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

Posted 2023-02-24

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

【英文标题】：Excel VBA to convert all Word files in a specific folder to PDF [closed]

【发布时间】：2019-04-14 03:28:25

【问题描述】：

我在下面的链接中找到了一个 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

【问题讨论】：

欢迎来到 ***。我建议阅读How to ask 页面。更具体地说，如果您只是要求代码而不显示您尝试过的内容以及遇到的具体问题，那么您不太可能获得太多帮助。

嗨@Matt，感谢您的通知，但我认为这个问题足够具体。恳请您重新评估问题并提供支持（如有）。

【参考方案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

【讨论】：

嗨@Parker.R，感谢您的帮助。我已经尽了最大努力，但由于我在编码方面有一点经验，所以我无法将上面的代码适应我所需的输出。请您编辑一下它可以将所有word文件转换为pdf吗？我非常感谢您的努力。

嘿@Ready2go，我编辑了上面的代码。您需要更改要导入文件的位置以及要导出文件的位置。如果有效，请为我单击侧面的复选标记。当我从 Microsoft Word VBA 中执行此操作时，它对我有用。

嘿@Parker.R，它在 Word 上运行良好，有什么方法可以让它在 Excel 上运行。实际上，我有一个 Excel 项目，它是该项目的一部分。

【参考方案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