用于将 Excel 和 PowerPoint 转换为 PDF 的类似 VBScript

Question

我正在寻找一种将 Excel 和 PowerPoint 文档转换为 PDF 的完全无损方法。我正在将此脚本用于 Word，它可以完美运行 https://gallery.technet.microsoft.com/office/Script-to-convert-Word-08c5154b。我正在为 Excel 和 PowerPoint 寻找类似的脚本，但在互联网上找不到。我根本没有太多的 VB 经验，所以我很困惑它在哪里指定使用哪个办公应用程序。有没有人可以为 Excel 和 PowerPoint 或精通 VB 的人提供一个能够更改脚本以与其他包一起使用的人？我认为它只是改变了意图，因为集成的程序另存为 PDF 选项是相同的？

Word 的脚本如下：

Option Explicit 
'################################################
'This script is to convert Word documents to PDF files
'################################################
Sub main()
Dim ArgCount
ArgCount = WScript.Arguments.Count
Select Case ArgCount 
    Case 1  
        MsgBox "Please ensure Word documents are saved,if that press 'OK' to continue",,"Warning"
        Dim DocPaths,objshell
        DocPaths = WScript.Arguments(0)
        StopWordApp
        Set objshell = CreateObject("scripting.filesystemobject")
        If objshell.FolderExists(DocPaths) Then  'Check if the object is a folder
            Dim flag,FileNumber
            flag = 0 
            FileNumber = 0  
            Dim Folder,DocFiles,DocFile     
            Set Folder = objshell.GetFolder(DocPaths)
            Set DocFiles = Folder.Files
            For Each DocFile In DocFiles  'loop the files in the folder
                FileNumber=FileNumber+1 
                DocPath = DocFile.Path
                If GetWordFile(DocPath) Then  'if the file is Word document, then convert it 
                    ConvertWordToPDF DocPath
                    flag=flag+1
                End If  
            Next 
            WScript.Echo "Totally " & FileNumber & " files in the folder and convert " & flag & " Word Documents to PDF fles."

        Else 
            If GetWordFile(DocPaths) Then  'if the object is a file,then check if the file is a Word document.if that, convert it 
                Dim DocPath
                DocPath = DocPaths
                ConvertWordToPDF DocPath
            Else 
                WScript.Echo "Please drag a word document or a folder with word documents."
            End If  
        End If 

    Case  Else 
        WScript.Echo "Please drag a word document or a folder with word documents."
End Select 
End Sub 

Function ConvertWordToPDF(DocPath)  'This function is to convert a word document to pdf file
    Dim objshell,ParentFolder,BaseName,wordapp,doc,PDFPath
    Set objshell= CreateObject("scripting.filesystemobject")
    ParentFolder = objshell.GetParentFolderName(DocPath) 'Get the current folder path
    BaseName = objshell.GetBaseName(DocPath) 'Get the document name
    PDFPath = parentFolder & "\" & BaseName & ".pdf" 
    Set wordapp = CreateObject("Word.application")
    Set doc = wordapp.documents.open(DocPath)
    doc.saveas PDFPath,17
    doc.close
    wordapp.quit
    Set objshell = Nothing 
End Function 

Function GetWordFile(DocPath) 'This function is to check if the file is a Word document
    Dim objshell
    Set objshell= CreateObject("scripting.filesystemobject")
    Dim Arrs ,Arr
    Arrs = Array("doc","docx")
    Dim blnIsDocFile,FileExtension
    blnIsDocFile= False 
    FileExtension = objshell.GetExtensionName(DocPath)  'Get the file extension
    For Each Arr In Arrs
        If InStr(UCase(FileExtension),UCase(Arr)) <> 0 Then 
            blnIsDocFile= True
            Exit For 
        End If 
    Next 
    GetWordFile = blnIsDocFile
    Set objshell = Nothing 
End Function 

Function StopWordApp 'This function is to stop the Word application
    Dim strComputer,objWMIService,colProcessList,objProcess 
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    'Get the WinWord.exe
    Set colProcessList = objWMIService.ExecQuery _
        ("SELECT * FROM Win32_Process WHERE Name = 'Winword.exe'")
    For Each objProcess in colProcessList
        'Stop it
        objProcess.Terminate()
    Next
End Function 

Call main 

Answer 1

这会将所有 Excel 文件转换为 PDF 文件。

Sub Convert_Excel_To_PDF()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean
    Dim LPosition As Integer

    'Fill in the path\folder where the Excel files are
    MyPath = "c:\Documents and Settings\shuerya\Desktop\ExcelFiles\"

    FilesInPath = Dir(MyPath & "*.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 mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then


                    LPosition = InStr(1, mybook.Name, ".") - 1
                    mybookname = Left(mybook.Name, LPosition)
                    mybook.Activate
                    'All PDF Files get saved in the directory below:
                    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                        "C:\Documents and Settings\shuerya\Desktop\PDFFiles\" & mybookname & ".pdf", _
                        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
                        :=False, OpenAfterPublish:=False

            End If

            mybook.Close SaveChanges:=False

        Next Fnum
    End If

    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If

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

你能用它吗？？