批量转换excel文件为pdf的VBA脚本

Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                 OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant
 
    'Test to see if the Microsoft Create/Send add-in is installed.
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
 
        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the PDF file.
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                  Title:="Create PDF")
 
            'If you cancel this dialog, exit the function.
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If
 
        'If OverwriteIfFileExist = False then test to see if the PDF
        'already exists in the folder and exit the function if it does.
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If
 
        'Now export the PDF file.
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False
        On Error GoTo 0
 
        'If the export is successful, return the file name.
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function
 
 
Function DigIn(sPath As String)
 
    Dim FS, f, f1, fc, s
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set f = FS.GetFolder(sPath)
    Set fc = f.Files
    For Each f1 In fc
        
        ExtName = GetExtName(f1.Path)
        If ExtName = "xlsx" Then
            RDB_Workbook_To_PDF (f1.Path)
        End If
        
    Next
    
    For Each subfolder In f.SubFolders
        s = s & subfolder.Path
        DigIn (subfolder.Path)
    Next
    
End Function
 
Function GetExtName(ScanString As String) As String
       
'*******************************************************
'<DESC>     Retrieves File Extension Name from full
'       directory path</DESC>
'<RETURN>   File Extension Only
'           </RETURN>
'<ACCESS>   Public
'<ARGS>     FullPath:
'           Full Filepath incl. Filename
'               </ARGS>
'<USAGE>    If GetExtName("c:\autoexec.bat")
'               </USAGE>
'*******************************************************
    
    Dim intPos As String
    Dim intPosSave As String
    
    If InStr(ScanString, ".") = 0 Then
        GetExtName = ""
        Exit Function
    End If
    
    intPos = 1
    Do
        intPos = InStr(intPos, ScanString, ".")
        If intPos = 0 Then
            Exit Do
        Else
            intPos = intPos + 1
            intPosSave = intPos - 1
        End If
    Loop
 
    GetExtName = Trim$(Mid$(ScanString, intPosSave + 1))
 
End Function
 
 
 
Sub RDB_Convert_Files_To_PDF()
    Dim sStartPath As String
    Dim sWhat As String
    
    sStartPath = "D:/workspace/clothes-report/data/fankui/output" 'Where?
    sWhat = "test.log" 'What?
    result = DigIn(sStartPath) 'First step
 
End Sub
 
 
 
Sub RDB_Workbook_To_PDF(fPath As String)
    Dim FileName As String
 
    'Call the function with the correct arguments.
    Workbooks.Open fPath
    FileName = RDB_Create_PDF(ActiveWorkbook, Replace(fPath, ".xlsx", "") & ".pdf", True, True)
    ActiveWorkbook.Close SaveChanges:=False
 
    'For a fixed file name and to overwrite the file each time you run the macro, use the following statement.
    'RDB_Create_PDF(ActiveWorkbook, "C:\Users\Ron\Test\YourPdfFile.pdf", True, True)
 
    If FileName <> "" Then
    'Uncomment the following statement if you want to send the PDF by mail.
        'RDB_Mail_PDF_Outlook FileName, "[e-mail]", "This is the subject", _
           "See the attached PDF file with the last figures" _
          & vbNewLine & vbNewLine & "Regards Ron de bruin", False
    Else
        MsgBox "It is not possible to create the PDF; possible reasons:" & vbNewLine & _
               "Microsoft Add-in is not installed" & vbNewLine & _
               "You canceled the GetSaveAsFilename dialog" & vbNewLine & _
               "The path to save the file in arg 2 is not correct" & vbNewLine & _
               "You didn't want to overwrite the existing PDF if it exists."
    End If
End Sub