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

以下要求您将 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,objPDFpage.GetNumPages,True
              objPDFpage.Close
              objFs.deleteFile strPathtoFolders & i & ".pdf"
          End If
      Next
  'Next

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

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

  Dim objFS As FileSystemObject,objFile As file
  Dim objPDFout As AcroPDDoc,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,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,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,True
              objPDFpage.Close
              objFs.deleteFile strPathtoFolders & i & ".pdf"
          End If
        Next
    Next
Skip:
  'Save final PDF
  objPDFout.Save 1,strPathtoFolders & strPDFFilename
End Sub```