使用 Excel VBA 将多个图像转换为一个 PDF 文件并将每个图像适合一页

Question

我有很多文件夹，每个文件夹里面可以有很多.jpg文件，以及其他类型的文件。

我需要的是通过使用 Excel vba，我想将所有 .jpg 文件一个一个地合并到一个 PDF 文件中，该文件在 Excel 中具有某些单元格文本，并为每个图像提供页码并将其存储在某个Excel 中的列。

我找到了这段代码，但它有两个问题

1. 图片在 pdf 文件中占据超过一页
2. 它只用随机的pdf文件转换一张图片

这里是代码

Sub JPG_PDF()
Application.ScreenUpdating = False
'Declare variables
Dim file As String
Dim path As String
path = "E:\pics\02-09-2015"
file = Dir(path & "\PC_20150902_145901.jpg")
Sheet1.Activate
'Start loop
Do While file <> ""
'Insert picture into Excel
Sheet1.Pictures.Insert (path & "\" & file)
ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Name = "A Picture"
ChDir "E:\pics\02-09-2015"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=file, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
ActiveSheet.Shapes.Range(Array("A Picture")).Delete
file = Dir()
Loop
Sheet2.Activate
Application.ScreenUpdating = True
End Sub

Answer 1

这是结合我提供给我的两个代码后的代码 https://stackoverflow.com/users/13302/marc-s https://stackoverflow.com/users/2497009/usncahill 是否有任何方法或方法来缩短此代码并使用户通过打开文件对话框窗口选择文件夹 另一件事我想要打开 pdf 文件的超链接并转到 PDF 文件中的选定图像 最后一个要求是，对于每个图像，我想生成一个包含 3 列的表格，第一列包含图像的名称，第二列包含标题为结果 PDF 文件中图像位置的超链接，第三列包含针对所有组合图像重复的 PDF 文件标题此 PDF 文件

  Dim objFS As FileSystemObject, objFolder As Folder, objFile As file
  Dim objPDFout As AcroPDDoc, objPDFpage As AcroPDDoc
  Dim strFileType As String, strPathtoFolders As String, strPDFFilename As String
  Dim i As Long
  Dim numMaxHeight As Single, numMaxWidth As Single

  'Optional
  Sheet1.UsedRange = "" 'Clears the picture list

  'Set up page parameters
  numMaxWidth = 8.5 - 0.5 - 0.5 - 0.5 '0.5" buffer
  numMaxHeight = 11 - 0.5 - 0.5 - 0.5 '0.5" buffer

  With Sheet2.PageSetup
    .CenterHorizontally = True
    .CenterVertically = True
    .RightMargin = 0.5
    .LeftMargin = 0.5
    .TopMargin = 0.5
    .BottomMargin = 0.5
    .Orientation = xlPortrait 'xlLandscape '
  End With

  'Initialize PDFs and file system
  Set objPDFout = New Acrobat.AcroPDDoc
  Set objPDFpage = New Acrobat.AcroPDDoc
  Set objFS = New FileSystemObject
  
  strFileType = "JPG File"
  strPathtoFolders = "C:\Users\Attorney\Desktop\"
  strPDFFilename = "output.pdf"
  i = 1
  
  objPDFout.Create
  
  Set objFolder = objFS.GetFolder(strPathtoFolders)

  'Go through every subfolder of the target folder and PDFify then combine PDFs
  'For Each objFolder In objFS.GetFolder(strPathtoFolders).SubFolders
      For Each objFile In objFolder.Files
          If objFile.Type = strFileType Then
              'Record filename, save link to file, and record page number
              Sheet1.Cells(i, 1) = objFile.Name
              Sheet1.Hyperlinks.Add Sheet1.Cells(i, 1), objFile.path
              Sheet1.Cells(i, 2) = i
              i = i + 1 'increment page counter
              
              'Insert and resize picture
              With Sheet2.Pictures.Insert(objFile.path)
                  With .ShapeRange
                      .LockAspectRatio = True
                      
                      'Set width while locked ratio
                      .Width = numMaxWidth * 72 '72 points per inch
                      
                      'If height went over the page height, then set height instead
                      If .Height > numMaxHeight * 72 Then .Height = numMaxHeight * 72
                  End With
                  
                  'Place the picture in the top-left most cell
                  .Left = Sheet2.Cells(1, 1).Left
                  .Top = Sheet2.Cells(1, 1).Top
                  .Placement = 1
              End With
              
              'Export sheet to PDF
              Sheet2.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPathtoFolders & i, _
                  Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                  IgnorePrintAreas:=True, OpenAfterPublish:=False
             
              'Get rid of picture from sheet
              Sheet2.Pictures(1).Delete
            
              'Open PDF with picture, append to output PDF, then close and delete PDF with picture
              objPDFpage.Open strPathtoFolders & i & ".pdf"
              objPDFout.InsertPages objPDFout.GetNumPages - 1, objPDFpage, 0, objPDFpage.GetNumPages, True
              objPDFpage.Close
              objFS.DeleteFile strPathtoFolders & i & ".pdf"
          End If
      Next
  'Next
  
  On Error GoTo Skip
    For Each objFolder In objFS.GetFolder(strPathtoFolders).SubFolders
        For Each objFile In objFolder.Files
            If objFile.Type = strFileType Then
              Sheet1.Cells(i, 1) = objFile.Name
              Sheet1.Hyperlinks.Add Sheet1.Cells(i, 1), objFile.path
              Sheet1.Cells(i, 2) = i
              i = i + 1 'increment page counter
              
              'Insert and resize picture
              With Sheet2.Pictures.Insert(objFile.path)
                  With .ShapeRange
                      .LockAspectRatio = True
                      
                      'Set width while locked ratio
                      .Width = numMaxWidth * 72 '72 points per inch
                      
                      'If height went over the page height, then set height instead
                      If .Height > numMaxHeight * 72 Then .Height = numMaxHeight * 72
                  End With
                  
                  'Place the picture in the top-left most cell
                  .Left = Sheet2.Cells(1, 1).Left
                  .Top = Sheet2.Cells(1, 1).Top
                  .Placement = 1
              End With
              
              'Export sheet to PDF
              Sheet2.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPathtoFolders & i, _
                  Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                  IgnorePrintAreas:=True, OpenAfterPublish:=False
             
              'Get rid of picture from sheet
              Sheet2.Pictures(1).Delete
            
              'Open PDF with picture, append to output PDF, then close and delete PDF with picture
              objPDFpage.Open strPathtoFolders & i & ".pdf"
              objPDFout.InsertPages objPDFout.GetNumPages - 1, objPDFpage, 0, objPDFpage.GetNumPages, True
              objPDFpage.Close
              objFS.DeleteFile strPathtoFolders & i & ".pdf"
          End If
        Next
    Next
Skip:
  'Save final PDF
  objPDFout.Save 1, strPathtoFolders & strPDFFilename
End Sub```

Answer 2

以下要求您将 Acrobat 和 Windows 脚本宿主对象模型添加到您的引用中。

Public Sub PDFsomePics()
  Dim objFS As FileSystemObject, objFolder As Folder, objFile As File
  Dim objPDFout As AcroPDDoc, objPDFpage As AcroPDDoc
  Dim strFileType As String, strPathtoFolders As String, strPDFFilename As String
  Dim i As Long
  Dim numMaxHeight As Single, numMaxWidth As Single

  'Optional
  Sheet1.UsedRange = "" 'Clears the picture list

  'Set up page parameters
  numMaxWidth = 8.5 - 0.5 - 0.5 - 0.5 '0.5" buffer
  numMaxHeight = 11 - 0.5 - 0.5 - 0.5 '0.5" buffer

  With Sheet2.PageSetup
    .CenterHorizontally = True
    .CenterVertically = True
    .RightMargin = 0.5
    .LeftMargin = 0.5
    .TopMargin = 0.5
    .BottomMargin = 0.5
    .Orientation = xlPortrait 'xlLandscape '
  End With

  'Initialize PDFs and file system
  Set objPDFout = New Acrobat.AcroPDDoc
  Set objPDFpage = New Acrobat.AcroPDDoc
  Set objFS = New FileSystemObject
  
  strFileType = "JPG File"
  strPathtoFolders = "drive:\path\to\folders\"
  strPDFFilename = "output.pdf"
  i = 1
  
  objPDFout.Create
  
  Set objFolder = objFS.GetFolder(strPathtoFolders)

  'Go through every subfolder of the target folder and PDFify then combine PDFs
  'For Each objFolder In objFS.GetFolder(strPathtoFolders).SubFolders
      For Each objFile In objFolder.Files
          If objFile.Type = strFileType Then
              'Record filename, save link to file, and record page number
              Sheet1.Cells(i, 1) = objFile.Name
              Sheet1.Hyperlinks.Add Sheet1.Cells(i, 1), objFile.Path
              Sheet1.Cells(i, 2) = i
              i = i + 1 'increment page counter
              
              'Insert and resize picture
              With Sheet2.Pictures.Insert(objFile.Path)
                  With .ShapeRange
                      .LockAspectRatio = True
                      
                      'Set width while locked ratio
                      .Width = numMaxWidth * 72 '72 points per inch
                      
                      'If height went over the page height, then set height instead
                      If .Height > numMaxHeight * 72 Then .Height = numMaxHeight * 72
                  End With
                  
                  'Place the picture in the top-left most cell
                  .Left = Sheet2.Cells(1, 1).Left
                  .Top = Sheet2.Cells(1, 1).Top
                  .Placement = 1
              End With
              
              'Export sheet to PDF
              Sheet2.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPathtoFolders & i, _
                  Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                  IgnorePrintAreas:=True, OpenAfterPublish:=False
             
              'Get rid of picture from sheet
              Sheet2.Pictures(1).Delete
            
              'Open PDF with picture, append to output PDF, then close and delete PDF with picture
              objPDFpage.Open strPathtoFolders & i & ".pdf"
              objPDFout.InsertPages objPDFout.GetNumPages - 1, objPDFpage, 0, objPDFpage.GetNumPages, True
              objPDFpage.Close
              objFS.DeleteFile strPathtoFolders & i & ".pdf"
          End If
      Next
  'Next

  'Save final PDF
  objPDFout.Save 1, strPathtoFolders & strPDFFilename
End Sub