rtf2html3.bas

简单、实用、特别。 有很多不足之处

    End If
End Function

Function PopTmpBeg() As String
    If UBound(CodesTmp) > 0 Then
        PopTmpBeg = CodesTmpBeg(UBound(CodesTmpBeg))
        ReDim Preserve CodesTmpBeg(UBound(CodesTmpBeg) - 1)
    End If
End Function

Function PopNext() As String
    If UBound(NextCodes) > 0 Then
        PopNext = NextCodes(UBound(NextCodes))
        ReDim Preserve NextCodes(UBound(NextCodes) - 1)
    End If
End Function

Function PopNextBeg() As String
    If UBound(NextCodesBeg) > 0 Then
        PopNextBeg = NextCodesBeg(UBound(NextCodesBeg))
        ReDim Preserve NextCodesBeg(UBound(NextCodesBeg) - 1)
    End If
End Function

Function ProcessWord(strWord As String)
    
    
    Dim l As Long
    
    
    Dim strTableAlign As String    'current table alignment for setting up tablestring
    Dim strTableWidth As String    'current table width for setting up tablestring
    
    If lSkipWords > 0 Then
        lSkipWords = lSkipWords - 1
        Exit Function
    End If
    If Left(strWord, 1) = "\" Or Left(strWord, 1) = "{" Or Left(strWord, 1) = "}" Then
        Select Case Left(strWord, 2)
        Case "}"
            For l = 1 To UBound(CodesBeg)
                CodesBeg(l) = ""
            Next l
            ClearFont
        Case "\b"    'bold
            If strWord = "\b" Then
                If Codes(UBound(Codes)) <> "</b>" Or (Codes(UBound(Codes)) = "</b>" And CodesBeg(UBound(Codes)) = "") Then
                    PushNext ("</b>")
                    PushNextBeg ("<b>")
                End If
            ElseIf strWord = "\bullet" Then
            ElseIf strWord = "\b0" Then    'bold off
                If InCodes("</b>") Then
                    Codes2NextTill ("</b>")
                ElseIf InNext("</b>") Then
                    RemoveFromNext ("</b>")
                End If
            End If
        Case "\c"
            If strWord = "\cf0" Then    'color font off
                If InCodes("</font>") Then
                    Codes2NextTill ("</font>")
                ElseIf InNext("</font>") Then
                    RemoveFromNext ("</font>")
                End If
            ElseIf Left(strWord, 3) = "\cf" And IsNumeric(Mid(strWord, 4)) Then  'color font
                'get color code
                l = Val(Mid(strWord, 4))
                If l <= UBound(strColorTable) And l > 0 Then
                    strFontColor = "#" & strColorTable(l)
                End If
                
                'insert color
                If strFontColor <> "#" Then
                    strFont = ParseFont(strFontColor, strFontSize)
                    If InNext("</font>") Then
                        ReplaceInNextBeg "</font>", strFont
                    ElseIf InCodes("</font>") Then
                        PushNext ("</font>")
                        PushNextBeg (strFont)
                        Codes2NextTill "</font>"
                    Else
                        PushNext ("</font>")
                        PushNextBeg (strFont)
                    End If
                End If
            End If
        Case "\f"
            If Left(strWord, 3) = "\fs" And IsNumeric(Mid(strWord, 4)) Then  'font size
                l = Val(Mid(strWord, 4))
                lFontSize = Int((l / 6) - 0)    'calc to convert RTF to HTML sizes
                If lFontSize > 8 Then lFontSize = 8
                If lFontSize < 1 Then lFontSize = 1
                strFontSize = Trim(lFontSize)
                'insert size
                If strFontSize <> "2" And strFontSize <> "" Then
                    strFont = ParseFont(strFontColor, strFontSize)
                    If InNext("</font>") Then
                        ReplaceInNextBeg "</font>", strFont
                    ElseIf InCodes("</font>") Then
                        PushNext ("</font>")
                        PushNextBeg (strFont)
                        Codes2NextTill "</font>"
                    Else
                        PushNext ("</font>")
                        PushNextBeg (strFont)
                    End If
                End If
            End If
        Case "\i"
            If strWord = "\i" Then 'italics
                If Codes(UBound(Codes)) <> "</i>" Or (Codes(UBound(Codes)) = "</i>" And CodesBeg(UBound(Codes)) = "") Then
                    PushNext ("</i>")
                    PushNextBeg ("<i>")
                End If
            ElseIf strWord = "\i0" Then 'italics off
                If InCodes("</i>") Then
                    Codes2NextTill ("</i>")
                ElseIf InNext("</i>") Then
                    RemoveFromNext ("</i>")
                End If
            End If
        Case "\l"
            'If strWord = "\listname" Then
            '    lSkipWords = 1
            'End If
        Case "\p"
            If strWord = "\par" Then
                strBeforeText2 = strBeforeText2 & strEOL & "<br>" & strCR
                gBOL = True
                'If Len(strBOL) > 0 Then
                '    PushNext ("</li>")
                '    PushNextBeg ("<li>")
                'End If
            ElseIf strWord = "\pard" Then
                For l = 1 To UBound(CodesBeg)
                    CodesBeg(l) = ""
                Next l
                ClearFont
            ElseIf strWord = "\plain" Then
                For l = 1 To UBound(CodesBeg)
                    CodesBeg(l) = ""
                Next l
                ClearFont
            ElseIf strWord = "\pnlvlblt" Then 'bulleted list
                'If Codes(UBound(Codes)) = "</u>" Then
                '    strTmp = PopCode
                '    strTmp = PopCodeBeg
                'End If
                'PushNext ("</ul>")
                'PushNextBeg ("<ul>")

                'strBOS = "<UL>"
                'strBOL = "<li>"
                'strEOL = "</li>"
                'strEOP = "</UL>"
            ElseIf strWord = "\pntxta" Then 'numbered list?
                lSkipWords = 1
            ElseIf strWord = "\pntxtb" Then 'numbered list?
                lSkipWords = 1
            End If
        Case "\q"
            If strWord = "\qc" Then    'centered
                strTableAlign = "center"
                strTableWidth = "100%"
                If InNext("</td></tr></table>") Then
                    '?
                Else
                    strTable = "<table width=" & strTableWidth & "><tr><td align=""" & strTableAlign & """>"
                End If
                If InNext("</td></tr></table>") Then
                    ReplaceInNextBeg "</td></tr></table>", strTable
                ElseIf InCodes("</td></tr></table>") Then
                    PushNext ("</td></tr></table>")
                    PushNextBeg (strTable)
                    Codes2NextTill "</td></tr></table>"
                Else
                    PushNext ("</td></tr></table>")
                    PushNextBeg (strTable)
                End If
            ElseIf strWord = "\qr" Then    'right justified
                strTableAlign = "right"
                strTableWidth = "100%"
                If InNext("</td></tr></table>") Then
                    '?
                Else
                    strTable = "<table width=" & strTableWidth & "><tr><td align=""" & strTableAlign & """>"
                End If
                If InNext("</td></tr></table>") Then
                    ReplaceInNextBeg "</td></tr></table>", strTable
                ElseIf InCodes("</td></tr></table>") Then
                    PushNext ("</td></tr></table>")
                    PushNextBeg (strTable)
                    Codes2NextTill "</td></tr></table>"
                Else
                    PushNext ("</td></tr></table>")
                    PushNextBeg (strTable)
                End If
            End If
        Case "\s"
            'If strWord = "\snext0" Then    'style
            '    lSkipWords = 1
            'End If
        Case "\u"
            If strWord = "\ul" Then    'underline
                If Codes(UBound(Codes)) <> "</u>" Or (Codes(UBound(Codes)) = "</u>" And CodesBeg(UBound(Codes)) = "") Then
                    PushNext ("</u>")
                    PushNextBeg ("<u>")
                End If
            ElseIf strWord = "\ulnone" Then    'stop underline
                If InCodes("</u>") Then
                    Codes2NextTill ("</u>")
                ElseIf InNext("</u>") Then
                    RemoveFromNext ("</u>")
                End If
            End If
        End Select
    Else
        If Len(strWord) > 0 Then
            If Trim(strWord) = "" Then
                If gBOL Then strWord = rtf2html_replace(strWord, " ", "&nbsp;")
                strCurPhrase = strCurPhrase & strBeforeText3 & strWord
            Else
                strBeforeText = strBeforeText & GetAllCodes
                Next2Codes
                strBeforeText3 = GetAllCodesBeg
                RemoveBlanks
                
                strCurPhrase = strCurPhrase & strBeforeText
                strBeforeText = ""
                strCurPhrase = strCurPhrase & strBeforeText2
                strBeforeText2 = ""
                strCurPhrase = strCurPhrase & strBeforeText3 & strWord
                strBeforeText3 = ""
                gBOL = False
            End If
        End If
    End If
    'MsgBox (strWord)
End Function


Function PushCode(strCode As String)
    ReDim Preserve Codes(UBound(Codes) + 1)
    Codes(UBound(Codes)) = strCode
End Function

Function PushTmp(strCode As String)
    ReDim Preserve CodesTmp(UBound(CodesTmp) + 1)
    CodesTmp(UBound(CodesTmp)) = strCode
End Function

Function PushTmpBeg(strCode As String)
    ReDim Preserve CodesTmpBeg(UBound(CodesTmpBeg) + 1)
    CodesTmpBeg(UBound(CodesTmpBeg)) = strCode
End Function

Function PushCodeBeg(strCode As String)
    ReDim Preserve CodesBeg(UBound(CodesBeg) + 1)
    CodesBeg(UBound(CodesBeg)) = strCode
End Function

Function PushNext(strCode As String)
    If Len(strCode) > 0 Then
        ReDim Preserve NextCodes(UBound(NextCodes) + 1)
        NextCodes(UBound(NextCodes)) = strCode
    End If
End Function

Function PushNextBeg(strCode As String)
    ReDim Preserve NextCodesBeg(UBound(NextCodesBeg) + 1)
    NextCodesBeg(UBound(NextCodesBeg)) = strCode
End Function

Function RemoveBlanks()
    Dim l As Long
    Dim lOffSet As Long
    
    l = 1
    lOffSet = 0
    While l <= UBound(CodesBeg) And l + lOffSet <= UBound(CodesBeg)
        If CodesBeg(l) = "" Then
            lOffSet = lOffSet + 1
        Else
            l = l + 1
        End If
        If l + lOffSet <= UBound(CodesBeg) Then
            Codes(l) = Codes(l + lOffSet)
            CodesBeg(l) = CodesBeg(l + lOffSet)
        End If
    Wend
    If lOffSet > 0 Then
        ReDim Preserve Codes(UBound(Codes) - lOffSet)
        ReDim Preserve CodesBeg(UBound(CodesBeg) - lOffSet)
    End If
End Function


Function RemoveFromNext(strRem As String)
    Dim l As Long
    Dim m As Long
    
    l = 1
    While l < UBound(NextCodes)
        If NextCodes(l) = strRem Then
            For m = l To UBound(NextCodes) - 1
                NextCodes(m) = NextCodes(m + 1)
                NextCodesBeg(m) = NextCodesBeg(m + 1)
            Next m
            l = m
        Else
            l = l + 1
        End If
    Wend
    ReDim Preserve NextCodes(UBound(NextCodes) - 1)
    ReDim Preserve NextCodesBeg(UBound(NextCodesBeg) - 1)
End Function

Function rtf2html_replace(ByVal strIn As String, ByVal strRepl As String, ByVal strWith As String) As String
    'replace all instances of strRepl in strIn with strWith
    Dim I As Integer
    
    If ((Len(strRepl) = 0) Or (Len(strIn) = 0)) Then
        rtf2html_replace = strIn
        Exit Function
    End If
    I = InStr(strIn, strRepl)
    While I <> 0
        strIn = Left(strIn, I - 1) & strWith & Mid(strIn, I + Len(strRepl))
        I = InStr(I + Len(strWith), strIn, strRepl)
    Wend
    rtf2html_replace = strIn
End Function

Function ReplaceInNextBeg(strCode As String, strWith As String)
    Dim l As Long
    
    l = 1
    While l <= UBound(NextCodes) And NextCodes(l) <> strCode
        l = l + 1
    Wend
    If NextCodes(l) = strCode Then
        NextCodesBeg(l) = strWith
    End If
End Function

Function rtf2html(strRTF As String, Optional strOptions As String) As String
    'Version 3.01b04
    'Copyright Brady Hegberg 2000
    '  I'm not licensing this software but I'd appreciate it if
    '  you'd to consider it to be under an lgpl sort of license
    
    'More information can be found at
    'http://www2.bitstream.net/~bradyh/downloads/rtf2htmlrm.html
    
    'Converts Rich Text encoded text to HTML format
    'if you find some text that this function doesn't
    'convert properly please email the text to
    '[e-mail]
    
    'Options:
    '+H              add an HTML header and footer
    '+G              add a generator Metatag
    '+T="MyTitle"    add a title (only works if +H is used)
    '+CR             add a carraige return after all <br>s
    '+I              keep html codes intact
    
    Dim strHTML As String
    Dim strRTFTmp As String
    Dim lBOS As Long                 'beginning of section                'end of section
   
    
    
    
    
    
    
    
    
    Dim gHTML As Boolean             'true if html codes should be left intact
    Dim strSecTmp As String          'temporary section buffer
    Dim strWordTmp As String         'temporary word buffer
    Dim strEndText As String         'ending text
    
    Dim strHtmlBody As String