'' Convert WordPerfect files to RTF format or PDF, using Word '' Version 5.3.8 - 15 September 2013 '' By Edward Mendelson http://wpdos.org '' With many ideas taken from posts on VBScriptForum.org '' Requires Windows 2000 or later, Microsoft Word 2000 or later. '' Word 2003 or later required for converting multiple files '' Word 2007 SP2 or later required for PDF export Option Explicit ''''''''''''''''''''''''' USER-SELECTABLE OPTIONS '''''''''''''''''''''''''''''''''''''''''''' ''''' Export as PDF, not RTF, format '''''' '' This script can be set to create PDF files by default, instead of RTF files. '' This feature requires Word 2007 SP2 or later. '' To turn on this option, in the first line below, change PDFExport from "No" to "Yes". Dim PDFExport : PDFExport = "No" '' The PDFOpen variable determines whether or not a PDF file will open in your default '' PDF-reading program after being created. If you do NOT want the file to open after '' being created, then change PDFOpen from "Yes" to "No" Dim PDFOpen : PDFOpen = "Yes" ''''' Option to turn off "processing takes time" prompt ''''' '' If you want to turn off the prompt that says "File processing can take some time", '' change "on" to "off" (in quotation marks) in the line below. Default setting is "On". Dim TakesTimePrompt : TakesTimePrompt = "On" ''''' Option to turn off prompt when overwriting an existing file ''''' '' IMPORTANT: If you want to turn off the prompt when overwriting existing files '' change "On" to "Off" (in quotation marks) in the line below this block. '' This option applies only for files or file specifications entered as '' command-line parameters. It has no effect on filenames entered by filling in '' a box when prompted for a filename. Default setting is "On". Dim PromptForOverwrite : PromptForOverwrite = "On" ''''' Font-Replacement Options '''''' '' This script can optionally correct some problems caused when Word assigns the wrong '' font or fonts to a converted document. If your documents use one font, and you want '' Word to apply one font to the ENTIRE document, you must specify the "WholeFile" option '' below, and then (in another option below this one), you must also specify the font '' (and optionally the point size) that you want Word to use '' If you want Word to replace up to three specific fonts in the converted document, '' then you must specify "MultiFont" in the line below, and then specify the fonts that '' you want Word to replace, in the separate section for the "MultiFont" option, about '' twenty lines below this one. The "MultiFont" option ONLY works if you ALSO specify '' font names in the section below. '' If you want the script NOT to confirm that the replacement fonts that you specify are '' installed on the system, change TestFontNames from "Yes" to "No". '' Options: FontMethod: empty (between quotation marks), OR "WholeFile" OR "MultiFont" '' Default: "" '' Options: TestFontNames: "Yes" (test fontnames) Dim FontMethod : FontMethod = "" Dim TestFontNames : TestFontNames = "Yes" ''''' "WholeFile" option to reformat output file with one specific font ''''' '' This setting takes effect ONLY if you have chosen the "WholeFile" option above. '' If you want Word to format your entire document with a specific font, you may specify '' the font name and size in the two lines below. Type the name between quotation marks. '' The font size setting is OPTIONAL; if set at 0, Word will NOT change the font size. '' The font size setting will be applied ONLY if the font name is ALSO specified. '' The setting NewFontSize = 14 will produce 14-point type in the converted document. '' Default settings are empty (nothing inside the two marks "") and 0. '' Example: Dim AllDocFont : AllDocFont = "Courier New" '' Example: Dim NewFontSize : NewFontSize = 0 Dim AllDocFont : AllDocFont = "" Dim NewFontSize : NewFontSize = 0 ''''' "MultiFont" option to replace up to three specific fonts in the output file ''''' '' This setting takes effect ONLY if you have chosen the "MultiFont" option above '' If Word replaces the fonts in your WordPerfect document with incorrect fonts, you '' may force it to correct its errors with the following settings. Remember that you '' must ONLY specify fonts that are listed in Word's font dialog, NOT fonts that are '' listed in the WordPerfect font menus. '' In the first pair of variables below, enter next to BadFirstFont the name (inside '' quotation marks) of the font that Word mistakenly assigns. Then enter next to '' NewFirstFont the name of the font that you want Word to use. REMEMBER THAT the '' BadFirstFont MUST be the font that Word mistakenly assigns, which may or may not '' be the same font that you specified in your WordPerfect file. Use the Word fontname! '' If you wish to replace further fonts, enter their names in the second and third pairs '' of variables below. The second and third items are optional. If you wish to replace '' only TWO fonts, be sure to use the BadSecondFont/NewSecontFont variables and leave '' the Third set blank. Dim BadFirstFont : BadFirstFont = "" Dim NewFirstFont : NewFirstFont = "" Dim BadSecondFont : BadSecondFont = "" Dim NewSecondFont : NewSecondFont = "" Dim BadThirdFont : BadThirdFont = "" Dim NewThirdFont : NewThirdFont = "" ''''' Option to fine-tune Word's formatting of imported files ''''' '' When Word imports a WordPerfect file, it makes minor format adjustments so that the '' converted Word file looks more as if formatted by WordPerfect. This script can '' make slight adjustments in Word's settings. These adjustments are turned off '' in the script by default, but if turned on will slightly improve the appearance '' of some WPDOS6.x files, and can be manually adjusted by expert users. '' To turn on this option, change "Off" to "On" in line below (retain quotation marks). '' Default setting: "Off" Dim EnableFormatFix : EnableFormatFix = "Off" ''''''''''''''''''''''''' USAGE AND PARAMETERS '''''''''''''''''''''''''''''''''''''''''''''' '' Usage: wp2msw.vbs [] [default | ] [silent] [subdirs] '' Parameters are optional, but if Parameter 2 is used, Parameter 1 is also required; '' if Paramater 3 is used, Parameters 1 and 2 are also required; '' if Parameter 4 is used, Parameters 1, 2, and 3 are also required '' If Parameter 1 or 2 includes a path or filename with a space character, enclose the '' parameter in quotation marks '' Parameter 1: either blank or '' = full path of one file or a folder, or a wildcard specification '' Parameter 2: either blank or 'default' or '' EITHER: '' default = used to specify .rtf as the output file name for '' an individual file, or to specify output directory when converting multiple files '' OR: '' = when Parameter 1 is an individual file, Parameter 2 must be the '' full path of the converted output file; when Parameter 1 is a directory or '' wildcard specification, Parameter 2 must be the name of an existing directory '' for the converted output files '' Parameter 3: either blank or 'silent' or 'RTF' or 'PDF' or 'silentRTF' or 'silentPDF' '' silent = do not prompt except in case of error; when used with directories or wildcard '' specifications, requires either 'default' or as Parameter 2 '' RTF = conversion to RTF format with prompting '' silentRTF = force no-prompting conversion to RTF format '' PDF = conversion to PDF format with prompting '' silentPDF = force no-prompting conversion to PDF format '' Parameter 4: either blank or 'subdirs' '' subdirs = when processing a directory or wildcard specification, also process '' subdirectories; requires 'default' as Parameter 2 and 'silent' as Parameter 3; '' if 'subdirs' is not specified subdirectories will not be processed '' during silent processing of a directory or wildcards ''''''''''''''''''''''' END OF USER INFORMATION ''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' '''' Declarations Dim args, num, wpVer, wordVer, wordBuild, doDirs, numDirs, fName, fVer, arg2ext Dim response, msgTxt, styleBtn, sUserIn, colSubfolders, lngJunk, rngStory Dim oWord, oDoc, oFolder, oExplorer Dim sInFile, sOutFile, sOutSpec, sOutDir, sOutExt, sFilename, sSDir, sWildspec Dim sFileExt, sPDFOut, sDefaultExt, sApp, sVerb Dim titleTxt : titleTxt = "Convert WP Files" Dim wordOK : wordOK = 0 Dim pdfOK : pdfOK = 0 Dim bulkWP : bulkWP = 0 Dim fileCount : fileCount = 0 Dim checkCount : checkCount = 0 Dim notCount : notCount = 0 Dim default : default = 0 Dim silent : silent = 0 Dim subdirs : subdirs = 0 Dim overwrite : overwrite = 0 Dim inExists : inExists = 0 Dim useIE : useIE = 0 Dim replaceOK ': replaceOK = 0 Dim fixFormat ': fixFormat = 0 Dim ExtArray ExtArray=Array(".DOC",".RTF",".BK!",".PDF",".ZIP",".DOCX",".XLS",".XLXS", + _ ".PPT","PPTX",".DMG",".EXE") Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject") Dim WSHShell : Set WSHShell = WScript.CreateObject("WScript.Shell") Dim CurDir : CurDir = oFSO.GetParentFolderName(Wscript.ScriptFullName) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''' Main subroutines ProgramsExist SetUserOptions GetFilenames TestPdfOK DisableWPFonts WordVersionControl SetIE BranchRoutines EndConv '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''' Preliminaries Sub ProgramsExist ' Test whether Word and filters are installed On Error Resume Next Set oWord = CreateObject("Word.Application") If Err.Number <> 0 Then MsgBox "Error: Microsoft Word is not correctly installed on this system.", _ vbOKOnly, titleTxt WScript.Quit End If oWord.Visible = False ' Test for Word version; requires 11 (2003) for WordPerfect detection wordVer = oWord.version If WordVer >= 11 Then wordOK = 1 End If ' Test for Word version with PDF export filter installed Select Case LCase(PDFExport) Case "yes" PDFExport = 1 Case "no" PDFExport = 0 Case Else MsgBox "Error: The PDFExport variable must be either 'Yes' or 'No'." + vbCR + _ vbCR + "You entered: '" + pdfExport + "'.", vbOKOnly, titleTxt WScript.Quit End Select Select Case LCase(PDFOpen) Case "yes" PDFOpen = 1 Case "no" PDFOpen = 0 Case Else MsgBox "Error: The PDFOpen variable must be either 'Yes' or 'No'." + vbCR + _ vbCR + "You entered: '" + pdfOpen + "'.", vbOKOnly, titleTxt WScript.Quit End Select ' If PDFExport = 1 Then If WordVer <= 11 Then MsgBox "Error: PDF Export requires Word 2007 SP2 or later.", _ vbOKOnly, titleTxt oWord.Quit WScript.Quit End If ' Word 2007 SP2 installs PDF exporter If WordVer = 12 Then wordBuild = oWord.Build Dim buildNum : buildNum = Right((wordBuild),4) If buildNum >= 6504 Then pdfOK = 1 Else MsgBox "Error: PDF Export requires Word 2007 SP2 or later.", _ vbOKOnly, titleTxt oWord.Quit WScript.Quit End If End If ' Word 2010 and later have PDF export If WordVer >= 13 Then pdfOK = 1 End If End If oWord.Quit 0 On Error GoTo 0 ' Test if import filters are installed Dim WshProcEnv : Set WSHProcEnv = WSHShell.Environment("PROCESS") Dim sCmnPrgFiles : sCmnPrgFiles = WSHProcEnv("commonprogramfiles") Dim cnvFolder : cnvFolder = sCmnPrgFiles + "\Microsoft Shared\TextConv" Dim v5Cnv : v5Cnv = cnvFolder + "\wpft532.cnv" Dim v6Cnv : v6Cnv = cnvFolder + "\wpft632.cnv" If oFSO.FileExists(v5Cnv) Then If oFSO.FileExists(v6Cnv) Then Else MsgBox "Error: The required WP file converters are not installed on this system.", _ vbOKOnly, titleTxt WScript.Quit End If End If End Sub Sub SetUserOptions If LCase(TakesTimePrompt) = "on" Then ElseIf LCase(TakesTimePrompt) = "off" Then Else MsgBox "Error: The TakesTimePrompt variable must be either 'On' or 'Off'." + vbCR + vbCR + _ "You entered: '" + TakesTimePrompt + "'.", vbOKOnly, titleTxt WScript.Quit End If If LCase(PromptForOverwrite) = "off" Then replaceOK = 1 ElseIf LCase(PromptForOverwrite) = "on" Then replaceOK = 0 Else MsgBox "Error: The PromptForOverwrite variable must be either 'On' or 'Off'." + vbCR + vbCR + _ "You entered: '" + PromptForOverwrite + "'.", vbOKOnly, titleTxt WScript.Quit End If If LCase(EnableFormatFix) = "on" Then fixFormat = 1 ElseIf LCase(EnableFormatFix) = "off" Then fixFormat = 0 Else MsgBox "Error: The EnableFormatFix variable must be either 'On' or 'Off'." + vbCR + vbCR + _ "You entered: '" + EnableFormatFix + "'.", vbOKOnly, titleTxt WScript.Quit End If If PDFExport = 0 Then sDefaultExt = ".rtf" sApp = "RTF" sVerb = "convert" titleTxt = "Convert WP Files To RTF" ElseIf PDFExport = 1 Then sDefaultExt = ".pdf" sApp = "PDF" sVerb = "export" titleTxt = "Export WP Files to PDF" End If If FontMethod <> "" Then If LCase(FontMethod) <> "wholefile" Then If LCase(FontMethod) <> "multifont" Then MsgBox "Error: The FontMethod variable must be either blank" + vbCR + _ "or 'WholeFile' or 'MultiFont'." + vbCR + vbCR + _ "You entered: '" + FontMethod + "'.", vbOKOnly, titleTxt WScript.Quit End If End If End If ' Test for accuracy of fontnames If LCase(TestFontNames) = "yes" Then FontInstalled(AllDocFont) FontInstalled(NewFirstFont) FontInstalled(NewSecondFont) FontInstalled(NewThirdFont) End If End Sub Sub GetFilenames ' Get command-line parameters Set args = WScript.Arguments num = args.Count If num = 0 Then userPmt End If ' Parameter 1 can be file or folder or wildcard If num >= 1 Then sInFile = args.Item(0) ' clean up filespec by removing final dot if present If Right(sInFile,1) = "." Then Dim newLen : newLen = Len(sInFile) - 1 sInFile = Left(sInFile,newLen) End If ' assume filespec in script directory if no path entered If InStr(sInFile, "\") = 0 Then sInFile = CurDir + "\" + sInFile End If If oFSO.FileExists(sInFile) Then fName = oFSO.GetFileName(sInFile) sOutFile = sInFile + sDefaultExt Else If oFSO.FolderExists(sInFile) Then sSDir = sInFile sOutDir = sSDir bulkWP = 1 Else sSDir = CheckWildcard(sInFile) sOutDir = sSDir If bulkWP <= 1 Then MsgBox "Error: The specified file or folder does not exist.", _ vbOKOnly, titleTxt WScript.Quit End If End If End If End If ' Parameter 2 is either "default", a filename, or an output directory If num >= 2 Then sOutSpec = args.Item(1) If LCase(sOutSpec) = "default" Then default = 1 Else 'replace illegal characters < > : " / | ? * with underscore sOutSpec = Clean(sOutSpec) 'force conversion type according to output file extension If LCase(Right(sOutSpec,4)) = ".rtf" Then PDFExport = 0 arg2ext = "rtf" ElseIf LCase(Right(sOutSpec,4)) = ".pdf" Then PDFExport = 1 arg2ext = "pdf" End If ' assume filespec in script directory if no path entered If InStr(sOutSpec, "\") = 0 Then sOutSpec = CurDir + sOutSpec End If If bulkWP = 0 Then If oFSO.FolderExists(sOutSpec) Then FixMultsOutFile(sOutSpec) Else sOutFile = sOutSpec End If End If If bulkWP >= 1 Then If oFSO.FolderExists(sOutSpec) Then sOutDir = sOutSpec If bulkWP = 2 Then bulkWP = 4 Else bulkWP = 3 End If Else MsgBox "Error: When processing multiple files Parameter 2 must be an " + _ "existing folder.", vbOKOnly, titleTxt WScript.Quit End If End If End If End If ' Parameter 3 "silent" means no prompting except for errors If num >= 3 Then Dim Param3OK : Param3OK = 0 'If args.Item(2) = "silent" Then If InStr(LCase(args.Item(2)), "silent") <> 0 Then Param3OK = 1 If replaceOK = 0 Then ' allow "forcesilent" to override IgnoreSilent ' this isn't mentioned in the documentation If InStr(LCase(args.Item(2)), "force") = 0 Then IgnoreSilent silent = 0 ElseIf InStr(LCase(args.Item(2)), "force") <> 0 Then replaceOK = 1 silent = 1 End If Else silent = 1 End If End If If InStr(UCase(args.Item(2)), "PDF") <> 0 Then Param3OK = 1 PDFExport = 1 If arg2ext = "rtf" Then MsgBox "Error: Output filename specifies RTF export, but Parameter 3 specifies PDF." + _ vbCR + vbCR + "Please use consistent command-line parameters.", vbOKonly, titleTxt WScript.Quit End If ElseIf InStr(UCase(args.Item(2)), "RTF") <> 0 Then Param3OK = 1 PDFExport = 0 If arg2ext = "pdf" Then MsgBox "Error: Output filename specifies PDF export, but Parameter 3 specifies RTF." + _ vbCR + vbCR + "Please use consistent command-line parameters.", vbOKonly, titleTxt WScript.Quit End If End If If Param3OK = 0 Then MsgBox "Parameter 3 must be either blank or any of the following:" + vbCR + vbCR + _ " PDF, RTF, silent, silentPDF, silentRTF" + vbCR + vbCR + "You entered " + _ Chr(34) + args.Item(2) + Chr(34) + ".", _ wScript.Quit End If End If ' Parameter 4 must be "subdirs" for use when processing a directory of files If num = 4 Then If args.Item(3) = "subdirs" Then If bulkWP >= 3 Then IgnoreSubdirs Else subdirs = 1 End If Else MsgBox "Parameter 4 must be " + Chr(34) + "subdirs" + Chr(34) + " or blank." + _ vbCR + vbCR + "You entered " + Chr(34) + args.Item(3) + Chr(34) + ".", _ vbOKOnly, titleTxt wScript.Quit End If End If If num >= 5 Then MsgBox "Too many command-line parameters.", _ vbOKOnly, titleTxt wScript.Quit End If End Sub Sub TestPdfOK If PDFExport = 1 Then Set oWord = CreateObject("Word.Application") If WordVer <= 11 Then MsgBox "Error: PDF Export requires Word 2007 SP2 or later.", _ vbOKOnly, titleTxt oWord.Quit WScript.Quit End If ' Word 2007 SP2 installs PDF exporter If WordVer = 12 Then wordBuild = oWord.Build Dim buildNum : buildNum = Right((wordBuild),4) If buildNum >= 6504 Then pdfOK = 1 Else MsgBox "Error: PDF Export requires Word 2007 SP2 or later.", _ vbOKOnly, titleTxt oWord.Quit WScript.Quit End If End If ' Word 2010 and later have PDF export If WordVer >= 13 Then pdfOK = 1 End If oWord.Quit End If If PDFExport = 0 Then sDefaultExt = ".rtf" sApp = "RTF" sVerb = "convert" titleTxt = "Convert WP Files To RTF" ElseIf PDFExport = 1 Then sDefaultExt = ".pdf" sApp = "PDF" sVerb = "export" titleTxt = "Export WP Files to PDF" End If End Sub Sub DisableWPFonts If Is32BitOS() = True Then ' Undocumented registry entries to prevent Word from using ' WPTypographicSymbols and similar fonts WSHShell.RegWrite "HKLM\Software\Microsoft\Shared Tools\Text " + _ "Converters\Import\WordPerfect6x\Options\NoWPFonts", "Yes", "REG_SZ" WSHShell.RegWrite "HKLM\Software\Microsoft\Shared Tools\Text " + _ "Converters\Import\WrdPrfctDos\Options\NoWPFonts", "Yes", "REG_SZ" End If End Sub Sub SetIE If Silent = 0 Then If BulkWP >= 1 Then Set oExplorer = WScript.CreateObject("InternetExplorer.Application") useIE = 1 End If End If End Sub Sub WordVersionControl ' If processing multiple files (bulkWP >= 1) then require Word 2003 or later If bulkWP >= 1 Then If wordOK = 0 Then bulkWP = 0 Dim wordName Select Case wordVer Case 9 wordName = "2000" Case 10 wordName = "2002 (Word XP)" Case Else MsgBox "This script does not work with Word 97 or earlier.", vbOKOnly, titleTxt wScript.Quit End Select MsgBox "On a system with Word " + wordName + ", this script will convert only " + _ "one file at a time." + vbCR + vbCR + _ "Please run the script again to convert a single file.", vbOKOnly, titleTxt wScript.Quit End If End If End Sub Sub BranchRoutines ' Test for bulkWP variable that tells what kind of operation to perform Select Case bulkWP ' 0 = process one file only Case 0 MsgOneFile If PDFExport = 0 Then ConvWPDoc ElseIf PDFExport = 1 Then ConvWPToPDF End If ' 1 = process directory full of files to same folder Case 1 CountDirs oFSO.GetFolder(sSDir) AskContinue RunIE CheckOutDir DirWalk oFSO.GetFolder(sSDir), oFSO.GetFolder(sOutDir) StopIE ' 2 = process wildcard specification to same folder Case 2 CountDirs oFSO.GetFolder(sSDir) AskContinueWild RunIE CheckOutDir DirWalkWild oFSO.GetFolder(sSDir), oFSO.GetFolder(sOutDir) StopIE ' 3 = process directory full of files to a different output folder Case 3 AskContinueMove RunIE CheckOutDir DirWalkMove oFSO.GetFolder(sSDir), oFSO.GetFolder(sOutDir) StopIE ' 4 = process wildcard specification to a different output folder Case 4 AskContinueMoveWild RunIE CheckOutDir DirWalkMoveWild oFSO.GetFolder(sSDir), oFSO.GetFolder(sOutDir) StopIE End Select End Sub Sub userPmt ' if no command-line parameters, prompt user for input file or folder or filespec Do While inExists = 0 If wordOK = 1 Then msgTxt = "Enter filename, directory name, or wildcard specification of " + _ "files to " + sVerb + " to " + sApp + " format. " + vbCR + vbCR + _ "This script converts WordPerfect files only." Else ' use different prompt for Word 2000/2002 and process one file only msgTxt = "Enter name of file to convert to Word format. " + vbCR + vbCR End If sInFile = InputBox(msgTxt, titleTxt, "") If Len(sInFile) = 0 Then wscript.Quit End If ' clean up filespec by removing final dot if present If Right(sInFile,1) = "." Then Dim newLen : newLen = Len(sInFile) - 1 sInFile = Left(sInFile,newLen) End If ' assume filespec in script directory if no path entered If InStr(sInFile, "\") = 0 Then sInFile = CurDir + sInFile End If ' if input file exists, assign default name to output file If oFSO.FileExists(sInFile) Then bulkWP = 0 inExists = 1 sOutFile = sInFile + sDefaultExt Else ' if input folder exists, proceed If oFSO.FolderExists(sInFile) Then sSDir = sInFile inExists = 1 bulkWP = 1 Else ' test for wildcard filespec sSDir = CheckWildcard(sInFile) If bulkWP <= 1 Then response = MsgBox("Error: The specified file or folder does not exist. " + _ "Please try again.", vbOK, titleTxt) If response = vbCancel Then WScript.Quit End If End If End If End If Loop End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''' Procedures for converting one file Sub msgOneFile ' replace illegal characters sOutFile = Clean(sOutFile) ' test for .rtf extension, add if needed sOutExt = LCase(Right(sOutFile, 4)) If sOutExt <> sDefaultExt Then sOutFile = sOutFile + sDefaultExt End If ' prompt to change name of output file if desired If silent = 0 Then If default = 0 Then msgTxt = "The file " + UCase(sInFile) + " will be " + sVerb + "ed" + _ " to " + sApp + " file" + vbCR + vbCR + sOutFile + vbCR + vbCR + _ "Use different filename for " + sVerb + "ed file?" styleBtn = VBYesNoCancel Or VBDefaultButton2 Or VBInformation response = MsgBox(msgTxt, StyleBtn, titleTxt) If response = VBYes Then GetsOutFile(sFilename) Else If response = VBCancel Then CancelQuit End If End If End If End If ' test for forbidden match of input and output filenames Do While UCase(sInFile) = UCase(sOutFile) msgTxt = "Source file and converted file must have different names." styleBtn = VBOK Or VBCritical response = MsgBox(msgTxt, StyleBtn, titleTxt) If response = VBCancel Then wScript.Quit End If GetsOutFile(sFilename) If Len(sOutFile) = 0 Then wscript.Quit End If Loop ' test whether specified output file already exists If silent = 0 Then Do While overwrite = 0 If oFSO.FileExists(sOutFile) Then msgTxt = "Output file " + sOutFile + " already exists!" + vbCR _ + vbCR + "Overwrite existing file?" styleBtn = VBYesNoCancel or VBDefaultButton2 or VBExclamation response = MsgBox(msgTxt, styleBtn, titleTxt) Select Case response Case VBCancel wScript.Quit Case VBYes overwrite = 1 Case VBNo getsOutFile(sFilename) End Select Else overwrite = 1 End If Loop End If End Sub Sub ConvWPDoc Set oWord = CreateObject("Word.Application") oWord.Visible = False If silent = 0 Then If LCase(TakesTimePrompt) = "on" Then response = MsgBox("File processing may take some time. " + _ "Press OK, and please wait.", vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End If End If 'save autoopen etc settings, and turn off for this file Dim secAutomation If WordOK = 1 Then secAutomation = oWord.AutomationSecurity oWord.AutomationSecurity = 3 End If Set oDoc = oWord.Documents.Open(sInFile, , True) Set oDoc = oWord.ActiveDocument If FontMethod <> "" Then FontReplace oDoc End If If WordOK = 1 Then fVer = oWord.WordBasic.FileVersion If InStr(UCase(fVer), UCase("WordPerfect")) Then If InStr(fVer, "6.x") Then wpVer = 6 Else wpVer = 5 End If If fixFormat = 1 Then AdjustFormat(oDoc) End If oDoc.SaveAs sOutFile, 6 ''' 6 = wdFormatRTF 'restore autoopen etc setting oWord.AutomationSecurity = secAutomation If silent = 0 Then msgTxt = "Converted file saved as " + sOutFile + vbCR + vbCR + _ "Open converted file for editing in Word?" styleBtn = VBYesNo Or VBDefaultButton2 Or VBInformation response = MsgBox(msgTxt, styleBtn, titleTxt) If response = VBNo Then oWord.Quit 0 wScript.Quit Else oWord.visible = True WSHShell.AppActivate("Microsoft Word") End If Else oWord.Quit 0 wScript.Quit End If Else MsgBox "Error: " + UCase(sInFile) + " is not a WordPerfect file." + vbCR + vbCR + _ "It has not been converted to Word format.", vbOKOnly, titleTxt oWord.Quit 0 wScript.Quit End If ElseIf wordOK = 0 Then ' don't test for WordPerfect file format in Word 2000/2002 If fixFormat = 1 Then wpVer = 5 AdjustFormat(oDoc) End If ''''''''''''''' oDoc.SaveAs sOutFile, 0 oDoc.SaveAs sOutFile, 6 ''' 6 = wdFormatRTF 'restore autoopen etc setting - not for Word 2000, XP oWord.AutomationSecurity = secAutomation If silent = 0 Then msgTxt = "Converted file saved as " + sOutFile + vbCR + vbCR + _ "Open converted file for editing in Word?" styleBtn = VBYesNo Or VBDefaultButton2 Or VBInformation response = MsgBox(msgTxt, styleBtn, titleTxt) If response = VBNo Then oWord.Quit 0 wScript.Quit Else oWord.visible = True WSHShell.AppActivate("Microsoft Word") End If Else oWord.Quit 0 wScript.Quit End If End If End Sub Sub ConvWPToPDF Set oWord = CreateObject("Word.Application") oWord.Visible = False If silent = 0 Then If LCase(TakesTimePrompt) = "on" Then response = MsgBox("File conversion may take some time. Press OK, and please wait.", _ vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End If End If 'save autoopen etc settings, and turn off for this file Dim secAutomation If WordOK = 1 Then secAutomation = oWord.AutomationSecurity oWord.AutomationSecurity = 3 End If Set oDoc = oWord.Documents.Open(sInFile, , True) Set oDoc = oWord.ActiveDocument If FontMethod <> "" Then FontReplace oDoc End If If WordOK = 1 Then fVer = oWord.WordBasic.FileVersion If InStr(UCase(fVer), UCase("WordPerfect")) Then If InStr(fVer, "6.x") Then wpVer = 6 Else wpVer = 5 End If If fixFormat = 1 Then AdjustFormat(oDoc) End If sPDFOut = Left(sOutFile, Len(sOutFile) -4) oDoc.ExportAsFixedFormat sPDFOut + sDefaultExt, 17, PDFOpen 'restore autoopen etc setting oWord.AutomationSecurity = secAutomation oWord.Quit 0 wScript.Quit Else MsgBox "Error: " + UCase(sInFile) + " is not a WordPerfect file." + vbCR + vbCR + _ "It has not been exported to PDF format.", _ vbOKOnly, titleTxt oWord.Quit 0 wScript.Quit End If End If End Sub Function GetsOutFile(sFilename) ' when converting one file, give user chance to change name of output file sUserIn = InputBox("Enter path and filename for converted file." + vbCR + vbCR + _ "Use the filename extension " + sDefaultExt + ". If you omit the " + _ sDefaultExt + " extension, " + "it will be added automatically.", _ titleTxt, sOutFile) If Len(sUserIn) = 0 Then wscript.Quit End If sOutFile = sUserIn sOutFile = Clean(sOutFile) ' add .doc extension if not already present sOutExt = LCase(Right(sOutFile, 4)) If sOutExt <> sDefaultExt Then sOutFile = sOutFile + sDefaultExt End If End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''' Procedures for converting files in folders Sub AskContinue If sOutFile <> "" Then If sOutFile <> "default" Then IgnoreParam End If End If If silent = 0 Then MsgTxt = "This script " + sVerb + "s to " + sApp + " format all WP files " + _ "in this directory:" + vbCR + vbCR + " " + sSDir + vbCR + vbCR + _ "The " + sVerb + "ed files will have the same name as the originals," + _ vbCR + "with a " + sDefaultExt + " extension added to the original " + _ "name and extension." + vbCR + vbCR + _ "The original files will not be changed (but see Warning below)." + vbCR + vbCR + _ "Warning: If this directory includes a WP file named MYFILE1" + vbCR + _ "and a file named MYFILE1" + sDefaultExt + ", then the original MYFILE1" + _ sDefaultExt + vbCR + "will be overwritten during conversion." + vbCR + vbCR + _ "Files with these extensions will not be processed:" + vbCR + _ " .BK!, .DOC, .DOCX, .EXE, .PDF, .XLS, .XLXS, .ZIP" + vbCR + vbCR + _ "Processing may take a long time. Continue?" response = MsgBox(MsgTxt, vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If If numDirs > 0 Then response = MsgBox("Also " + sVerb + " files in subdirectories?", _ vbYesNoCancel Or vbDefaultButton2, titleTxt) If response = vbCancel Then wScript.Quit End If If response = vbYes Then doDirs = 1 End If End If End If If silent = 1 Then If subdirs = 1 Then doDirs = 1 End If End If End Sub Sub CheckOutDir If sOutDir = "" Then sOutDir = sSDir End If End Sub Sub DirWalk(oDir, sOutDir) Dim oFiles : Set oFiles = oDir.Files Dim oFile For Each oFile In oFiles ' checkCount = checkCount + 1 If UseIE = 1 Then WaitIE End If ' test file extensions sFileExt = Right(UCase(oFile.Name),4) If InArray(sFileExt,ExtArray) = False Then sFileExt = Right(UCase(oFile.Name),5) If InArray(sFileExt,ExtArray) = False Then If PDFExport = 0 Then OpenAndSave oFile, sOutDir ElseIf PDFExport = 1 Then OpenAndExportPDF oFile, sOutDir End If End If End If Next If DoDirs = 1 Then Dim oSubDs : Set oSubDs = oDir.SubFolders Dim oSubD For Each oSubD In oSubDs sOutDir = oSubD DirWalk oSubD, sOutDir Next End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''' Procedures for wildcards Sub AskContinueWild If sOutFile <> "" Then If sOutFile <> "default" Then IgnoreParam End If End If If silent = 0 Then MsgTxt = "This script " + sVerb + "s to " + sApp + " format all WP files named" + _ vbCR + vbCR + " " + sWildSpec + vbCR + vbCR + "in this directory:" + _ vbCR + vbCR + " " + sSDir + vbCR + vbCR + _ "The " + sVerb + "ed files will have the same name as the originals," + _ vbCR + "with a " + sDefaultExt + " extension added to the original name " + _ "and extension." + vbCR + vbCR + _ "The original files will not be changed (but see Warning below)." + vbCR + vbCR + _ "Warning: If this directory includes a WP file named MYFILE1" + vbCR + _ "and a file named MYFILE1" + sDefaultExt + ", then the original MYFILE1" + _ sDefaultExt + vbCR + "will be overwritten." + vbCR + vbCR + _ "Files with these extensions will not be processed:" + vbCR + _ " .BK!, .DOC, .DOCX, .EXE, .PDF, .XLS, .XLXS, .ZIP" + vbCR + vbCR + _ "Processing may take a long time. Continue?" response = MsgBox(MsgTxt, vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If If numDirs > 0 Then response = MsgBox("Also " + sVerb + " files in subdirectories?", _ vbYesNoCancel Or vbDefaultButton2, titleTxt) If response = vbCancel Then wScript.Quit End If If response = vbYes Then doDirs = 1 End If End If End If If silent = 1 Then If subdirs = 1 Then doDirs =1 End If End If End Sub Sub DirWalkWild( oDir, oMove ) Dim oFiles : Set oFiles = oDir.Files Dim oFile For Each oFile In oFiles ' checkCount = checkCount + 1 If UseIE = 1 Then WaitIE End If If FileMatchesPattern(oFile.name, sWildSpec) Then ' test file extensions sFileExt = Right(UCase(oFile.Name),4) If InArray(sFileExt,ExtArray) = False Then sFileExt = Right(UCase(oFile.Name),5) If InArray(sFileExt,ExtArray) = False Then If PDFExport = 0 Then OpenAndSave oFile, sOutDir ElseIf PDFExport = 1 Then OpenAndExportPDF oFile, sOutDir End If End If End If End If Next If DoDirs = 1 Then Dim oSubDs : Set oSubDs = oDir.SubFolders Dim oSubD For Each oSubD In oSubDs sOutDir = oSubD DirWalkWild oSubD, sOutDir Next End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''' Procedures for converting files in folders to another folder Sub AskContinueMove If silent = 0 Then MsgTxt = "This script " + sVerb + "s to " + sApp + " format all WP files "+ _ "in this directory:" + vbCR + vbCR + " " + sSDir + vbCR + vbCR + _ "The " + sVerb + "ed files will be written to this directory:" + _ vbCR + vbCR + " " + sOutDir + vbCR + vbCR + _ "The " + sVerb + "ed files have the same name as the originals," + vbCR + _ "with " + sDefaultExt + " appended to the original name and extension." + _ vbCR + vbCR + "Subdirectories will not be processed." + vbCR + vbCR + _ "Warning: Processing will overwrite any existing files in" + vbCR + _ + sOutDir + " that have the same names as the output files." + vbCR + vbCR + _ "Files with these extensions will not be processed:" + vbCR + _ " .BK!, .DOC, .DOCX, .EXE, .PDF, .XLS, .XLXS, .ZIP" + vbCR + vbCR + _ "Processing may take a long time. Continue?" response = MsgBox(MsgTxt, vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End If End Sub Sub DirWalkMove(oDir, oMove) Dim oFiles : Set oFiles = oDir.Files Dim oFile For Each oFile In oFiles ' checkCount = checkCount + 1 If UseIE = 1 Then WaitIE End If ' test file extensions sFileExt = Right(UCase(oFile.Name),4) If InArray(sFileExt,ExtArray) = False Then sFileExt = Right(UCase(oFile.Name),5) If InArray(sFileExt,ExtArray) = False Then If PDFExport = 0 Then OpenAndSave oFile, sOutDir ElseIf PDFExport = 1 Then OpenAndExportPDF oFile, sOutDir End If End If End If Next End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''' Procedures for converting wildcards to a different folder Sub AskContinueMoveWild If silent = 0 Then MsgTxt = "This script " + sVerb + "s to " + sApp + " format all WP files named" _ + vbCR + vbCR + " " + sWildSpec + vbCR + vbCR + "in this directory:" + _ vbCR + vbCR + " " + sSDir + vbCR + vbCR + _ "The " + sVerb + "ed files will be written to this directory:" + _ vbCR + vbCR + " " + sOutDir + vbCR + vbCR + _ "The " + sVerb + "ed files have the same name " + "as the originals," + vbCR + _ "with " + sDefaultExt + "appended to the original name and extension." + _ vbCR + vbCR + "Subdirectories will not be processed." + vbCR + vbCR + _ "Warning: Processing will overwrite any existing files in" + vbCR + _ + sOutDir + " with the same names as the output files." + vbCR + vbCR + _ "Files with these extensions will not be processed:" + vbCR + _ " .BK!, .DOC, .DOCX, .EXE, .PDF, .XLS, .XLXS, .ZIP" + vbCR + vbCR + _ "Processing may take a long time. Continue?" response = MsgBox(MsgTxt, vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End If If silent = 1 Then End If End Sub Sub DirWalkMoveWild(oDir,oMove ) Dim oFiles : Set oFiles = oDir.Files Dim oFile For Each oFile In oFiles ' checkCount = checkCount + 1 If UseIE = 1 Then WaitIE End If If FileMatchesPattern(oFile.name, sWildSpec) Then ' test file extensions sFileExt = Right(UCase(oFile.Name),4) If InArray(sFileExt,ExtArray) = False Then sFileExt = Right(UCase(oFile.Name),5) If InArray(sFileExt,ExtArray) = False Then If PDFExport = 0 Then OpenAndSave oFile, sOutDir ElseIf PDFExport = 1 Then OpenAndExportPDF oFile, sOutDir End If End If End If End If Next End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''' Shared subs and functions Sub CountDirs(oDir) Set oFolder = oFSO.GetFolder(sSDir) Set colSubfolders = oFolder.Subfolders numDirs = colSubfolders.Count End Sub Sub EndConv If bulkWP <> 0 Then If silent = 0 Then Select Case fileCount Case 0 MsgBox "No files were converted.", , titleTxt Case 1 MsgBox "One file converted.", , titleTxt Case Else MsgBox CStr(fileCount) + " files converted.", , titleTxt End Select End If End If wScript.Quit End Sub Function FixMultsOutFile(sFilename) Dim outFirst : outFirst = sOutSpec If Right(sOutSpec, 1) <> "\" Then sOutSpec = sOutSpec + "\" End If sUserIn = InputBox("Error: " + outFirst + " is a directory name." + vbCR + vbCR +_ "I think you want to use the output file specified below, "+ _ "but you may change it if you prefer." + vbCR + vbCR + _ "Use the filename extension .doc. If you omit the .doc extension, " + _ "it will be added automatically.", titleTxt, sOutSpec + fName + ".doc") If Len(sUserIn) = 0 Then wscript.Quit End If sOutFile = sUserIn sOutExt = LCase(Right(sOutFile, 4)) If sOutExt <> sDefaultExt Then sOutFile = sOutFile + sDefaultExt End If End Function Function CheckWildcard(strIn) Dim wildPos, wildLen, slantPos, dirLen wildPos = InStr(sInFile, "*") If wildPos = 0 Then wildPos = InStr(sInFile, "?") End If If wildPos <> 0 Then sInFile = Trim(sInFile) slantPos = InStrRev(sInFile, "\") wildLen = Len(sInFile) - SlantPos sWildSpec = Right(sInFile, wildLen) dirLen = Len(sInFile) - wildLen sSDir = Left(sInFile, dirLen) inExists = 1 bulkWP = 2 CheckWildcard = sSDir End If End Function Function clean(strToClean) 'Source: http://www.code-tips.com, with modifications by EM 'Remove illegal characters ?:*?"<> Dim charArray : charArray = Array("?","/","*","""","<",">","|") Dim arraySize : arraySize = UBound(charArray) 'get the size of the character array Dim tmpstr : tmpstr = strToClean 'store string in tempporary variable Dim cont : cont = True 'repeat string check for current character Dim current : current = 0 'store current array index 'Loop through illegal character array until all illegal chars removed from string Dim charAt, leftPart, rightPart Dim charChanged : charChanged = 0 While cont charAt = InStr(tmpstr,charArray(current)) 'msgbox (charAt) If (charAt > 0) Then leftPart = Left(tmpstr, charAt-1) rightPart = Mid(tmpstr, charAt+1, Len(tmpstr)) 'If charArray(current) = ":" Then ' tmpstr = leftPart & "-" & rightPart ' Else tmpstr = leftPart & "_" & rightPart charChanged = 1 'End If 'msgbox (leftPart) 'msgbox (rightPart) 'msgbox (tmpstr) Else 'Character not found in string If current < arraySize Then 'Increment current = current + 1 Else cont = False End If End If Wend 'Remove any : after 2nd character If InStr(3, tmpstr, ":") > 0 Then tmpstr = Left(tmpstr,2) + Replace(tmpstr, ":", "_", 3) charChanged = 1 End If If charChanged = 1 Then response = MsgBox("The specified filename includes one or more characters " + _ "that cannot be used" + vbCR + "in filenames. " + _ "This script replaces these illegal characters with underscores." + vbCR + vbCr + _ "The name you entered will be corrected to: " + vbCR + vbCR + tmpstr + vbCR + vbCR + _ "Press Cancel if you prefer to quit without saving the output file.", _ vbOK, titleTxt) If response = vbCancel Then WScript.Quit End If End If 'Return the cleaned string clean = tmpstr End Function Sub IgnoreParam response = MsgBox("Specified output file specification (" + Chr(34) + _ sOutSpec + Chr(34) + ")" + vbCR + _ "will be ignored when processing multiple files." + vbCR + vbCR + _ "For multiple files, either use " + chr(34) + "default" + chr(34) + _ " as output" + vbCR + "file specification, or leave Parameter 2 blank." + _ vbCR + vbCR + "Press OK to continue with multiple-file conversion.",_ vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End Sub Sub IgnoreSilent response = MsgBox("The 'silent' parameter may be used only when the " + _ "PromptForOverwrite " + vbCR + "option is marked 'off' in the script file." + _ vbCR + vbCR + "You must edit the script file by hand to change this option." + _ vbCR + vbCR + "Press OK to continue with prompted (not 'silent') file " + _ "conversion." + vbCR + "You will be prompted to overwrite any " + _ "output files that already exist.", vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End Sub Sub CancelQuit MsgBox "Macro cancelled. Your file was not converted.", _ vbOKOnly, titleTxt wScript.Quit End Sub Sub IgnoreSubdirs response = MsgBox("The " + Chr(34) + "subdirs" + Chr(34) + " parameter is ignored " + _ "when converting multiple" + vbCR + "files from one directory to another." + _ vbCR + vbCR + "Press OK to continue with conversion from one directory only.",_ vbOK, titleTxt) If response = vbCancel Then wScript.Quit End If End Sub Function InArray(item,A) Dim i For i=0 To UBound(A) Step 1 If A(i) = item Then InArray=True Exit Function End If Next InArray=False End Function Function FileMatchesPattern(strFileName, strWildCard) ' by Bigjokey at www.experts-exchange.com ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Function to test if a filename matches the wildcard characters passed. ' Params: ' strFileName String, Holding the name of the file to test (must not include the path) ' strWildCard String, Holding the wildcard string used to compare the file with. (eg. "*.vbs") ' Returns: ' True if the filename matches the wildcard, otherwise False. ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Dim objRegExp, strPattern Set objRegExp = CreateObject("VBScript.RegExp") ' Update the wildcard string to define a valid regular expression strPattern = Replace(strWildCard, ".", "\.") strPattern = Replace(strPattern, "*", ".*") '''''' next added by EM strPattern = Replace(strPattern, "?", ".") '''''' strPattern = "^" & strPattern & "$" With objRegExp .Pattern = strPattern .IgnoreCase = True .Global = True End With FileMatchesPattern = objRegExp.Test(strFileName) Set objRegExp = Nothing End Function Sub OpenAndSave(oFile, sOutDir) Set oWord = CreateObject("Word.Application") oWord.Visible = False 'save autoopen etc settings, and turn off for this file Dim secAutomation secAutomation = oWord.AutomationSecurity oWord.AutomationSecurity = 3 On Error Resume Next Set oDoc = oWord.Documents.Open(oFile.path, , True) If Err.Number <> 0 Then MsgBox "Word encountered an error when attempting to open " + oFile.path + "." + _ vbCR + vbCR + "This error was NOT caused by this script." + vbCR + vbCR + _ "The error was caused ONLY by Microsoft Word." + _ "You may want to try opening the file separately in Word." +vbCR + vbCR +_ "This script will stop. Some files may not have been converted.", _ vbOKOnly, titleTxt oWord.Quit 0 If silent = 0 Then oExplorer.Quit End If Wscript.Quit End If On Error GoTo 0 Set oDoc = oWord.ActiveDocument fVer = oWord.WordBasic.FileVersion If InStr(UCase(fVer), UCase("WordPerfect")) Then If InStr(fVer, "6.x") Then wpVer = 6 Else wpVer = 5 End If '' Overwrite prompting If replaceOK = 0 Then If oFSO.FileExists(sOutDir + "\" + oFile.name + sDefaultExt) Then Dim oTarget Set oTarget = oFSO.getFile(sOutDir + "\" + oFile.name + sDefaultExt) msgTxt = "Output file " + oTarget + " already exists!" + vbCR _ + vbCR + "Overwrite existing file? Press Yes to overwrite." + _ vbCR + vbCR + "Press No to skip this file, or Cancel to exit this script." styleBtn = VBYesNoCancel or VBDefaultButton2 or VBExclamation response = MsgBox(msgTxt, styleBtn, titleTxt) Select Case response Case VBCancel oWord.Quit 0 StopIE wScript.Quit Case VBNo oWord.AutomationSecurity = secAutomation 'oDoc = Nothing oWord.Quit 0 Exit Sub Case VBYes End Select End If End If '' Delete existing ouput file when replacing font If FontMethod <> "" Then If oFSO.FileExists(sOutDir + "\" + oFile.name + sDefaultExt) Then Dim oDelFile Set oDelFile = oFSO.getFile(sOutDir + "\" + oFile.name + sDefaultExt) oDelFile.Delete True End If FontReplace oDoc End If '' Delete existing ouput file when adjusting format If fixFormat = 1 Then If oFSO.FileExists(sOutDir + "\" + oFile.name + sDefaultExt) Then Dim oDelFileBis Set oDelFileBis = oFSO.getFile(sOutDir + "\" + oFile.name + sDefaultExt) oDelFileBis.Delete True End If AdjustFormat(oDoc) End If oDoc.SaveAs sOutDir + "\" + oFile.name + sDefaultExt, 6 'If useIE = 1 Then ' oExplorer.Document.Body.InnerHTML = "

Converting " & _ ' oFile.path & "
" & fileCount + 1 & " file(s) converted so far.

" ' WSHShell.AppActivate(titleTxt) 'End If fileCount = fileCount + 1 Else notCount = notCount + 1 End If Set oDoc = Nothing 'Set oFSO = Nothing 'restore autoopen etc setting oWord.AutomationSecurity = secAutomation oWord.Quit 0 End Sub Sub OpenAndExportPDF(oFile, sOutDir) Set oWord = CreateObject("Word.Application") oWord.Visible = False 'save autoopen etc settings, and turn off for this file Dim secAutomation secAutomation = oWord.AutomationSecurity oWord.AutomationSecurity = 3 On Error Resume Next Set oDoc = oWord.Documents.Open(oFile.path, , True) If Err.Number <> 0 Then MsgBox "Word encountered an error when attempting to open " + oFile.path + "." + _ vbCR + vbCR + "This error was NOT caused by this script." + vbCR + vbCR + _ "The error was caused ONLY by Microsoft Word." + _ "You may want to try opening the file separately in Word." +vbCR + vbCR +_ "This script will stop. Some files may not have been converted.", _ vbOKOnly, titleTxt oWord.Quit 0 If silent = 0 Then oExplorer.Quit End If Wscript.Quit End If On Error GoTo 0 Set oDoc = oWord.ActiveDocument fVer = oWord.WordBasic.FileVersion If InStr(UCase(fVer), UCase("WordPerfect")) Then If InStr(fVer, "6.x") Then wpVer = 6 Else wpVer = 5 End If '' Overwrite prompting If replaceOK = 0 Then If oFSO.FileExists(sOutDir + "\" + oFile.name + sDefaultExt) Then Dim oTarget Set oTarget = oFSO.getFile(sOutDir + "\" + oFile.name + sDefaultExt) msgTxt = "Output file " + oTarget + " already exists!" + vbCR _ + vbCR + "Overwrite existing file? Press Yes to overwrite." + vbCR + _ vbCR + "Press No to skip this file, or Cancel to exit this script." styleBtn = VBYesNoCancel or VBDefaultButton2 or VBExclamation response = MsgBox(msgTxt, styleBtn, titleTxt) Select Case response Case VBCancel oWord.Quit 0 StopIE wScript.Quit Case VBNo oWord.AutomationSecurity = secAutomation 'oDoc = Nothing oWord.Quit 0 Exit Sub Case VBYes End Select End If End If '' Delete existing ouput file when replacing font If FontMethod <> "" Then If oFSO.FileExists(sOutDir + "\" + oFile.name + sDefaultExt) Then Dim oDelFile Set oDelFile = oFSO.getFile(sOutDir + "\" + oFile.name + sDefaultExt) oDelFile.Delete True End If FontReplace oDoc End If '' Delete existing ouput file when adjusting format If fixFormat = 1 Then If oFSO.FileExists(sOutDir + "\" + oFile.name + sDefaultExt) Then Dim oDelFileBis Set oDelFileBis = oFSO.getFile(sOutDir + "\" + oFile.name + sDefaultExt) oDelFileBis.Delete True End If AdjustFormat(oDoc) End If oDoc.ExportAsFixedFormat sOutDir + "\" + oFile.name + sDefaultExt , 17, PDFOpen fileCount = fileCount + 1 Else notCount = notCount + 1 End If Set oDoc = Nothing 'Set oFSO = Nothing 'restore autoopen etc setting oWord.AutomationSecurity = secAutomation oWord.Quit 0 End Sub Sub FontReplace(oDoc) If FontMethod = "WholeFile" Then If AllDocFont <> "" Then 'Fix the skipped blank Header/Footer problem as provided by Peter Hewett lngJunk = oDoc.Sections(1).Headers(1).Range.StoryType 'Iterate through all story types in the current document For Each rngStory In oDoc.StoryRanges 'Iterate through all linked stories Do With rngStory.Font .Name = AllDocFont If NewFontSize > 0 Then .Size = NewFontSize End If End With 'Get next linked story (if any) Set rngStory = rngStory.NextStoryRange Loop Until rngStory Is Nothing Next End If End If If FontMethod = "MultiFont" Then Dim FontDict Set FontDict = CreateObject("Scripting.Dictionary") If BadFirstFont <> "" Then FontDict.add BadFirstFont, NewFirstFont If BadSecondFont <> "" Then FontDict.add BadSecondFont, NewSecondFont If BadThirdFont <> "" Then FontDict.add BadThirdFont, NewThirdFont End If End If End If Dim BadFont, NewFont Dim items : items = FontDict.Items Dim keys : keys = FontDict.Keys Dim i For i = 0 To FontDict.Count - 1 BadFont = keys(i) NewFont = items(i) 'Fix the skipped blank Header/Footer problem as provided by Peter Hewett lngJunk = oDoc.Sections(1).Headers(1).Range.StoryType 'Iterate through all story types in the current document For Each rngStory In oDoc.StoryRanges 'Iterate through all linked stories Do With rngStory.Find 'Run font replacement twice, first for bidirectional, then normal fonts .Font.NameBi = BadFont .Replacement.Font.Name = NewFont .Execute ,,,,,,,1,,,2 ' same as Wrap and Replace .Font.Name = BadFont .Replacement.Font.Name = NewFont .Execute ,,,,,,,1,,,2 ' same as Wrap and Replace End With 'Get next linked story (if any) Set rngStory = rngStory.NextStoryRange Loop Until rngStory Is Nothing Next Next End If End Sub Function FontInstalled(sFont) If sFont <> "" Then Const HKLM = &H80000002 Dim fontName : fontName = sFont Dim objReg : Set objReg = GetObject("winmgmts:\\.\root\default:StdRegProv") Dim strKeyPath : strKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Fonts" Dim arrNames objReg.EnumValues HKLM, strKeyPath, arrNames If IsArray(arrNames) Then If InStr(UCase(Join(arrNames, "|")), UCase(fontName + " (TrueType)")) Then 'WScript.Echo fontName & " is installed" FontInstalled = 1 ElseIf InStr(UCase(Join(arrNames, "|")), UCase(fontName + " Regular (TrueType)")) Then FontInstalled = 1 Else FontInstalled = 0 MsgBox "Error: The specified replacement font" + vbCR + vbCR + _ " " + fontName + vbCR + vbCR + _ "seems not to be installed in this system." + vbCR + _ "Please edit this script to correct the error.", vbOKOnly, titleTxt WScript.Quit End If End If End If End Function Function Is32BitOS() Is32BitOS = (GetObject("winmgmts:root\cimv2:Win32_Processor='cpu0'").AddressWidth = 32) End Function Function Is64BitOS() Is64BitOS = (GetObject("winmgmts:root\cimv2:Win32_Processor='cpu0'").AddressWidth = 64) End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''Internet Explorer message box Sub RunIE If useIE = 1 Then 'Dim oExplorer 'Set oExplorer = WScript.CreateObject("InternetExplorer.Application") oExplorer.Navigate "about:blank" oExplorer.ToolBar = 0 oExplorer.StatusBar = 0 oExplorer.Width=250 oExplorer.Height = 100 oExplorer.Left = 30 oExplorer.Top = 30 Do While (oExplorer.Busy) Wscript.Sleep 200 Loop oExplorer.Visible = 1 oExplorer.Document.Title = titleTxt oExplorer.Document.Body.InnerHTML = "

" & _ "Preparing to convert WordPerfect files.
" _ & "This may take several minutes to complete.

" WSHShell.AppActivate(titleTxt) End If End Sub Sub WaitIE oExplorer.Document.Body.InnerHTML = "

Checking " & _ "for WordPerfect files." & "
" & fileCount & " file(s) converted so far.

" WSHShell.AppActivate(titleTxt) End Sub Sub StopIE If useIE = 1 Then 'oExplorer.Document.Body.InnerHTML = "All files converted." 'Wscript.Sleep 2000 oExplorer.Quit End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''' Adjust formatting in Word Sub AdjustFormat(oDoc) If wpVer = 6 Then With oDoc ' .Compatibility(1) = True ' wdNoTabHangIndent - Do not add automatic tab stop for hanging indent ' .Compatibility(2) = False ' wdNoSpaceRaiseLower - No extra space for raised/lowered characters ' .Compatibility(3) = False ' wdPrintColBlack - Print colors as black on noncolor printers. ' .Compatibility(4) = True ' wdWrapTrailSpaces - Wrap trailing spaces to the next line ' .Compatibility(5) = False ' wdNoColumnBalance - Do not balance columns for continuous section starts ' .Compatibility(6) = False ' wdConvMailMergeEsc - Treat \" as "" in mailmerge data sources ' .Compatibility(7) = False ' wdSuppressSpBfAfterPgBrk - No Space Before after hard pg or col break ' .Compatibility(8) = False ' wdSuppressTopSpacing - Suppress extra line spacing at the top of a page ' .Compatibility(9) = False ' wdOrigWordTableRules - Combine table borders like Word 5.x for the Mac ' .Compatibility(10) = False ' wdTransparentMetafiles - Do not blank the area behind metafile pictures ' .Compatibility(11) = False ' wdShowBreaksInFrames - Show hard pg or col breaks in frames ' .Compatibility(12) = False ' wdSwapBordersFacingPages) - Swap left/right borders on odd facing pages ' .Compatibility(13) = False ' wdLeaveBackslashAlone - Convert backslash characters into Yen signs ' .Compatibility(14) = False ' wdExpandShiftReturn - No expand char spaces on lns ending in LineBreak ' .Compatibility(15) = False ' wdDontULTrailSpace - Draw underline on trailing spaces ' .Compatibility(16) = False ' wdDontBalanceSingleByteDoubleByteWidth - alance SBCS chars and DBCS chars ' .Compatibility(17) = False ' wdSuppressTopSpacingMac5) - No extra ln space at pg top like MacWord 5 ' .Compatibility(18) = False ' wdSpacingInWholePoints - Expand/condense by whole number of points ' .Compatibility(19) = False ' wdPrintBodyTextBeforeHeader - Print body text before header/footer ' .Compatibility(20) = False ' wdNoLeading - Do not adding leading between rows of text ' .Compatibility(21) = False ' wdNoSpaceForUL - Add space for underline ' .Compatibility(22) = False ' wdMWSmallCaps - use larger small caps like Word 5 for the Mac .Compatibility(23) = True ' wdNoExtraLineSpacing - Suppress extra line spacing the way WP5.x does ' .Compatibility(24) = False ' wdTruncateFontHeight - Truncate font height ' .Compatibility(25) = True ' wdSubFontBySize - Substitute fonts based on size ' .Compatibility(26) = False ' wdUsePrinterMetrics - Use printer metrics to lay out document ' .Compatibility(27) = False ' wdWW6BorderRules - Use Word 6.x/95 border rules ' .Compatibility(28) = False ' wdExactOnTop - Do not center "exact line height" lines ' .Compatibility(29) = True ' wdSuppressBottomSpacing - Suppress extra line spacing at foot of page ' .Compatibility(30) = False ' wdWPSpaceWidth - Set width of a space like WordPerfect 5.x ' .Compatibility(31) = False ' wdWPJustification - Do full justification like WPWin 6.x ' .Compatibility(32) = True ' wdLineWrapLikeWord6 - Line wrap like Word 6.0 ' .Compatibility(33) = True ' wdShapeLayoutLikeWW8 - Layout autoshapes like Word 97 ' .Compatibility(34) = True ' wdFootnoteLayoutLikeWW8 - Layout footnotes like Word 6/95/97 ' .Compatibility(35) = True ' wdDontUseHTMLParagraphAutoSpacing - Don't use HTML auto para spacing ' .Compatibility(36) = False ' wdDontAdjustLineHeightInTable - Adjust ln ht to grid ht in table ' .Compatibility(37) = True ' wdForgetLastTabAlignment) - Forget last tab alignment ' .Compatibility(38) = False ' wdAutospaceLikeWW7 - Autospace like Word 95 ' .Compatibility(39) = True ' wdAlignTablesRowByRow - Align table rows independently ' .Compatibility(40) = True ' wdLayoutRawTableWidth - Layout tables with raw width ' .Compatibility(41) = True ' wdLayoutTableRowsApart - Allow table rows to be laid out apart ' .Compatibility(42) = True ' wdUseWord97LineBreakingRules - Use Word97 rules for breaking Asian text ' .Compatibility(43) = True ' wdDontBreakWrappedTables - Don't break wrapped tables across pages ' .Compatibility(44) = True ' wdDontSnapTextToGridInTableWithObjects - Do not snap text to grid ' ' inside table with inline objects ' .Compatibility(45) = True ' wdSelectFieldWithFirstOrLastCharacter - Select entire field with ' ' first or last character ' .Compatibility(46) = False ' wdApplyBreakingRules - Use line-breaking rules ' .Compatibility(47) = False ' wdDontWrapTextWithPunctuation - No hanging punct with character grid ' .Compatibility(48) = True ' wdDontUseAsianBreakRulesInGrid - No Asian break rules in char. grid ' .Compatibility(49) = True ' wdUseWord2002TableStyleRules - Use Word 2002 table style rules ' .Compatibility(50) = True ' wdGrowAutofit - Allow tables to expand into margin ' .Compatibility(51) = True ' wdUseNormalStyleForList - Use normal style, not ListPara style for ' ' numbered and bulleted lists ' .Compatibility(52) = True ' wdDontUseIndentAsNumberingTabStop - Don't use hanging indent as tab ' ' stop for bullets and numbering ' .Compatibility(53) = True ' wdFELineBreak11 - Use Asian rules for hanging punct in Asian texts ' .Compatibility(54) = True ' wdAllowSpaceOfSameStyleInTable - Allow space btw paras in table ' .Compatibility(55) = True ' wdWW11IndentRules - Word 2003 rules for indents by wrapped objects ' .Compatibility(56) = True ' wdDontAutofitConstrainedTables - Don't autofit tables by wrapped objs ' .Compatibility(57) = True ' wdAutofitLikeWW11 - Use Word 2003 autofit table rules ' .Compatibility(58) = 1 ' wdUnderlineTabInNumList - Underline tab betw num and text in lists End With ElseIf wpVer = 5 Then With oDoc ' .Compatibility(1) = True ' wdNoTabHangIndent - Do not add automatic tab stop for hanging indent ' .Compatibility(2) = False ' wdNoSpaceRaiseLower - No extra space for raised/lowered characters ' .Compatibility(3) = False ' wdPrintColBlack - Print colors as black on noncolor printers. ' .Compatibility(4) = True ' wdWrapTrailSpaces - Wrap trailing spaces to the next line ' .Compatibility(5) = False ' wdNoColumnBalance - Do not balance columns for continuous section starts ' .Compatibility(6) = True ' wdConvMailMergeEsc - Treat \" as "" in mailmerge data sources ' .Compatibility(7) = False ' wdSuppressSpBfAfterPgBrk - No Space Before after hard pg or col break ' .Compatibility(8) = False ' wdSuppressTopSpacing - Suppress extra line spacing at the top of a page ' .Compatibility(9) = False ' wdOrigWordTableRules - Combine table borders like Word 5.x for the Mac ' .Compatibility(10) = False ' wdTransparentMetafiles - Do not blank the area behind metafile pictures ' .Compatibility(11) = False ' wdShowBreaksInFrames - Show hard pg or col breaks in frames ' .Compatibility(12) = False ' wdSwapBordersFacingPages) - Swap left/right borders on odd facing pages ' .Compatibility(13) = False ' wdLeaveBackslashAlone - Convert backslash characters into Yen signs ' .Compatibility(14) = False ' wdExpandShiftReturn - No expand char spaces on lns ending in LineBreak ' .Compatibility(15) = False ' wdDontULTrailSpace - Draw underline on trailing spaces ' .Compatibility(16) = False ' wdDontBalanceSingleByteDoubleByteWidth - balance SBCS & DBCS chars ' .Compatibility(17) = False ' wdSuppressTopSpacingMac5) - Suppress extra ln space at pg top like ' ' Word for the Mac 5.x ' .Compatibility(18) = False ' wdSpacingInWholePoints - Expand/condense by whole number of points ' .Compatibility(19) = False ' wdPrintBodyTextBeforeHeader - Print body text before header/footer ' .Compatibility(20) = False ' wdNoLeading - Do not adding leading between rows of text ' .Compatibility(21) = False ' wdNoSpaceForUL - Add space for underline ' .Compatibility(22) = Flase ' wdMWSmallCaps - use larger small caps like Word 5 for Mac .Compatibility(23) = True ' wdNoExtraLineSpacing - Suppress extra line spacing like WP5.x ' .Compatibility(24) = False ' wdTruncateFontHeight - Truncate font height ' .Compatibility(25) = False ' wdSubFontBySize - Substitute fonts based on size ' .Compatibility(26) = False ' wdUsePrinterMetrics - Use printer metrics to lay out document ' .Compatibility(27) = False ' wdWW6BorderRules - Use Word 6.x/95 border rules ' .Compatibility(28) = False ' wdExactOnTop - Do not center "exact line height" lines ' .Compatibility(29) = False ' wdSuppressBottomSpacing - Suppress extra line spacing ' .Compatibility(30) = False ' wdWPSpaceWidth - Set width of a space like WordPerfect 5.x ' .Compatibility(31) = False ' wdWPJustification - Do full justification like WPWin 6.x ' .Compatibility(32) = True ' wdLineWrapLikeWord6 - Line wrap like Word 6.0 ' .Compatibility(33) = True ' wdShapeLayoutLikeWW8 - Layout autoshapes like Word 97 ' .Compatibility(34) = True ' wdFootnoteLayoutLikeWW8 - Layout footnotes like Word 6/95/97 ' .Compatibility(35) = True ' wdDontUseHTMLParagraphAutoSpacing - Don't use HTML auto para spacing ' .Compatibility(36) = False ' wdDontAdjustLineHeightInTable - Adjust line ht to grid ht in table ' .Compatibility(37) = True ' wdForgetLastTabAlignment) - Forget last tab alignment ' .Compatibility(38) = False ' wdAutospaceLikeWW7 - Autospace like Word 95 ' .Compatibility(39) = True ' wdAlignTablesRowByRow - Align table rows independently ' .Compatibility(40) = True ' wdLayoutRawTableWidth - Layout tables with raw width ' .Compatibility(41) = True ' wdLayoutTableRowsApart - Allow table rows to be laid out apart ' .Compatibility(42) = True ' wdUseWord97LineBreakingRules - Use Word97 rules for breaking Asian text ' .Compatibility(43) = True ' wdDontBreakWrappedTables - Don't break wrapped tables across pages ' .Compatibility(44) = True ' wdDontSnapTextToGridInTableWithObjects - Do not snap text to grid ' ' inside table with inline objects ' .Compatibility(45) = True ' wdSelectFieldWithFirstOrLastCharacter - Select entire field with ' ' first or last character ' .Compatibility(46) = False ' wdApplyBreakingRules - Use line-breaking rules ' .Compatibility(47) = False ' wdDontWrapTextWithPunctuation - No hanging punct with character grid ' .Compatibility(48) = True ' wdDontUseAsianBreakRulesInGrid - No Asian break rules in char. grid ' .Compatibility(49) = True ' wdUseWord2002TableStyleRules - Use Word 2002 table style rules ' .Compatibility(50) = True ' wdGrowAutofit - Allow tables to expand into margin ' .Compatibility(51) = True ' wdUseNormalStyleForList - Use normal style, not ListPara style for ' ' numbered and bulleted lists ' .Compatibility(52) = True ' wdDontUseIndentAsNumberingTabStop - Don't use hanging indent as tab ' ' stop for bullets and numbering ' .Compatibility(53) = True ' wdFELineBreak11 - Use Asian rules for hanging punct in Asian texts ' .Compatibility(54) = True ' wdAllowSpaceOfSameStyleInTable - Allow space btw paras in table ' .Compatibility(55) = True ' wdWW11IndentRules - Word 2003 rules for indents by wrapped objects ' .Compatibility(56) = True ' wdDontAutofitConstrainedTables - Don't autofit tables by wrapped objs ' .Compatibility(57) = True ' wdAutofitLikeWW11 - Use Word 2003 autofit table rules ' .Compatibility(58) = 1 ' wdUnderlineTabInNumList - Underline tab betw num and text in lists End With End If End Sub