استفسار بخصوص كود لطباعة الفريم

[صياد الجراح]

السلام عليكم ورحمته وبركاته

..اخوانى لكم منى الشكر والتقدير على مجهودكم الجبار فى هذا الصرح

استفسار  هل يمكن كتابة كود لطباعة الفريم فقط بدون الفورم ..انا استخدمت الكود التالى لطباعة الفورم

Sub print_userform()
UserForm1.PrintForm
End Sub

ولكن ببحث عن كود يطبع او يحفظ محتوي الفريم فقط بنفس التصميم  ودورت كتير بس لاسف مش لاقيه

كل  الاكواد اللى لاقيتها بتطبع الفورم كامل فقط..لكم ودى وتقديرى

 

تم تعديل أكتوبر 5, 2022 بواسطه صياد الجراح

[عبدالفتاح في بي اكسيل]

اذا كنت  لاتريد  اظهار  اليوزرفورم   كله  لا  حاجة لليوزرفورم استعين  بورقة لطباعة بيانات محددة من خلال  تحديد خلايا  محددة ، ثم  ما  الهدف  والفائدة من وراء ذلك؟

[صياد الجراح]

لان البيانات الموجوده فى  الفريم  واخدها من كذا ورقة عمل منفصلة..وكده مش حينفع اطبع من  ورقة العمل على طول 

وكده لازم اطبع الفريم او احفظ بياناته كماهو   

طباعة يوزر فورم  كامل  مع الفريم بياكل حبر الطابعة لان الخلفية بتكون ملونة او صورة وبيكون لون خلفية الورقة عند الطباعة اسود

لان الطباعة ابيض واسود..لك ودى وتقديرى

 

 

[عبدالفتاح في بي اكسيل]

لا اعتقد  انه  مشكلة  كما  ان  يبدو  انك  لم  تفهم  علي ، ما  قصدته  ان  تنشيء ورقة  مساعدة  متخصصة  بطباعة  ما  يظهر  باليوزرفورم سواء  كانت  بيانات  ورقة  او عدة  اوراق .

[صياد الجراح]

انا فكرت فى الموضوع ده بالفعل بس عشان اصمم ورقة عمل لكل فريم  واعمل ترحيل من الفريم لها

وخصوصا ان عدد الفريمات الموجوده حتكون كبير   حتحتاج وقت كبير اوى

وكمان حيكون هناك عدد كبير من اوراق العمل الرئيسية موجوده بالفعل  ده ممكن ثقل البرنامج   

exe وفكرت ايضا انى احول اليوزرفورم كلوه لبرنامج مستقل

بس حتكون اول مرة اعملها و  مش عارف وقتها حقدر اعمل طباعة لفريم لوحده ولا لا 

 

لك ودى وتقديرى  

 

[عبدالفتاح في بي اكسيل]

اطلاقا  لست  بحاجة  ان  تصمم  ورقة لكل  فريم  فقط  تقوم  بتعيين  رقم  الفورم  من  خلال  اجراء  معين  من  خلال  حلقة  تكرارية   لكل  الفريمات  ثم  تقوم  باختيار  الفريم  الذي  تريده   عن  طريق   checkbox  او  optionbutton   لورقة  واحدة  فقط  يتم  تخصيصها  للطباعة   ، ثم  لماذا  تستخدم  كل  هذه  الفريمات ؟

قريم  واحد  فقط  لاي  عدد  من  الاوراق    فقط  تقوم  بحلقة  تكرارية  لكل  الاوراق  من  خلال  فريم  واحد    يتم  جلب  الورقة  المحددة  داخل  نفس  الفريم  بناء  على  الكومبوبوكس .تحياتي .

 

[عبدالله بشير عبدالله]

السلام عليكم في الملف المرفق فيه طلبك ان شاء الله  

الملف الاصلي وهو من كنوز المنتدى

فورم ادخال و تعديل مرن مع الطباعة 1.xls

[صياد الجراح]

بسم الله الرحمن الرحيم

شكرا اخى عبد الفتاح على اهتمامك ... حعمل بحث واحاول افهم واوصل للطريقة اللى حضرتك قلت عليها الخاصة ب

 checkbox  او  optionbutton 

لك ودى وتقديرى

بسم الله الرحمن الرحيم

الف شكر اخى بشير على اهتمامك..للأسف الملف لم يعمل معايا بيطلع خطا ..استأذن حضرتك بوضع كود الطباعة منفرد  ..لك ودى وتقديرى

استذان حضرتك بوضع كود الطباعة منفرد  ..لك ودى وتقديرى

 

[عبدالله بشير عبدالله]

الكوود المرتبط بزر الطباعة

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

 

[صياد الجراح]

شكرا اخى بشير

ولكن الكود لم يعمل معايا  اكيد لان المسميات مختلفه وبالتالى محتاج شرح تفصيلى له عشان اقدر اظبطوه بشكل سليم

ومش عارف باقى الاكواد  فى اى ربط بينها وبين كود زر الطباعة ولالا

الخطأ بيظهر معايا فى الكود الخاص بالمعاينة  

على العموم الف شكر اخى

لك ودى وتقديرى لشخصك الكريم