If you want to automate the process of converting MS InfoPath and/or MS Word to PDF, here’s a handy script my partner and I developed. I’ll explain later…jump to the script.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | Dim pCurrentDir, pFilename, ObjFSO, objIP, objWord, objDir, objDoc, x, objFile, objSubDir, strTargetFile
Const wdFormatPDF = 17
' Change the path below to the folder that you want to convert to PDF
'##############################################################
strInDir = InputBox("Please enter the InfoPath document folder.")
strOutDir = InputBox("Please enter the DESTINATION folder for the PDF files.")
'##############################################################
'initialize objects: Filesystem, Infopath, Word
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objIP = CreateObject("InfoPath.Application")
Set objWord = CreateObject("Word.Application")
Set objDir = objFSO.GetFolder(strInDir)
' this does all the work
getXMLFiles(objDir)
objIP.Quit(true)
objWord.Quit
'##############################################################
Function getXMLFiles(pCurrentDir)
For Each objFile In pCurrentDir.Files
pFilename = objFile.Name
strTargetFile = replace(pCurrentDir, strInDir, strOutDir) & "\" & objFSO.GetBaseName(pFilename) & ".PDF"
strSourceFile = pCurrentDir & "\" & pFilename
If Not objFSO.FolderExists(replace(pCurrentDir, strInDir, strOutDir)) Then
x = objFSO.CreateFolder(replace(pCurrentDir, strInDir, strOutDir))
End If
If LCase(Right(Cstr(objFile.Name), 3)) = "xml" Then
'x = MakePDF(pCurrentDir, pFilename, "I") ' InfoPath
objIP.XDocuments.Open(strSourceFile)
x = objIP.XDocuments.Item(0).View.Export(strTargetFile, "PDF")
objIP.XDocuments.Close(0)
Else
'x = MakePDF(pCurrentDir, pFilename, "W") ' Word
objWord.Documents.Open strSourceFile
Set objDoc = objWord.ActiveDocument
objDoc.SaveAs strTargetFile, wdFormatPDF
objDoc.Close
End If
' wscript.Echo strSourceFile, "->", strTargetFile
Next
For Each objSubDir In pCurrentDir.SubFolders
'wscript.Echo objSubDir.Name '& " passing recursively"
'wscript.Echo replace(objSubDir.ParentFolder, strInDir, strOutDir) & "\" & objSubDir.Name
getXMLFiles(objSubDir)
Next
End Function
'wscript.Echo pCurrentDir
'wscript.Echo pCurrentDir.ParentFolder
'wscript.Echo objFSO.GetBaseName(pCurrentDir.ParentFolder)
'wscript.Echo objSubDir.Name
'wscript.Echo strNewDir
'strOutDir & "\" & objFSO.GetBaseName(pCurrentDir)
'wscript.Echo strNewDir |