VBA to Convert and Merge .PNG to .PDF

M

michele227

New Member
Joined
Feb 15, 2023
Messages
15
Office Version
  1. 2019
Platform
  1. Windows
Hi everyone,

I am brand new to VBA!

I am currently working on a VBA that merges multiple selected .png files into one .pdf.
Each image to be the full size of a separate page.

It starts by opens up a file dialog to a specific path.
It then allows you to pick multiple image files.
It then creates a new sheet per image selected named "Sketch1," "Sketch2," etc.
It then pastes each image per sheet.
All of the new sheets are then selected and saved as a pdf.
All new sheets are then deleted.

This is my code currently.
I managed to make it work with 2 images but I can't make it work with 3, 4, or more images.
It ends up pasting 3 images in "Sketch1" and 1 image in "Sketch 4,"
I am also sure there is a better way to condense the code but I can't wrap my brain around loops or integers.
I would really appreciate some guidance :).

Thank you in advance!

Sub SavePNGtoPDF()

Set FSO = CreateObject("Scripting.FileSystemObject")
Dim sheetArray As Variant
Dim pdfname As String
Dim pdfpath As String

pdfname = Sheets("Sheet1").Range("Q2").Value
pdfpath = Sheets("Sheet1").Range("O17").Value

Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.InitialFileName = pdfpath
xFileDlg.AllowMultiSelect = True
If xFileDlg.Show = 0 Then
Exit Sub
End If


If xFileDlg.SelectedItems.Count = 4 Then
Sheets.Add.Name = "Sketch1"
With ActiveSheet.PageSetup
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Zoom = 150
End With
Sheets.Add.Name = "Sketch2"
With ActiveSheet.PageSetup
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Zoom = 150
End With

Sheets.Add.Name = "Sketch3"
With ActiveSheet.PageSetup
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Zoom = 150
End With

Sheets.Add.Name = "Sketch4"
With ActiveSheet.PageSetup
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Zoom = 150
End With
For Each xSelItem In xFileDlg.SelectedItems
Set myPic = ActiveSheet.Pictures.Insert(xSelItem)
Sheets(Array("Sketch1", "Sketch2", "Sketch3", "Sketch4")).Select
Next

ElseIf xFileDlg.SelectedItems.Count = 2 Then
Sheets.Add.Name = "Sketch1"
With ActiveSheet.PageSetup
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Zoom = 150
End With
Sheets.Add.Name = "Sketch2"
With ActiveSheet.PageSetup
.PaperSize = xlPaperLegal
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Zoom = 150
End With
For Each xSelItem In xFileDlg.SelectedItems
Set myPic = ActiveSheet.Pictures.Insert(xSelItem)
Sheets(Array("Sketch1", "Sketch2")).Select
Next
End If

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfpath & pdfname & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

Set myPic = Nothing
Set NewSheet = Nothing
Set MyFolder = Nothing
Set FSO = Nothing

End Sub
Click to expand...
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
Hi and welcome to MrExcel.
I give you 2 macros, both codes work for one or several images.

This code considers the same as in your code to configure each sheet when you create it:
VBA Code: 
Sub SavePNGtoPDF_1()
  Dim myPic As Object
  Dim sheetArray() As Variant, xSelItem As Variant
  Dim pdfname As String, pdfpath As String
  Dim xFileDlg As FileDialog
  Dim i As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  pdfname = Sheets("Sheet1").Range("Q2").Value
  pdfpath = Sheets("Sheet1").Range("O17").Value
 
  Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
  xFileDlg.InitialFileName = pdfpath
  xFileDlg.AllowMultiSelect = True
  If xFileDlg.Show = 0 Then Exit Sub
 
  For Each xSelItem In xFileDlg.SelectedItems
    Sheets.Add.Name = "Sketch" & i
    ReDim Preserve sheetArray(i)
    sheetArray(i) = "Sketch" & i
    i = i + 1
    Set myPic = ActiveSheet.Pictures.Insert(xSelItem)

    With ActiveSheet.PageSetup
      .PaperSize = xlPaperLegal
      .Orientation = xlLandscape
      .LeftHeader = ""
      .CenterHeader = ""
      .RightHeader = ""
      .LeftFooter = ""
      .CenterFooter = ""
      .RightFooter = ""
      .LeftMargin = Application.InchesToPoints(0.15)
      .RightMargin = Application.InchesToPoints(0.15)
      .TopMargin = Application.InchesToPoints(0.15)
      .BottomMargin = Application.InchesToPoints(0.15)
      .PrintHeadings = False
      .PrintGridlines = False
      .PrintComments = xlPrintNoComments
      .PrintQuality = 600
      .CenterHorizontally = True
      .CenterVertically = True
      .Zoom = 150
    End With
  Next

  Sheets(sheetArray).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfpath & pdfname & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
 
  ActiveWindow.SelectedSheets.Delete
  Application.DisplayAlerts = True
End Sub

But this code only sets one sheet once, then that sheet is copied for each image, in my tests this version is faster, but try both and see which one works best for you:

VBA Code: 
Sub SavePNGtoPDF()
  Dim myPic As Object
  Dim sheetArray() As Variant, xSelItem As Variant
  Dim pdfname As String, pdfpath As String
  Dim xFileDlg As FileDialog
  Dim i As Long
  Dim sh As Worksheet
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  pdfname = Sheets("Sheet1").Range("Q2").Value
  pdfpath = Sheets("Sheet1").Range("O17").Value
 
  Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
  xFileDlg.InitialFileName = pdfpath
  xFileDlg.AllowMultiSelect = True
  If xFileDlg.Show = 0 Then Exit Sub
 
  Sheets.Add after:=Sheets(Sheets.Count)
  Set sh = ActiveSheet
  With sh.PageSetup
    .PaperSize = xlPaperLegal
    .Orientation = xlLandscape
    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0.15)
    .RightMargin = Application.InchesToPoints(0.15)
    .TopMargin = Application.InchesToPoints(0.15)
    .BottomMargin = Application.InchesToPoints(0.15)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = True
    .CenterVertically = True
    .Zoom = 150
  End With
 
  For Each xSelItem In xFileDlg.SelectedItems
    sh.Copy after:=Sheets(Sheets.Count)
    ReDim Preserve sheetArray(i)
    sheetArray(i) = ActiveSheet.Name
    i = i + 1
    Set myPic = ActiveSheet.Pictures.Insert(xSelItem)
  Next

  Sheets(sheetArray).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfpath & pdfname & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
 
  ActiveWindow.SelectedSheets.Delete
  sh.Delete
  Application.DisplayAlerts = True
End Sub
 
Upvote 1
Solution
DanteAmor said:
Hi and welcome to MrExcel.
I give you 2 macros, both codes work for one or several images.

This code considers the same as in your code to configure each sheet when you create it:
VBA Code: 
Sub SavePNGtoPDF_1()
  Dim myPic As Object
  Dim sheetArray() As Variant, xSelItem As Variant
  Dim pdfname As String, pdfpath As String
  Dim xFileDlg As FileDialog
  Dim i As Long
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  pdfname = Sheets("Sheet1").Range("Q2").Value
  pdfpath = Sheets("Sheet1").Range("O17").Value
 
  Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
  xFileDlg.InitialFileName = pdfpath
  xFileDlg.AllowMultiSelect = True
  If xFileDlg.Show = 0 Then Exit Sub
 
  For Each xSelItem In xFileDlg.SelectedItems
    Sheets.Add.Name = "Sketch" & i
    ReDim Preserve sheetArray(i)
    sheetArray(i) = "Sketch" & i
    i = i + 1
    Set myPic = ActiveSheet.Pictures.Insert(xSelItem)

    With ActiveSheet.PageSetup
      .PaperSize = xlPaperLegal
      .Orientation = xlLandscape
      .LeftHeader = ""
      .CenterHeader = ""
      .RightHeader = ""
      .LeftFooter = ""
      .CenterFooter = ""
      .RightFooter = ""
      .LeftMargin = Application.InchesToPoints(0.15)
      .RightMargin = Application.InchesToPoints(0.15)
      .TopMargin = Application.InchesToPoints(0.15)
      .BottomMargin = Application.InchesToPoints(0.15)
      .PrintHeadings = False
      .PrintGridlines = False
      .PrintComments = xlPrintNoComments
      .PrintQuality = 600
      .CenterHorizontally = True
      .CenterVertically = True
      .Zoom = 150
    End With
  Next

  Sheets(sheetArray).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfpath & pdfname & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
 
  ActiveWindow.SelectedSheets.Delete
  Application.DisplayAlerts = True
End Sub

But this code only sets one sheet once, then that sheet is copied for each image, in my tests this version is faster, but try both and see which one works best for you:

VBA Code: 
Sub SavePNGtoPDF()
  Dim myPic As Object
  Dim sheetArray() As Variant, xSelItem As Variant
  Dim pdfname As String, pdfpath As String
  Dim xFileDlg As FileDialog
  Dim i As Long
  Dim sh As Worksheet
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  pdfname = Sheets("Sheet1").Range("Q2").Value
  pdfpath = Sheets("Sheet1").Range("O17").Value
 
  Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
  xFileDlg.InitialFileName = pdfpath
  xFileDlg.AllowMultiSelect = True
  If xFileDlg.Show = 0 Then Exit Sub
 
  Sheets.Add after:=Sheets(Sheets.Count)
  Set sh = ActiveSheet
  With sh.PageSetup
    .PaperSize = xlPaperLegal
    .Orientation = xlLandscape
    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0.15)
    .RightMargin = Application.InchesToPoints(0.15)
    .TopMargin = Application.InchesToPoints(0.15)
    .BottomMargin = Application.InchesToPoints(0.15)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = True
    .CenterVertically = True
    .Zoom = 150
  End With
 
  For Each xSelItem In xFileDlg.SelectedItems
    sh.Copy after:=Sheets(Sheets.Count)
    ReDim Preserve sheetArray(i)
    sheetArray(i) = ActiveSheet.Name
    i = i + 1
    Set myPic = ActiveSheet.Pictures.Insert(xSelItem)
  Next

  Sheets(sheetArray).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfpath & pdfname & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
 
  ActiveWindow.SelectedSheets.Delete
  sh.Delete
  Application.DisplayAlerts = True
End Sub
Click to expand...
Hi Dante!

Thank you SO much for the kind welcome! :)
And for the very speedy response!
I am so excited!

I tried both of them out!
You are absolutely right, the second code was about 30 seconds faster than my original one.

I am so grateful and appreciative of your help!

I hope you have an amazing day!
 
Upvote 1
You must log in or register to reply here.

Similar threads

willow1985
  • Solved
PrintArea = "TableName" but visible cells only
Replies
2
Views
384
willow1985
willow1985
J
  • Question
Excel VBA error 400 while link to another sheet
Replies
3
Views
393
rollis13
rollis13
C
  • Solved
VBA Print to PDF
Replies
7
Views
2K
camerong
C
C
  • Solved
Print to PDF into created folder in Workbook location
Replies
3
Views
574
camerong
C
M
  • Question
Formatting and Charts lost/scrambled when exporting to PDF via macro
Replies
0
Views
565
Moosles
M

Forum statistics

Threads
1,214,897
Messages
6,122,148
Members
449,066
Latest member
Andyg666

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top