Similar VBScript for converting Excel and PowerPoint to PDF

问题

I am looking for a completely lossless way of converting Excel and PowerPoint documents to PDF. I am using this script for Word and it works flawlessly https://gallery.technet.microsoft.com/office/Script-to-convert-Word-08c5154b. I am looking for a similar script for Excel and PowerPoint and cant find one on the internet. I dont have much experience with VB at all so I am confused where it specifies which office application to use. Is there anyone that can provide one for Excel and PowerPoint or someone proficient in VB that would be able to change the script to work with the other packages? I assume its just changing the intent as the programs integrated save as PDF option is the same?

The script for Word is below as well:

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 

回答1:

This will convert all Excel files into PDF files.

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

Can you work with that??

来源：https://stackoverflow.com/questions/38244131/similar-vbscript-for-converting-excel-and-powerpoint-to-pdf