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

我终于找到了我想要的正确的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

Answer 2

老实说，我想到的最简单的方法是只记录一个宏。如果转到“ Word”->“开发人员”->“记录宏”，则可以记录要执行的功能。从那里，您将拥有代码，并且可以从那里更改某些区域。这是我经过一些调整即可完成我认为您正在寻找的代码：

   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

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

2 个答案: