Excel VBA将特定文件夹中的所有Word文件转换为PDF [关闭]

Question

我在下面的链接中找到了一个 Excel vba，它将特定目录中的 excel 文件转换为 pdf。 我希望您帮助对此代码进行必要的更改，以使其将特定目录中的 Word 文档转换为 pdf。

归功于： https://www.listendata.com/2013/02/excel-macro-convert-multiple-excel.html

代码如下：

Sub ExcelToPDF2()
Dim Path As String, FilesInPath As String _
, OutputPath As String, OutputPath2 As String
Dim MyFiles() As String, Fnum As Long
Dim Buk As Workbook, BukName As String
Dim CalcMode As Long
Dim sh As Worksheet
Dim StartTime As Date, EndTime As Date
Dim LPosition As Integer

'Specify the path of a folder where all the excel files are stored

StartTime = Timer
Path = Range("G6").Text & "\"
OutputPath = Range("G8").Text & "\"


FilesInPath = Dir(Path & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set Buk = Nothing
On Error Resume Next
Set Buk = Workbooks.Open(Path & MyFiles(Fnum))
On Error GoTo 0

If Not Buk Is Nothing Then


LPosition = InStr(1, Buk.Name, ".") - 1
BukName = Left(Buk.Name, LPosition)
Buk.Activate

OutputPath2 = OutputPath & BukName & ".pdf"

On Error Resume Next
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=OutputPath2, 
_
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False

    On Error GoTo 0

End If

Buk.Close SaveChanges:=False

Next Fnum
End If


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

EndTime = Timer
MsgBox "Task succesfully completed in " & Format(EndTime - StartTime, 
"0.00") & " seconds"

End Sub

Answer 1

老实说，我能想到的最简单的方法就是录制一个宏。如果你去 Word->Developer->Record a Macro，你可以记录你想做的功能。从那里，您将获得代码，并且您可以从那里更改某些区域。这是我通过一些调整得到的代码，可以满足您的需求：

   Sub Macro1()
'
' Macro1 Macro
'
'
    Dim i As Integer, FileLocation As String, WDoc() As Word.Document

    Dim FilesInPath As String, Path As String, MyFiles() As String, iend As Integer
    Path = "C:\...\" ' This is where you would like to get the files that need to be exported to .pdfs
    NewPath = "C:\...\" ' This is where you would like to send the exported files
    FilesInPath = Dir(Path & "*.doc*")
    iend = 0
    Do While FilesInPath <> ""
        iend = iend + 1
        ReDim Preserve MyFiles(1 To iend)
        MyFiles(iend) = FilesInPath
        FilesInPath = Dir()
    Loop

    For i = 1 To iend
        ReDim Preserve WDoc(i)
        Set WDoc(i) = Word.Documents.Open(Path & MyFiles(i))
        FileLocation = NewPath & WDoc(i).Name & ".pdf" ' Location and name of new file
        WDoc(i).ExportAsFixedFormat OutputFileName:=FileLocation, ExportFormat:=wdExportFormatPDF, _
            OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
            wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
            IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
            wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
            True, UseISO19005_1:=False
        WDoc(i).Close
    Next i
End Sub

Answer 2

我终于找到了我正在寻找的正确 VBA：

'In your VBA window go to tools then references and add a reference to 
'Microsoft Word

Sub Converter()
  Dim cnt As Integer, currfile As String
  Dim TrimFile As String, Path As String, FilesInPath As String _
, MyFiles() As String, Fnum As Long
  Dim CalcMode As Long, LPosition As Long
  Dim StartTime As Date, EndTime As Date

  Dim objWord As Word.Application
  Dim objDoc As Word.Document


  ThisWorkbook.Activate
  currfile = ActiveWorkbook.Name

  Windows(currfile).Activate
  Sheets("Sheet1").Activate

  StartTime = Timer
  Path = Range("C3").Text & "\"

  FilesInPath = Dir(Path & "*.doc*")
  If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
  End If

  Fnum = 0
  Do While FilesInPath <> ""
    Fnum = Fnum + 1
    ReDim Preserve MyFiles(1 To Fnum)
    MyFiles(Fnum) = FilesInPath
    FilesInPath = Dir()
  Loop

  With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
  End With

  If Fnum > 0 Then
    For Fnum = LBound(MyFiles) To UBound(MyFiles)
      Set objWord = CreateObject("Word.Application")
      'objWord.Visible = True

      On Error Resume Next

      Set objDoc = Word.Documents.Open(Path & MyFiles(Fnum))

      On Error GoTo 0

      If Not objDoc Is Nothing Then

        LPosition = InStr(1, objDoc.Name, ".") - 1
        TrimFile = Left(objDoc.Name, LPosition)

        On Error Resume Next

        objDoc.ExportAsFixedFormat OutputFileName:=objDoc.Path & "\" & TrimFile & ".pdf", 
        ExportFormat:=wdExportFormatPDF, _
        OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False



      End If

      objDoc.Close

   Next Fnum
  End If


  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
  End With

  objWord.Quit

  Set objDoc = Nothing
  Set objWord = Nothing

  EndTime = Timer
  MsgBox " Task succesfully completed in " & Format(EndTime - StartTime, "0.00") & " 
seconds"
End Sub