شهادات PDF

[waledms]

السلام عليكم ورحمه الله وبركاته - أرجو طباعة الشهادات PDF 

2022شيت مدرستى شهادات الأول والثانى- الصف الأول.xls

[محمد هشام.]

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

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

Option Explicit
Private Const CopyRange As String = "A5:J49"
Private Const sFolder As String = "برنامج الكنترول شيت"
Private Const NamePDF As String = "شهادات الأول"
Private Const CrWS As String = "شهادات الأول بالقديرات"

Private Sub CommandButton1_Click()
    Dim tbl As Boolean: tbl = False
    On Error GoTo CleanExit
    Dim f As Worksheet: Set f = Sheets(CrWS)
    Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer
    Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range
   
    If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _
    MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub

    début = f.[J3].Value: fin = f.[R3].Value
    If début < 1 Or fin < 1 Or début > fin Then Exit Sub

    If MsgBox("هل ترغب بحفظ الشهادات من " & _
        début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub
    SetApp False
        On Error Resume Next
        Set WS = Sheets("PDF")
        If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True
        Set WS = Sheets.Add(After:=Sheets(Sheets.Count))
        WS.Name = "PDF": WS.DisplayRightToLeft = True
        On Error GoTo 0

    If WS Is Nothing Then: GoTo CleanExit
        tempFile = ThisWorkbook.Path & "\" & sFolder
        If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile
        tmp = 1
    Set OnRng = f.Range(CopyRange)

    For i = début To fin Step 5
        f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2)
        OnRng.Copy
        Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats
        Rng.PasteSpecial Paste:=xlPasteColumnWidths

        For row = 1 To OnRng.Rows.Count
            WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5
        Next

        If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1)
        tmp = tmp + OnRng.Rows.Count + 1
    Next

    With WS.PageSetup
        .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False
        .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2)
        .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False
    End With

    sPath = tempFile & "\" & NamePDF & ".pdf"
        On Error Resume Next
        WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        tbl = (Err.Number = 0)
        On Error GoTo 0
        f.[J3].Value = 1
        WS.Delete

CleanExit:
    SetApp True
    
        MsgBox IIf(tbl, _
                "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _
                "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _
                "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _
                "PDF" & "تصدير الشهادات بصيغة"
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
    End With
End Sub

وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية

 

 

 

 

 

شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf