كود لطباعة أو تصدير البيانات الى ملفات PDF

كود لطباعة أو تصدير البيانات الى ملفات PDF

Code VBA To Print PDF

طباعة أو تصدير البيانات الى ملفات PDF

سنعرض ثلاثة طرق لطباعة البيانات أو تصديرها بمعنى أدق إلى ملفات PDF

أولا :  طباعة أو تصدير المصنف بأكمله الى PDF

Code VBA Excel To Print or export the entire  All Workbook to PDF

تلميحات 

يجب أن تقوم بتحديد نطاقات الطباعة لكل شيت بداخل المصنف 

حيث انه سيتم تحويل كامل المصنف الى PDF

فى حالة عدم تحديد نطاق الطباعة سيتم طباعه أوراق بيضاء بداخل ملف الـ PDF

الشفرة المستخدمة 

'Permits any person to use this code provided that the source is mentioned
'https://elshriefacademy.blogspot.com

Option Explicit

Function CrePDF(Myvar As Object, PathName As String, _
OverFile As Boolean, OpenPDF As Boolean) As String

    Dim FilTex As String
    Dim Fname As Variant

    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" & _
    Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
        If PathName = "" Then
            FilTex = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", _
            filefilter:=FilTex, Title:="Create PDF")

            If Fname = False Then Exit Function
        Else
            Fname = PathName
        End If
        If OverFile = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If
        On Error Resume Next
        Myvar.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Fname, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=OpenPDF
        On Error GoTo 0
        If Dir(Fname) <> "" Then CrePDF = Fname
    End If
    
End Function


Sub WorPDF()
    Dim FileName As String

    FileName = CrePDF(ActiveWorkbook, "", True, True)

    If FileName <> "" Then
    
    Else
        MsgBox "File not created for one of the following reasons:" & vbNewLine & _
               "You did not choose a file name or file path" & vbNewLine & _
               "Your device does not have a file reader installed PDF" & vbNewLine & _
               "The save path is incorrect" & vbNewLine & _
               "The file already exists can not be overwritten"

   End If
End Sub

ثم يتم وضع زر أو شكل داخل ورقة العمل وربطها بالشفرة ( تختار اسم الشفرة WorPDF )
ومن الممكن وضع الشفرة داخل موديول وربطها بزر داخل نموذج UserForm


ثانيا : تحديد نطاق من خلال الماوس لطباعته PDF
Code VBA Excel To Select a range through the mouse to print it to PDF

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

الشفرة المستخدمة
لاحظ  الـ Function المستخدمة بالشفرة السابقة سنتستخدمها أيضا بالشفرة التالية

'Permits any person to use this code provided that the source is mentioned
'https://elshriefacademy.blogspot.com

Option Explicit

Function CrePDF(Myvar As Object, PathName As String, _
OverFile As Boolean, OpenPDF As Boolean) As String

    Dim FilTex As String
    Dim Fname As Variant

    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" & _
    Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
        If PathName = "" Then
            FilTex = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", _
            filefilter:=FilTex, Title:="Create PDF")

            If Fname = False Then Exit Function
        Else
            Fname = PathName
        End If
        If OverFile = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If
        On Error Resume Next
        Myvar.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Fname, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=OpenPDF
        On Error GoTo 0
        If Dir(Fname) <> "" Then CrePDF = Fname
    End If
    
End Function



Sub SelectPDF()
    Dim FileName As String
    Dim Selc
    
    Selc = Selection.Address
    
    If ActiveWindow.SelectedSheets.Count > 1 Then
    MsgBox "There is more than one worksheet selected" & vbNewLine
    Else
        FileName = CrePDF(Range(Selc), "", True, True)
        
        If FileName <> "" Then
        Else
        MsgBox "File not created for one of the following reasons:" & vbNewLine & _
               "You did not choose a file name or file path" & vbNewLine & _
               "Your device does not have a file reader installed PDF" & vbNewLine & _
               "The save path is incorrect" & vbNewLine & _
               "The file already exists can not be overwritten"
          End If
    End If
End Sub

ثم يتم وضع زر أو شكل داخل ورقة العمل وربطها بالشفرة ( تختار اسم الشفرة SelectPDF )
ومن الممكن وضع الشفرة داخل موديول وربطها بزر داخل نموذج UserForm


ثالثا : تصدير نطاق الطباعة المحدد (Print Area) فقط الى PDF 
Code VBA Excel To Print only the Print Area

هنا يتم مباشرة تحويل النطاق المحدد (Print Area)لطباعته الى PDF

الشفرة المستخدمة

'Permits any person to use this code provided that the source is mentioned
'https://elshriefacademy.blogspot.com

Option Explicit

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
  Dim FileFormatstr As String
  Dim Fname As Variant

 If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
    & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

    If FixedFilePathName = "" Then
       FileFormatstr = "PDF Files (*.pdf), *.pdf"
       Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                              Title:="Create PDF")

            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function

Sub RDB_PrintArea_Range_To_PDF()
  On Error Resume Next
    Dim FileName As String
    If ActiveWindow.SelectedSheets.Count > 1 Then
        MsgBox "There is more then one sheet selected," & vbNewLine & _
               "ungroup the sheets and try the macro again"
    Else
   
    Dim rng As Range
    On Error Resume Next
    Set rng = Range(ActiveSheet.PageSetup.PrintArea)
    If Not rng Is Nothing Then
        Debug.Print rng.Address(external:=True)
    rng.Select
        FileName = Create_PDF(Selection, ActiveSheet.[J1].Value, True, True)
        If FileName = "" Then
        Else
            MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                   "Microsoft Add-in is not installed" & vbNewLine & _
                   "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                   "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                   "You didn't want to overwrite the existing PDF if it exist"
        End If
            End If
    End If
End Sub

ثم يتم وضع زر أو شكل داخل ورقة العمل وربطها بالشفرة ( تختار اسم الشفرة PrintArea_Range_To_PDF )
ومن الممكن وضع الشفرة داخل موديول وربطها بزر داخل نموذج UserForm