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

'===============================================================
'                       Format
'===============================================================
Function WordExists(hash, word, isCaseSensitive)
    If isCaseSensitive Then
        WordExists = HashExists(hash,word)
    Else
        WordExists  = HashExists(hash, LCase(word))
    End If
End 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 = Nothing
End Function
Function 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 = Null
End Function
Function 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 If
End Function