PrintTifToPdf

[snuggles57]

Hello I am in need of some assistance with a Macro the EDGE chat thing has generated.

The Macro is supposed to combine tif images located in a nominated folder and convert and combine the images to single pdf. The macro generates the pdf however excel continues to (run) spin I am wondering if there is a line of code missing that stops the loop. I have to do CTRL ALT DEL and kill excel to make it stop.

Also I am a bit unsure if I am supposed to change anything other than the folderPath. Greatly appreciate any help. I did do a search but could find no specific results.

Sub PrintTifToPdf()
    'Declare variables
    Dim FolderPath As String
    Dim FileName As String
    Dim PdfName As String
    Dim ShellApp As Object
    Dim PdfFiles As Object
   
    'Set the folder path where the tif images are located
    FolderPath = "G:\Test"
   
    'Create a new instance of the Shell.Application object
    Set ShellApp = CreateObject("Shell.Application")
   
    'Loop through all the tif files in the folder
    FileName = Dir(FolderPath & "*.tif")
    Do While FileName <> "*.tif"
        'Set the pdf file name based on the tif file name
        PdfName = Replace(FileName, ".tif", ".pdf")
       
        'Print the tif file to pdf using the Microsoft Print to PDF printer
        Shell "rundll32.exe C:\WINDOWS\system32\shimgvw.dll,ImageView_PrintTo /pt """ & FolderPath & FileName & """ ""Microsoft Print to PDF"" ""Microsoft Print to PDF""", vbHide
       
        'Wait for the pdf file to be created
        Do While Dir(FolderPath & PdfName) = ""
            Application.Wait Now + TimeValue("0:00:01")
        Loop
       
        'Move to the next tif file
        FileName = Dir()
    Loop
   
    'Get all the pdf files in the folder as a collection
    Set PdfFiles = ShellApp.Namespace(FolderPath).Items
   
    'Filter the collection to include only pdf files
    PdfFiles.Filter 64, "*.pdf"
   
    'Combine all the pdf files into a single pdf file using the Shell.Application object
    ShellApp.Namespace(FolderPath & "Combined.pdf").CopyHere PdfFiles
   
    'Wait for the combined pdf file to be created
    Do While Dir(FolderPath & "Combined.pdf") = ""
        Application.Wait Now + TimeValue("0:00:01")
    Loop
   
    'Release the objects
    Set PdfFiles = Nothing
    Set ShellApp = Nothing
   
    'Inform the user that the macro is done
    MsgBox "All tif images have been printed and combined into a single pdf file.", vbInformation, "Macro Done"
End Sub

 

[John_w]

FolderPath must end with a back slash:

FolderPath = "G:\Test\"

And you can't use nested Dir loops because the inner Dir loop loses the context of the outer Dir loop. Use FileSystemObject instead.

 

[snuggles57]

Thanks for your input I changed the path to include the last Backslash and I am not sure where to use FileSystem Object. I can confirm that everything works up to the point of the macro asking me for the name of the PDF. And the PDF is created in the folder I select with the correct name (this is basically all I need). It seems like the bits after the FileName = Dir() is the problem.

When I use CTRL + pause and select debug it highlights the second last loop as you have indicated. I tried to comment out everything after the FileName = Dir() but got the error about do with no loop. What is the correct code to use to replace in the DIR loop? I was wondering if there is something else that should be included in the.

Set PdfFiles = Nothing
Set ShellApp = Nothing
Set"" = Nothing

FolderPath must end with a back slash:

FolderPath = "G:\Test\"

And you can't use nested Dir loops because the inner Dir loop loses the context of the outer Dir loop. Use FileSystemObject instead.

 

[John_w]

I am not sure where to use FileSystem Object

Use it instead of this loop:

    FileName = Dir(FolderPath & "*.tif")
    Do While FileName <> "*.tif"


       'Move to the next tif file
        FileName = Dir()
    Loop

like this:

    Dim FSO As Object 'Scripting.FileSystemObject
    Dim FSfolder As Object 'Scripting.Folder
    Dim FSfile As Object 'Scripting.File
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Loop through all the tif files in the folder
    
    Set FSfolder = FSO.GetFolder(FolderPath)
    For Each FSfile In FSfolder.Files
        If LCase(FSfile.Name) Like "*.tif" Then
            Debug.Print FSfile.Name
            Debug.Print FSfile.Path
        End If
    Next

Also, this line does not combine all the PDF files into a single PDF:

    'Combine all the pdf files into a single pdf file using the Shell.Application object
    ShellApp.Namespace(FolderPath & "Combined.pdf").CopyHere PdfFiles

An error will occur because the Namespace argument must be a folder path, not a file. If a folder path is specified, CopyHere simply copies the files in the PdfFiles collection to the folder.

To merge (combine) multiple PDFs to a single PDF, there are several 3rd party command line tools available, such as PDFtk Server. Search the forum for example code.