VBScript的PDF转换工具.8.文档格式化

现在是戏肉部分，将任意格式的文件转换为PDF。

注：因为使用Word的保存为PDF文件功能，所以是有限制的，必须是Word能够正常打开的文件才能进行转换，否则....

 

'===============================================================' Format'===============================================================Function WordExists(hash, word, isCaseSensitive) If isCaseSensitive Then WordExists = HashExists(hash,word) Else WordExists = HashExists(hash, LCase(word)) End IfEnd Function Function SetFormat(wordAppObj, rngObj, fontname, fontsize, fontcolor) Dim selObj rngObj.Select Set selObj = wordAppObj.Selection If Not (IsNull(fontname) Or IsEmpty(fontname)) Then selObj.Font.Name = fontname End If If Not (IsNull(fontsize) Or IsEmpty(fontsize)) Then selObj.Font.Size = fontsize End If If Not (IsNull(fontcolor) Or IsEmpty(fontcolor)) Then selObj.Font.Color = fontcolor End If Set selObj = NothingEnd FunctionFunction FormatDoc(wordAppObj, docObj, ext) Dim confExists : confExists = ExtConfigExists(ext) ' If no config for this ext, convert the doc as plain text. If Not confExists Then Trace(STR_Format & ":" & STR_PlainText) SetFormat wordAppObj, docObj.Content, DefaultFontName, DefaultFontSize, DefaultFontColor Exit Function End If ' Config Dim configDesc : configDesc = GetConfigDesc(ext) Dim isCaseSensitive : isCaseSensitive = GetConfigCaseSensitive(ext) ' Key curWord Dim keyWordColor : keyWordColor = GetConfigKeyWordColor(ext) Dim keyWordList : keyWordList = GetConfigKeyWordList(ext, isCaseSensitive) ' Extended Key curWord Dim extKeyWordColor : extKeyWordColor = GetConfigExtKeyWordColor(ext) Dim extKeyWordList : extKeyWordList = GetConfigExtKeyWordList(ext, isCaseSensitive) Dim backwardWord : backwardWord = GetConfigBackwardWord(ext) ' content config Dim commentsMark : commentsMark = GetConfigCommentsMark(ext) Dim commentsColor : commentsColor = GetConfigCommentsColor(ext) ' String config Dim stringMark : stringMark = GetConfigStringMark(ext) Dim stringColor : stringColor = GetConfigStringColor(ext) ' Font Dim fontName : fontName = GetConfigFontName(ext) Dim fontSize : fontSize = GetConfigFontSize(ext) Dim fontColor : fontColor = GetConfigFontColor(ext) ' local variable Dim curWord, lastWord, trimedWord, content, wordColor, escStrMark Dim markIdx, pos, offset Dim curStat, isKeyWord, lastWordIsKeyWord ' obj Dim allWordsObj, lastWordObj, contentObj, rngObj Dim wordIdx, wordCount, wordPercentage, wordStep ' Set font SetFormat wordAppObj, docObj.Range(0, docObj.Sentences.Last.End), fontName, fontSize, fontColor Trace(STR_Format & ":" & configDesc) ' If caseinsensitive, turn key curWord To lower Case If Not isCaseSensitive Then For i = 0 To UBound(commentsMark, 1) commentsMark(i, 0) = LCase(commentsMark(i, 0)) commentsMark(i, 1) = LCase(commentsMark(i, 1)) Next For i = 0 To UBound(stringMark, 1) stringMark(i, 0) = LCase(stringMark(i, 0)) stringMark(i, 1) = LCase(stringMark(i, 1)) Next End If curStat = Stat_Other escStrMark = stringMark(markIdx, 1) & stringMark(markIdx, 0) lastWordIsKeyWord = False Set allWordsObj = docObj.Words wordStep = Int(allWordsObj.Count / 10) wordIdx = 0 ' Loop all words For Each curWordObj In allWordsObj wordIdx = wordIdx + 1 If wordIdx = wordStep Then wordPercentage = wordPercentage + 10 wordIdx = 0 Trace(wordPercentage & "%") End If curWord = "" ' Combine char To curWord For Each ch In curWordObj.Characters curWord = curWord + ch.Text Next If isCaseSensitive Then wordCopy = curWord Else wordCopy = LCase(curWord) End If If backwardWord <> "" Then If (isCaseSensitive And LCase(lastWord) = backwardWord) Or _ (Not isCaseSensitive And lastWord = backwardWord) Then wordCopy = lastWord & wordCopy End If End If trimedWord = Trim(wordCopy) Select Case curStat Case Stat_Comments ' Comments content = content + curWord pos = InStr(1, trimedWord, commentsMark(markIdx, 1)) If pos > 0 And (pos = Len(trimedWord) - 1 Or curWordObj.End = allWordsObj.Last.End) Then 'clear flag curStat = Stat_Other SetFormat wordAppObj, docObj.Range(contentObj.Start, curWordObj.End), Null, Null,commentsColor End If Case Stat_String pos = InStr(1, wordCopy, escStrMark) offset = 1 While pos > 0 offset = pos + Len(escStrMark) pos = InStr(offset, wordCopy, escStrMark) Wend pos = InStr(offset, wordCopy, stringMark(markIdx, 0)) If pos > 0 Then pos = pos + Len(stringMark(markIdx, 0)) - 1 content = content + Mid(wordCopy, 1, pos) curStat = Stat_Other SetFormat wordAppObj, docObj.Range(contentObj.Start, curWordObj.Start + pos), Null, Null, stringColor End If If curStat = Stat_String Then content = content + curWord End If Case Stat_Other ' Check content For i = 0 To UBound(commentsMark, 1) If InStr(1, trimedWord, commentsMark(i, 0)) = 1 Then pos = InStr(1, wordCopy, commentsMark(i, 0)) If Mid(wordCopy, pos) = commentsMark(i, 0) & commentsMark(i, 1) Then Set contentObj = docObj.Range(curWordObj.Start, curWordObj.End) SetFormat wordAppObj, contentObj, Null, Null, commentsColor Exit For Else markIdx = i curStat = Stat_Comments Set contentObj = curWordObj content = curWord Exit For End If End If Next ' Check string If curStat = Stat_Other Then For i = 0 To UBound(stringMark, 1) pos = InStr(1, wordCopy, stringMark(i, 0)) If pos > 0 Then Set contentObj = docObj.Range(curWordObj.Start, curWordObj.End) If Mid(wordCopy, pos) = stringMark(i, 0) & stringMark(i, 0) Then ' Empty string found curStat = Stat_Other SetFormat wordappObj, contentObj, Null, Null, stringColor Exit For Else curStat = Stat_String markIdx = i content = Mid(curWord, pos) If Len(wordCopy) - pos > Len(stringMark(i, 0)) Then pos = InStr(Len(wordCopy) - Len(stringMark(i, 0)), curWord, stringMark(i, 0)) If pos <> 0 Then 'String starts and ends in single curWord curStat = Stat_Other SetFormat wordappObj, contentObj, Null, Null, stringColor End If End If ' String begins Exit For End If End If Next End If If curStat = Stat_Other Then isKeyWord = False If Len(trimedWord) > 1 Then If WordExists(keyWordList, trimedWord, isCaseSensitive) Then isKeyWord = True wordColor = keyWordColor Else If WordExists(extKeyWordList, trimedWord, isCaseSensitive) Then isKeyWord = True wordColor = extKeyWordColor End If ' If is ext key curWord End If ' If is key curWord If isKeyWord Then If backwardWord <> "" And _ ((isCaseSensitive And lastWord = backwardWord) Or _ (Not isCaseSensitive And LCase(lastWord) = backwardWord)) Then ' Format Set rngObj = docObj.Range(lastWordObj.Start, curWordObj.End) Else Set rngObj = docObj.Range(curWordObj.Start, curWordObj.End) End If SetFormat wordAppObj, rngObj, Null, Null, wordColor End If End If ' If Len > 1 End If ' End of Case Stat_Other End Select lastWord = curWord Set lastWordObj = curWordObj Next ' For Each curWord ' Release Hash HashClear keyWordList HashClear extKeyWordList keyWordList = Null extKeyWordList = NullEnd FunctionFunction DocToPDF(path) Dim wordAppObj, curDocObj Set wordAppObj = CreateObject("Word.Application") wordAppObj.DisplayAlerts = 0 Dim inputFilePath, inputFileDir, inputFileName, inputFileBaseName, inputFileExt Dim outputFilePath, outputFileName ' input file info inputFilePath = FileSysObj.GetAbsolutePathName(path) inputFileDir = FileSysObj.GetParentFolderName(inputFilePath) inputFileBaseName = FileSysObj.GetBaseName(inputFilePath) inputFileName = FileSysObj.GetFileName(inputFilePath) inputFileExt = LCase(FileSysObj.GetExtensionName(inputFilePath)) ' If output file keeps the original extention If ExtConfigExists(inputFileExt) then outputFilePath = inputFilePath + "." + LCase(PDFExt) Else outputFilePath = inputFileDir + "/" + inputFileBaseName + "." + LCase(PDFExt) End If outputFileName = FileSysObj.GetFileName(outputFilePath) ' Remove old output file If FileSysObj.FileExists(outputFilePath) Then FileSysObj.DeleteFile(outputFilePath) End If REM open(path, confirm conversions, read-only) wordAppObj.Documents.Open inputFilePath, False, False, ,,,,,,, DefaultWordEncoding Set curDocObj = wordAppObj.Documents(1) Trace(STR_From & ":【" & inputFileName & "】 " & STR_Line & ":" & curDocObj.Sentences.Count & vbCrLf & _ STR_To & ":【" & outputFileName & "】") ' Format file FormatDoc wordAppObj, curDocObj, inputFileExt 'Save changes curDocObj.SaveAs outputFilePath, WordFormatPDF curDocObj.close Set curDocObj = Nothing wordAppObj.Quit WdDoNotSaveChanges Set wordAppObj = Nothing NumberOfFiles = NumberOfFiles + 1 'if remove the original file If RemoveOriginalFile Then FileSysObj.DeleteFile(inputFilePath) End IfEnd Function