I have searched many sites but there is no such example for converting
an "xls" file to "pdf" file by using "FreePDF XP". So I re-write the
code from "FreePDF XP ResourceKit" and share it here for anyone needs.
Please install "FreePDF XP" before running this script. "FreePDF XP"
can be downloaded at
http://freepdfxp.de/fpxp.htm
----------------------------------8<---------------------------------
'**********************************************************************
'*
'* Author: Curtis Wong
'* File: xls2pdf.vbs
'* Created on: 15 August 2004
'*
'* Aim: To convert "xls" to "pdf" format by using FreePDF
'*
'**********************************************************************
Option Explicit
' Check if this script is run by "cscript.exe"
If Not IsHostCscript Then
Const kMessage1 = "Please run this script using CScript."
Const kMessage2 = "This can be achieved by changing the default"
Const kMessage3 = "Windows Scripting Host to CScript using:"
Const kMessage4 = """CScript //H:CScript //S""."
WScript.Echo kMessage1 & vbCRLF & vbCRLF & kMessage2 & vbCRLF & _
kMessage3 & vbCRLF & vbCRLF & kMessage4
WScript.Quit
End If
' To make this script can be run once at each time
Dim OneInstance, strWQL
strWQL = "SELECT name from win32_process where" & _
" name='wscript.exe' or name='cscript.exe'"
OneInstance = GetObject("winmgmts:").Execquery(strWQL).Count
If Trim(CStr(OneInstance)) <> "1" Then WScript.Quit
' Main part
Dim objFSO
Dim RptDir, CurDir, RptName, objRpt
' Define the Current Directory
Set objFSO = CreateObject("Scripting.FileSystemObject")
CurDir = objFSO.GetParentFolderName(Wscript.ScriptFullName)
If Right(CurDir, 1) = "\" Then _
CurDir = Left(CurDir, Len(CurDir) - 1)
' Define the variables for output reports
RptDir = CurDir
' Add into the following array for the reports needed to convert
' to "pdf" format. Note that filename only, ".xls" is NOT required
RptName = Array("book1")
For Each objRpt in RptName
XLS2PDF objRpt
Next
Msgbox "The conversions are finished.", vbOKOnly + vbInformation, _
"Congratulations"
Set objFSO = Nothing
'**********************************************************************
'*
'* Sub XLS2PDF(ByVal Workbookname)
'* Purpose: Convert Excel Worksheet to pdf
'* Input: Workbookname <Name of Excel Workbook>
'*
'**********************************************************************
Private Sub XLS2PDF(ByVal Workbookname)
Dim psFile, objExcel, OldPrinter
psFile = CurDir & "\" & Workbookname & ".ps"
Wscript.Echo "Converting """ & Workbookname & ".xls"" -> """ & _
Workbookname & ".pdf"""
' Create Excel Object
Set objExcel = CreateObject("Excel.Application")
With objExcel
' Open workbook
.Workbooks.Open RptDir & "\" & Workbookname & ".xls", 0, True
' Open the workbook implicitly
.Visible = False
' Check if it is a blank workbook
If .Worksheets(1).UsedRange.Address = "$A$1" And _
.Worksheets(1).Range("A1") = "" Then
.Workbooks(Workbookname & ".xls").Close False
.Quit
Set objExcel = Nothing
WScript.Echo Workbookname & ".xls is a blank workbook."
WScript.Quit
End If
' Print all worksheets in the opened workbook
' (Comment the following if you only want to print some
' worksheets)
.Workbooks(Workbookname & ".xls").PrintOut _
, , , , "FreePDF XP", True, , psFile
' Print the first worksheet counting from the left
' (Comment the following if you want to print all worksheets in
' the opened workbook)
'.Worksheets(1).PrintOut , , , , "FreePDF XP", True, , psFile
' Close the workbook
.Workbooks(Workbookname & ".xls").Close False
' Quit Excel
.Quit
End With
' Release Excel Object
Set objExcel = Nothing
Dim objFreePDF, FreePDF, objShell, PDFFile, Parameter
' Create Shell object
Set objShell = WScript.CreateObject("WScript.Shell")
PDFFile = RptDir & "\" & Workbookname & ".pdf"
' Define the "freepdf.exe" in Full Path format
FreePDF = objShell.ExpandEnvironmentStrings("%ProgramFiles%") & _
"\FreePDF_XP\freepdf.exe"
'Define the parameter needed for outputing "pdf" files
Parameter = " /3 delps,end ""High Quality"" " & """" & PDFFile & _
""" """ & psFile & """"
If objFSO.FileExists(FreePDF) Then
' Run "freepdf.exe" with parameter and get the WshScriptExec
' object
Set objFreePDF = objShell.Exec(FreePDF & Parameter)
Wscript.Stdout.Write "Please wait "
' Check whether "freepdf.exe" ends for every 0.5 second
Do While objFreePDF.Status = 0
WScript.Sleep 500
Wscript.Stdout.Write "."
Loop
WScript.Echo vbCrLf & "Convertion finished." & vbCrLf
Else
' Prompt to user to install "FreePDF XP" before running this
' script
MsgBox _
"Please install ""FreePDF XP"" before running this script.", _
vbExclamation, "Error"
End If
' Release objects
Set objShell = Nothing: Set objFreePDF = Nothing
End Sub
'**********************************************************************
'*
'* Function: IsHostCscript()
'* Purpose: Check if "cscript.exe" is to run this script
'* Output: Returns true if the script host is "cscript.exe"
'*
'**********************************************************************
Private Function IsHostCscript()
On Error Resume Next
Dim strFullName, strCommand, i, j
Dim bReturn: bReturn = False
strFullName = WScript.FullName
i = InStr(1, strFullName, ".exe", 1)
If i <> 0 Then
j = InStrRev(strFullName, "\", i, 1)
If j <> 0 Then
strCommand = Mid(strFullName, j + 1, i - j - 1)
If LCase(strCommand) = "cscript" Then bReturn = True
End If
End If
If Err <> 0 Then _
WScript.Echo "Error 0x" & Hex(Err.Number) & " occurred. " &
Err.Description _
& ". " & vbCrLf & "The scripting host could not be determined."
IsHostCscript = bReturn
End Function
----------------------------------8<---------------------------------