Convert images to one pdf using Adobe Acrobat Pro

[YasserKhalil]

Hello everyone
I have searched for this topic but couldn't find a good start. I have some images in a folder and I need VBA code to convert them to only one pdf file

[YasserKhalil]

I have found a start point. The code converts only one image to pdf but I need to adjust the pdf output to be fit to A4 size

Code: Select all

Sub Test()
    Dim avdoc As New Acrobat.AcroAVDoc, Acroapp As New Acrobat.Acroapp, pddoc As New Acrobat.AcroPDDoc
    Set Acroapp = CreateObject("AcroExch.App")
    Set avdoc = CreateObject("acroexch.avdoc")
    avdoc.Open ThisWorkbook.Path & "\Images\01.jpg", ""
    Set pddoc = avdoc.GetPDDoc()
    pddoc.Save PDSaveFull, ThisWorkbook.Path & "\WOO\01.pdf"
    Acroapp.Exit
    Acroapp.CloseAllDocs
    Set Acroapp = Nothing: Set avdoc = Nothing: Set pddoc = Nothing
End Sub

[SpeakEasy]

Personally, I have always found the automation parts of Acrobat to almost be hostile!

But I see you've found a start, and perhaps the code here may be of some use

[YasserKhalil]

Thanks a lot. Any idea how to modify the code so as to have A4 size in pdf output

[YasserKhalil]

this is the final solution but I welcome any other solutions (as this is too lengthy)

Code: Select all

Sub Convert_Images_To_PDF()
    Dim sFolder As String, sOutputFolder As String, sFile As String, sExt As String, sFileName As String
    sFolder = ThisWorkbook.Path & "\Images\"
    sOutputFolder = ThisWorkbook.Path & "\MyPDFs\"
    If Dir(sOutputFolder, vbDirectory) = "" Then MkDir sOutputFolder
    sFile = Dir(sFolder & "*.*")
    Do While sFile <> ""
        sExt = LCase(Right(sFile, Len(sFile) - InStrRev(sFile, ".")))
        If sExt = "jpg" Or sExt = "jpeg" Or sExt = "png" Or sExt = "bmp" Or sExt = "gif" Then
            sFileName = Left(sFile, InStrRev(sFile, ".") - 1)
            Call ExportImageToPDF(sFolder & sFile, sOutputFolder & sFileName & ".pdf")
        End If
        sFile = Dir
    Loop
    Call Merge_PDF_Files_Into_One
    MsgBox "Done", 64
End Sub

Public Sub ExportImageToPDF(ByVal srcFile As String, ByVal destFile As String)
    Dim ws As Worksheet, pic As Picture, maxHeight As Double, maxWidth As Double, aspectRatio As Double, picWidth As Double, picHeight As Double
    Set ws = ActiveSheet
    With ws
        .PageSetup.PaperSize = xlPaperA4
        maxHeight = Application.CentimetersToPoints(26.9)
        maxWidth = Application.CentimetersToPoints(19)
        .Range("A1").Activate
        Set pic = .Pictures.Insert(srcFile)
        aspectRatio = pic.ShapeRange.Width / pic.ShapeRange.Height
        If aspectRatio > 1 Then
            picWidth = maxWidth
            picHeight = maxWidth / aspectRatio
        Else
            picHeight = maxHeight
            picWidth = maxHeight * aspectRatio
        End If
        With pic.ShapeRange
            .LockAspectRatio = msoTrue
            .Width = picWidth
            .Height = picHeight
            .Top = (maxHeight - .Height) / 2
            .Left = (maxWidth - .Width) / 2
        End With
        .ExportAsFixedFormat Type:=xlTypePDF, FileName:=destFile, OpenAfterPublish:=False
        pic.Delete
    End With
End Sub

Private Sub Merge_PDF_Files_Into_One()
    Const destFileName As String = "MergedFile.pdf"
    Dim a() As String, myPath As String, destPath As String, myFiles As String, f As String, i As Long
    myPath = ThisWorkbook.Path & "\MyPDFs\"
    destPath = ThisWorkbook.Path & "\"
    ReDim a(1 To 2 ^ 14)
    f = Dir(myPath & "*.pdf")
    While Len(f)
        If StrComp(f, destFileName, vbTextCompare) Then
            i = i + 1
            a(i) = f
        End If
        f = Dir()
    Wend
    If i Then
        ReDim Preserve a(1 To i)
        myFiles = Join(a, ",")
        Application.StatusBar = "Merging, Please Wait ..."
        Call MergePDFs(myPath, myFiles, destPath & destFileName)
        Application.StatusBar = False
    Else
        MsgBox "No PDF Files Found In" & vbLf & myPath, vbExclamation, "Cancelled"
    End If
End Sub

Sub MergePDFs(ByVal myPath As String, ByVal myFiles As String, Optional ByVal destFile As String = "MergedFile.pdf")
    Dim a, acApp As New Acrobat.Acroapp, pDocs() As Acrobat.CAcroPDDoc, s As String, i As Long, j As Long, n As Long
    If Right(myPath, 1) = "\" Then s = myPath Else s = myPath & "\"
    a = Split(myFiles, ",")
    ReDim pDocs(0 To UBound(a))
    On Error GoTo Exit_
    If Len(Dir(destFile)) Then Kill destFile
    For i = 0 To UBound(a)
        If Dir(s & Trim(a(i))) = "" Then MsgBox "File Not Found" & vbLf & s & a(i), vbExclamation, "Cancelled": Exit For
        Set pDocs(i) = CreateObject("AcroExch.PDDoc")
        pDocs(i).Open s & Trim(a(i))
        If i Then
            j = pDocs(i).GetNumPages()
            If Not pDocs(0).InsertPages(n - 1, pDocs(i), 0, j, True) Then
                MsgBox "Cannot Insert Pages Of" & vbLf & s & a(i), vbExclamation, "Cancelled"
            End If
            n = n + j
            pDocs(i).Close
            Set pDocs(i) = Nothing
        Else
            n = pDocs(0).GetNumPages()
        End If
    Next i
    If i > UBound(a) Then
        If Not pDocs(0).Save(PDSaveFull, destFile) Then
            Debug.Print "Cannot Save The Resulting Document" & vbLf & destFile
        End If
    End If
Exit_:
    If Err Then
        MsgBox Err.Description, vbCritical, "Error #" & Err.Number
    ElseIf i > UBound(a) Then
        Debug.Print "The Resulting File Is Created:" & vbLf & destFile
    End If
    If Not pDocs(0) Is Nothing Then pDocs(0).Close
    Set pDocs(0) = Nothing: acApp.Exit: Set acApp = Nothing
End Sub

[StuartR]

It might be easier to use VBA to import all the images into a Word document and then print to the Acrobat printer.

[YasserKhalil]

Great idea. Thanks a lot for sharing.