اخي العزيز
اذا كنت تقصد ان البيانات الناتجة عن الفلترة اذا كانت اكثر من صفحة واحدة وتريد طباعتها في صفحة واحدة ربما هذا الملف قيه الحل
'طباعة حسب البيانات1.xlsm
عبدالله بشير عبدالله's post in تصنف was marked as the answer
وعليكم السلام ورحمة الله وبركاته
قم بالاختيار من الخانتين الحمراء او احداهما تم اضغط زر تصفية لا تنسى تمكين المحتوى اذا طلبه الاوفيس منك
اتمنى انى قدمت لك ما يفيد
طلاب.xlsm
وعليكم السلام ورحمة الله وبركاته
طلبك غير واضح بالنسبة لي هل تريد اخفاء الليبل فقط ام يتم معه اخفاء التكست بوكس ايضا
علي كل حال اليك ملف اخفاء الليبل فقط
اخفاء الليبل.xlsm
وهذا اخفاء الليبل مع التكست بوكس الاثنين
اخفاء الليبلوالتكست.xlsm
واختر ما يخقق طلبك
تحياتي
الكوود المرتبط بزر الطباعة
Private Sub ButtonPrint_Click()
If Me.Frame1.ScrollHeight > Me.Frame1.Height Then
Print1
Else
If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÓÌá Úáì ÇáÝæÑã ¿ ", vbYesNo + mBox, "ØÈÇÚÉ Úáì ÇáÝæÑã ") = vbYes Then
Print2
Else
Print1
End If
End If
End Sub
Private Sub Print1()
Dim ctl As Control
Dim i As Integer
Me.Hide
'------------------------
With Workbooks.Add(xlWBATWorksheet)
.Activate
For i = 1 To LastColumn
Cells(i, "A").Value = CStr(Me.Controls("Labeldt" & i))
Cells(i, "B").Value = CStr(Me.Controls("Textdt" & i))
Next
With Range("A1").Resize(LastColumn, 2)
.ColumnWidth = 35
.Borders.LineStyle = 1
.PrintPreview
End With
.Close False
End With
'------------------------
Me.Show
End Sub
Private Sub Print2()
Print_Visible False
''''''''''''''''''''''''''
If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÝæÑã ÍÓÈ åÐå ÇáãÚÇíäÉ ¿ ", vbYesNo + mBox, "ãÚÇíäÉ ÞÈá ÇáØÈÇÚÉ") = vbYes Then
On Error Resume Next
Me.PrintForm
On Error GoTo 0
End If
''''''''''''''''''''''''''
Print_Visible True
kh_Enabled True
End Sub
اما باقي اكواد الفورم فربمما الكود في الاعلى مرتبط بباقي الاكواد
Option Explicit
'======================================================
'======================================================
' ÊäÓíÞ ÇáÊÇÑíÎ
Private Const DtF As String = "yyyy/mm/dd"
'======================================================
' ÚõÑÖ ÊÇßÓÊ ÇáÇÏÎÇá
Private Const iWgt1 As Single = 200
'======================================================
Private Const Frmtop As Single = 3
Private Const Frmlft As Single = 3
Private Const iHgt As Single = 21.55
Private Const iTop As Single = iHgt + 2
Private Const mBox As Long = vbMsgBoxRight + vbMsgBoxRtlReading
'======================================================
'======================================================
Private Ar() As Integer
Private MyRngSeri As Range
Private MyRngdate As Range
Private ContRow As Long
Private iRow As Long
Private LastColumn As Integer
Private tSr As Boolean
Private MyList As String
Private tAc As Boolean
Private iColor1, iColor2
Private Sub BoxFind_Click()
Dim tm As Integer
Me.ListFind.Clear
tm = Me.BoxFind.Tag
Me.Controls("Labeldt" & tm).ForeColor = vbBlack
tm = Me.BoxFind.ListIndex + 1
Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor
Me.BoxFind.Tag = tm
End Sub
Private Sub ButtonCalendar_Click()
On Error GoTo 1
Dim MyVelue, t
With Me.Frame1
If .ActiveControl Is Nothing Then .SetFocus
If TypeOf .ActiveControl Is MSForms.TextBox Then
.ActiveControl.BackColor = Me.ButtonCalendar.BackColor
If .ActiveControl.Top > .Height Then .ScrollTop = .ActiveControl.Top - (.Height / 2)
MyVelue = .ActiveControl
t = .Controls(.ActiveControl.TabIndex + 1)
If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then Else MyVelue = Date
With FormDate
.Caption = t
.Tag = MyVelue
.Show
End With
.ActiveControl.BackColor = &HFFFFFF
Else
MsgBox "áÇ íãßä ÇÖÇÝÉ ÇáÊÇÑíÎ Ýí ÞÇÆãÉ", mBox, "ÊäÈíå"
End If
End With
1
If Err Then Err.Clear
End Sub
Private Sub ButtonClear_Click()
kh_ClearRecord
End Sub
Private Sub ButtonEnd_Click()
Me.ScrollBar1.Value = ContRow
End Sub
Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False)
Dim tm As Integer
''''''''''''''''''''''''''''''''
For tm = 2 To LastColumn
If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then
Me.Controls("Textdt" & tm) = ""
End If
Next
End Sub
Private Sub kh_AddNewRecord()
Dim C As Integer
''''''''''''''''''
Me.Frame1.ScrollTop = 0
kh_ClearRecord True
''''''''''''''''''
Me.LabelSerial = ContRow + 1
Me.LabelSerial2 = ContRow + 1 & " - " & ContRow + 1
kh_Enabled False
''''''''''''''''''
With Me.Controls("Textdt1")
If .Enabled Then
.SetFocus
.Text = "íÌÈ ÇáÇÏÎÇá Ýí åÐå ÇáÎáíÉ ÇÝÊÑÇÖíÇð"
.SelStart = 0
.SelLength = .TextLength
Else
.Text = "........"
End If
End With
End Sub
Private Sub ButtonGo_Click()
With MyRngdate
.Worksheet.Activate
.Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select
End With
Unload Me
End Sub
Private Sub ButtonNew_Click()
kh_AddNewRecord
End Sub
Private Sub ButtonNewCancel_Click()
ScrollBar1_Change
End Sub
Private Sub ButtonNewSave_Click()
If kh_TestBlank() Then Exit Sub
Dim cRow As Long: cRow = ContRow + 1
Me.ScrollBar1.Max = cRow
kh_SaveDate cRow, True
Me.ScrollBar1.Value = cRow
Call MsgBox(" Êã ÍÝÙ ÇáÓÌá ÇáÌÏíÏ ÈäÌÇÍ ", mBox, "ÇáÍãÏááå")
End Sub
Private Sub ButtonPrint_Click()
If Me.Frame1.ScrollHeight > Me.Frame1.Height Then
Print1
Else
If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÓÌá Úáì ÇáÝæÑã ¿ ", vbYesNo + mBox, "ØÈÇÚÉ Úáì ÇáÝæÑã ") = vbYes Then
Print2
Else
Print1
End If
End If
End Sub
Private Sub Print1()
Dim ctl As Control
Dim i As Integer
Me.Hide
'------------------------
With Workbooks.Add(xlWBATWorksheet)
.Activate
For i = 1 To LastColumn
Cells(i, "A").Value = CStr(Me.Controls("Labeldt" & i))
Cells(i, "B").Value = CStr(Me.Controls("Textdt" & i))
Next
With Range("A1").Resize(LastColumn, 2)
.ColumnWidth = 35
.Borders.LineStyle = 1
.PrintPreview
End With
.Close False
End With
'------------------------
Me.Show
End Sub
Private Sub Print2()
Print_Visible False
''''''''''''''''''''''''''
If MsgBox(" åá ÊÑíÏ ØÈÇÚÉ ÇáÝæÑã ÍÓÈ åÐå ÇáãÚÇíäÉ ¿ ", vbYesNo + mBox, "ãÚÇíäÉ ÞÈá ÇáØÈÇÚÉ") = vbYes Then
On Error Resume Next
Me.PrintForm
On Error GoTo 0
End If
''''''''''''''''''''''''''
Print_Visible True
kh_Enabled True
End Sub
Private Sub Print_Visible(v As Boolean)
Dim ctl As Control
''''''''''''''''''''''''''
If v Then
Me.BackColor = iColor1
With Me.Frame1
.BackColor = iColor2
.SpecialEffect = 3
End With
Else
Me.BackColor = vbWhite
With Me.Frame1
.BackColor = vbWhite
.SpecialEffect = 0
End With
End If
''''''''''''''''''''''''''
For Each ctl In Me.Controls
If ctl.Parent.Name <> "Frame1" Then
If ctl.Name <> "Frame1" Then ctl.Visible = v
End If
Next
''''''''''''''''''''''''''
For Each ctl In Me.Frame1.Controls
If TypeOf ctl Is MSForms.ComboBox Then
ctl.ShowDropButtonWhen = IIf(v, 2, 0)
End If
Next
End Sub
Private Sub ButtonSaveDate_Click()
If kh_TestBlank() Then Exit Sub
kh_SaveDate iRow
ScrollBar1_Change
Call MsgBox(" Êã ÍÝÙ ÇáÊÛííÑÇÊ ÈäÌÇÍ ", mBox, "ÇáÍãÏááå")
End Sub
Private Function kh_TestBlank() As Boolean
If Len(Trim(Me.Controls("Textdt1"))) = 0 Then
kh_TestBlank = True
Me.Controls("Textdt1").SetFocus
Call MsgBox("ÇáÚãæÏ : " & Me.Controls("Labeldt1") & vbCr & vbCr & "íÌÈ ÇáÇÏÎÇá Ýí åÐå ÇáÎáíÉ ÇÝÊÑÇÖíÇð", mBox + vbCritical, "ÇÓÊÎÏÇã ÎÇØìÁ")
End If
End Function
Private Sub kh_AutoFill()
Dim CelFill As Range, CFil As Range
Dim R As Integer
''''''''''''''''''''''''''
If tSr Then
Set CelFill = Union(MyRngSeri, MyRngdate)
Else
Set CelFill = MyRngdate
End If
''''''''''''''''''''''''''
For R = 1 To CelFill.Areas.Count
Set CFil = CelFill.Areas(R).Rows(ContRow + 1)
With CFil
.AutoFill .Resize(2), xlFillDefault
End With
Next
Set CelFill = Nothing
Set CFil = Nothing
End Sub
Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False)
Dim MyVelue, Msg
Dim C As Integer, cc As Integer
''''''''''''''''''''''''''
'On Error GoTo 1
''''''''''''''''''''''''''
Application.Calculation = xlCalculationManual
''''''''''''''''''''''''''
If nR > 1 And tFil Then kh_AutoFill
If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR
'''''''''''''''''''''''''''
For cc = 1 To LastColumn
C = Ar(cc)
If Me.Controls("Textdt" & cc).Enabled = True Then
With MyRngdate
MyVelue = Me.Controls("Textdt" & cc).Text
If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then
MyVelue = Format(MyVelue, DtF)
Else
If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then
Msg = MsgBox("ÇáÎáíÉ Ýí ÇáÚãæÏ : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _
& "ãäÓÞÉ ßÊÇÑíÎ æÇáÇÏÎÇá ÇáÌÏíÏ ÑÞã" & vbCr & vbCr _
& "åá ÊÑíÏ ãÓÍ ÊäÓíÞÇÊ ÇáÇÑÞÇã ÇáÓÇÈÞÉ ¿¿", mBox + vbYesNo, "ÊÃßíÏ ãÓÍ ÊäÓíÞÇÊ ÇáÊÇÑíÎ ÇáÓÇÈÞÉ ¿¿ ")
'''''''''''''''''''''''''
If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = ""
End If
End If
.Cells(nR + 1, C).Value = MyVelue
End With
End If
Next
''''''''''''''''''''''''''
1:
Application.Calculation = xlCalculationAutomatic
''''''''''''''''''''''''''
End Sub
Private Sub ButtonExit_Click()
Unload Me
End Sub
Private Sub ButtonDelete_Click()
If MsgBox(" åá ÊÑíÏ ÍÐÝ ÇáÓÌá ÑÞã : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "ÊÇßíÏ ÇáÍÐÝ ") = vbNo Then Exit Sub
If Me.ListFind.ListCount Then Me.ListFind.Clear
MyRngdate.Rows(iRow + 1).EntireRow.Delete
If Not tSr Then GoTo 1
If iRow = ContRow Then GoTo 1
With MyRngSeri
.Cells(iRow + 1, 1).Value = iRow
Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries
End With
1:
Me.ScrollBar1.Max = ContRow - 1
ScrollBar1_Change
Call MsgBox(" Êã ÍÐÝ ÇáÓÌá ÈäÌÇÍ ", mBox, "ÇáÍãÏááå")
End Sub
Private Sub ButtonTop_Click()
If ContRow Then Me.ScrollBar1.Value = 1
End Sub
Private Sub CheckFind_Click()
Me.ListFind.Clear
Me.LblFindCount = 0
End Sub
Private Sub CheckFindDate_Click()
If Me.CheckFindDate.Value = True Then
kh_SetDate Me.TextFind
''''''''''''''''''''''''''''
End If
End Sub
Private Sub LabelH2_Click()
Call MsgBox(" ÓíÊã ÊÍæíá Çí ÞíãÉ ÊÖÚåÇ Ýí ãÑÈÚ ÇáäÕ ááÈÍË " _
& vbCr & vbCr & "Çáì ÊÇÑíÎ ÈÇáÊäÓíÞ ÇáÇÝÊÑÇÖí ááÝæÑã ,,,,,,," _
& vbCr & String$(40, "=") _
& vbCr & vbCr & "ãÚ ÇãßÇäíÉ ÇÏÎÇá ÑÞã ÕÍíÍ Èíä 1 Çáì 31 áíÝåã Úáì Çäå " _
& vbCr & vbCr & "ÊÇÑíÎ Çáíæã ááÔåÑ ÇáÍÇáí æÇáÓäÉ ÇáÍÇáíÉ " _
, mBox + vbQuestion + vbApplicationModal, "ÊÚáíãÇÊ")
'''''''''''''''''''''''''''
End Sub
Private Sub ListFind_Click()
Dim RR As Long
RR = Me.ListFind.Column(1)
Me.ScrollBar1.Value = RR
End Sub
Private Sub ScrollBar1_Change()
Dim MyVelue
Dim C As Integer, cc As Integer
Me.Frame1.ScrollTop = 0
With Me.ScrollBar1
If ContRow = 0 Then .Min = 1
iRow = .Value: ContRow = .Max
End With
'''''''''''''''''
For cc = 1 To LastColumn
C = Ar(cc)
With MyRngdate
If IsDate(.Cells(iRow + 1, C)) Then
MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF)
Else: MyVelue = .Cells(iRow + 1, C).Value2
End If
End With
On Error Resume Next
Me.Controls("Textdt" & cc).Text = ""
Me.Controls("Textdt" & cc).Text = MyVelue
On Error GoTo 0
Next
'------------------------------
Me.LabelSerial.Caption = iRow
Me.LabelSerial2.Caption = iRow & " - " & ContRow
kh_Enabled True
End Sub
Private Sub TextFind_Change()
With Me.ListFind
If .ListCount Then .Clear
End With
Me.LblFindCount = 0
Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False)
End Sub
Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Me.CheckFindDate.Value = False Then Exit Sub
kh_SetDate Me.TextFind
End Sub
' åÐÇ ÇáßæÏ íÑÛãß ÈÇÏÎÇá ÊÇÑíÎ
Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control)
Dim dtest, dt
dtest = dCntrl
If Not IsDate(dtest) Then
If IsNumeric(dtest) Then
On Error Resume Next
dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF)
If Err Then dt = Format(Date, DtF)
On Error GoTo 0
Else
dt = Format(Date, DtF)
End If
Else: dt = Format(CDate(dtest), DtF)
End If
dCntrl = dt
End Sub
Private Sub TextSerial_Change()
Dim v
v = Me.TextSerial.Text
If Len(v) = 0 Then Exit Sub
If Not IsNumeric(v) Then GoTo 1
If v = 0 Or v > ContRow Then GoTo 1
Exit Sub
'=======================
1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1)
End Sub
Private Sub TextSerial_AfterUpdate()
If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = ""
End Sub
Private Sub kh_Enabled(ByVal Ebl As Boolean)
Me.ButtonNewSave.Visible = Not Ebl
Me.ButtonNewCancel.Visible = Not Ebl
Me.ButtonNew.Visible = Ebl
Me.ButtonSaveDate.Visible = Ebl
''''''''''''''''''''''''''''''''''''''''''''
Me.ButtonPrint.Enabled = Ebl
Me.ButtonSaveDate.Enabled = Ebl
Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False)
''''''''''''''''''''''''''''''''
Me.ButtonEnd.Enabled = CBool(iRow <> ContRow)
Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1)
Me.ButtonNewCancel.Enabled = IIf(iRow, True, False)
Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl)
End Sub
Private Sub ButtonSerach_Click()
Dim tb1 As Boolean, ib As Boolean
Dim R As Long, RR As Long
Dim C As Integer
Dim MyFind, MySrch, MyVelue
''''''''''''''''''''''
Me.ListFind.Clear
If Len(Trim(Me.TextFind)) = 0 Then Exit Sub
'''''''''''''''''''''
C = Me.BoxFind.ListIndex + 1
tb1 = CBool(Me.CheckFindDate.Value = True)
If tb1 Then
If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind
MyFind = CDbl(CDate(Me.TextFind))
Else
MyFind = Me.TextFind.Value
End If
'''''''''''''''''''''''
With MyRngdate.Cells(2, Ar(C))
For R = 1 To ContRow
If Len(Trim(.Cells(R, 1))) Then
If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value
ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare))
If ib Then
MyVelue = .Cells(R, 1).Value
If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF)
Me.ListFind.AddItem MyVelue
Me.ListFind.List(RR, 1) = R
RR = RR + 1
End If
End If
Next
End With
Me.LblFindCount = Me.ListFind.ListCount
If RR = 0 Then MsgBox " áÇ ÊæÌÏ äÊÇÆÌ áÈÍËß åÐÇ ", mBox, "ÊäÈíå"
'''''''''''''''''''''''''
End Sub
Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "")
tSr = TypeName(Evaluate(aSr)) = "Range"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook
If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr)
Set MyRngdate = .Worksheets(MySht).Range(MyAddrs)
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With MyRngdate
ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row
LastColumn = .Cells.Count
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Col As Range
Dim ii As Integer
ReDim Ar(1 To LastColumn)
For Each Col In MyRngdate.Cells
ii = ii + 1
Ar(ii) = Col.Column - MyRngdate.Column + 1
Next
'''''''''''''''''''''''''''
End Sub
Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean
If Not Rng.Comment Is Nothing Then
MyList = Trim(Replace(Rng.Comment.Text, Chr(10), ""))
MyList = Replace(MyList, " ", "")
If TypeName(Evaluate(MyList)) = "Range" Then
kh_TestType = True
End If
End If
End Function
Private Sub UserForm_Activate()
Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double
Dim MyBox As Control, MyLabl As Control
Dim t As Integer
Dim tTp As Boolean
Dim MyType As String
'''''''''''''''''''''
If tAc Then Exit Sub
Me.Caption = MyRngdate.Worksheet.Name
MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2)
With Frame1
If MyScrollHeight > .Height Then
.ScrollBars = 2
.ScrollHeight = MyScrollHeight
End If
End With
MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2))
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For t = 1 To LastColumn
tTp = kh_TestType(MyRngdate.Cells(1, Ar(t)))
MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1")
Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True)
With MyBox
.Move Frmlft, MyTop, iWgt1, iHgt
.TextAlign = 3
If tTp Then
.BackColor = 16761024
.ControlTipText = "ÅÎÊÑ ãä ÇáÞÇÆãÉ"
On Error Resume Next
.List = Range(MyList).Value
If Err Then .AddItem Range(MyList).Cells(1, 1).Value
On Error GoTo 0
End If
If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then
.BackStyle = 0
.TextAlign = 2
.SpecialEffect = 3
.Enabled = False
End If
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True)
With MyLabl
.Move iWgt1 + Frmlft, MyTop, MyWith, iHgt
.SpecialEffect = 3
.TextAlign = 2
.Caption = MyRngdate.Cells(1, Ar(t))
End With
'''''''''''''''''''''''''''''''''''
Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2
MyTop = MyTop + iTop
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Me.BoxFind
.Style = 2
.Tag = 1
.ListIndex = 0
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Me.ScrollBar1
.Max = ContRow
If ContRow Then
.Min = 1
.Value = ContRow
Else
kh_AddNewRecord
End If
End With
tAc = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
Private Sub UserForm_Initialize()
Dim Zo%
Dim ZH#, ZW#, AL#, AT#, AH#, AW#
Dim FH!, FW!
'===========================================
AH = Application.Height: AW = Application.Width
AL = Application.Left: AT = Application.Top
FH = Height: FW = Width
ZH = AH - FH: ZW = AW - FW: Zo = Zoom
If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW)
'===========================================
Move AL, AT, AW, AH
If Zo <> 100 Then Zoom = Zo
''''''''''''''''''''''''
iColor1 = Me.BackColor
iColor2 = Me.Frame1.BackColor
End Sub
Private Sub UserForm_Terminate()
Set MyRngdate = Nothing
Erase Ar
Unload FormDate
End Sub
