类似的VBScript,用于将Excel和PowerPoint转换为PDF [英] Similar VBScript for converting Excel and PowerPoint to PDF
问题描述
我正在寻找一种将Excel和PowerPoint文档转换为PDF的完全无损的方法.我正在将此脚本用于Word,它可以完美运行 https://gallery.technet.microsoft.com/office/Script-to-convert-Word-08c5154b .我正在寻找适用于Excel和PowerPoint的类似脚本,但无法在Internet上找到一个脚本.我完全没有VB的经验,所以我很困惑在哪里指定要使用哪个Office应用程序.有没有人可以为Excel和PowerPoint提供一个或精通VB的人可以更改脚本以与其他软件包一起使用?我认为它只是改变了意图,因为集成了另存为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?
Word的脚本也在下面:
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
推荐答案
这会将所有Excel文件转换为PDF文件.
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
您可以使用它吗?
这篇关于类似的VBScript,用于将Excel和PowerPoint转换为PDF的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!