rtf2html3.bas

VB做滴邮件收发系统,喜欢的朋友可以下载看看学习参考哈

Attribute VB_Name = "rtf2html"
Option Explicit

Private strCurPhrase As String
Private strHTML As String
Private Codes() As String
Private NextCodes() As String
Private CodesBeg() As String         'beginning codes
Private NextCodesBeg() As String     'beginning codes for next text
Private CodesTmp() As String         'temp stack for copying
Private CodesTmpBeg() As String      'temp stack for copying beg

Public strCR As String           'string to use for CRs - blank if +CR not chosen in options
Private strBeforeText As String
Private strBeforeText2 As String
Private strBeforeText3 As String
Private gPlain As Boolean            'true if all codes shouls be popped before next text
Private strColorTable() As String    'table of colors
Private lColors As Long              '# of colors
Private strFontTable() As String     'table of fonts
Private lFonts As Long               '# of fonts
Private strEOL As String             'string to include before <br>
Private lSkipWords As Long           'number od words to skip from current
Private gBOL As Boolean              'a <br> was inserted but no non-whitespace text has been inserted

Private strFont As String
Private strTable As String
Private strFontColor As String     'current font color for setting up fontstring
Private strFontSize As String      'current font size for setting up fontstring
Private lFontSize As Long

Function ClearCodes()
    ReDim Codes(0)
    ReDim NextCodes(0)
    ReDim CodesBeg(0)
    ReDim NextCodesBeg(0)
End Function


Function ClearFont()
    strFont = ""
    strTable = ""
    strFontColor = ""
    strFontSize = ""
    lFontSize = 0
End Function

Function Codes2NextTill(strCode As String)
    

    Dim l As Long

    l = UBound(Codes)
    While Codes(l) <> strCode And l >= 0
        l = l - 1
    Wend
    CodesBeg(l) = ""
    l = l + 1
    While l <= UBound(Codes)
        PushNext (Codes(l))
        PushNextBeg (CodesBeg(l))
        CodesBeg(l) = ""
        l = l + 1
    Wend
End Function

Function GetColorTable(strSecTmp As String, strColorTable() As String)
    'get color table data and fill in strColorTable array
    Dim lColors As Long
    Dim lBOS As Long
    Dim lEOS As Long
    Dim strTmp As String
    
    lBOS = InStr(strSecTmp, "\colortbl")
    ReDim strColorTable(0)
    lColors = 1
    If lBOS <> 0 Then
        lEOS = InStr(lBOS, strSecTmp, ";}")
        If lEOS <> 0 Then
            lBOS = InStr(lBOS, strSecTmp, "\red")
            While ((lBOS <= lEOS) And (lBOS <> 0))
                ReDim Preserve strColorTable(lColors)
                strTmp = Trim(Hex(Mid(strSecTmp, lBOS + 4, 1) & IIf(IsNumeric(Mid(strSecTmp, lBOS + 5, 1)), Mid(strSecTmp, lBOS + 5, 1), "") & IIf(IsNumeric(Mid(strSecTmp, lBOS + 6, 1)), Mid(strSecTmp, lBOS + 6, 1), "")))
                If Len(strTmp) = 1 Then strTmp = "0" & strTmp
                strColorTable(lColors) = strColorTable(lColors) & strTmp
                lBOS = InStr(lBOS, strSecTmp, "\green")
                strTmp = Trim(Hex(Mid(strSecTmp, lBOS + 6, 1) & IIf(IsNumeric(Mid(strSecTmp, lBOS + 7, 1)), Mid(strSecTmp, lBOS + 7, 1), "") & IIf(IsNumeric(Mid(strSecTmp, lBOS + 8, 1)), Mid(strSecTmp, lBOS + 8, 1), "")))
                If Len(strTmp) = 1 Then strTmp = "0" & strTmp
                strColorTable(lColors) = strColorTable(lColors) & strTmp
                lBOS = InStr(lBOS, strSecTmp, "\blue")
                strTmp = Trim(Hex(Mid(strSecTmp, lBOS + 5, 1) & IIf(IsNumeric(Mid(strSecTmp, lBOS + 6, 1)), Mid(strSecTmp, lBOS + 6, 1), "") & IIf(IsNumeric(Mid(strSecTmp, lBOS + 7, 1)), Mid(strSecTmp, lBOS + 7, 1), "")))
                If Len(strTmp) = 1 Then strTmp = "0" & strTmp
                strColorTable(lColors) = strColorTable(lColors) & strTmp
                lBOS = InStr(lBOS, strSecTmp, "\red")
                lColors = lColors + 1
            Wend
        End If
    End If
End Function

Function GetFontTable(strSecTmp As String, strFontTable() As String)
    'get font table data and fill in strFontTable array
    Dim lFonts As Long
    Dim lBOS As Long
    Dim lEOS As Long
    Dim strTmp As String
    
    lBOS = InStr(strSecTmp, "\fonttbl")
    ReDim strFontTable(0)
    lFonts = 0
    If lBOS <> 0 Then
        lEOS = InStr(lBOS, strSecTmp, ";}}")
        If lEOS <> 0 Then
            lBOS = InStr(lBOS, strSecTmp, "\f0")
            While ((lBOS <= lEOS) And (lBOS <> 0))
                ReDim Preserve strFontTable(lFonts)
                While ((Mid(strSecTmp, lBOS, 1) <> " ") And (lBOS <= lEOS))
                    lBOS = lBOS + 1
                Wend
                lBOS = lBOS + 1
                strTmp = Mid(strSecTmp, lBOS, InStr(lBOS, strSecTmp, ";") - lBOS)
                strFontTable(lFonts) = strFontTable(lFonts) & strTmp
                lBOS = InStr(lBOS, strSecTmp, "\f" & (lFonts + 1))
                lFonts = lFonts + 1
            Wend
        End If
    End If
End Function


Function InNext(strTmp) As Boolean
    Dim gTmp As Boolean
    Dim l As Long
    
    l = 1
    gTmp = False
    While l <= UBound(NextCodes) And Not gTmp
        If NextCodes(l) = strTmp Then gTmp = True
        l = l + 1
    Wend
    InNext = gTmp
End Function

Function InCodes(strTmp) As Boolean
    Dim gTmp As Boolean
    Dim l As Long
    
    l = 1
    gTmp = False
    While l <= UBound(Codes) And Not gTmp
        If Codes(l) = strTmp And Len(CodesBeg(l)) > 0 Then gTmp = True
        l = l + 1
    Wend
    InCodes = gTmp
End Function


Function NabNextLine(strRTF As String) As String
    Dim l As Long
    
    l = InStr(strRTF, vbCrLf)
    If l = 0 Then l = Len(strRTF)
    NabNextLine = TrimAll(Left(strRTF, l))
    If l = Len(strRTF) Then
        strRTF = ""
    Else
        strRTF = TrimAll(Mid(strRTF, l))
    End If
End Function

Function NabNextWord(strLine As String) As String
    Dim l As Long
    Dim lvl As Integer
    Dim gEndofWord As Boolean
    Dim gInCommand As Boolean    'current word is command instead of plain word
    
    gInCommand = False
    l = 0
    lvl = 0
    'strLine = TrimifCmd(strLine)
    If Left(strLine, 1) = "}" Then
        strLine = Mid(strLine, 2)
        NabNextWord = "}"
        GoTo finally
    End If
    While Not gEndofWord
        l = l + 1
        If l >= Len(strLine) Then
            If l = Len(strLine) Then l = l + 1
            gEndofWord = True
        ElseIf InStr("\{}", Mid(strLine, l, 1)) Then
            If l = 1 And Mid(strLine, l, 1) = "\" Then gInCommand = True
            If Mid(strLine, l + 1, 1) <> "\" And l > 1 And lvl = 0 Then
                gEndofWord = True
            End If
        ElseIf Mid(strLine, l, 1) = " " And lvl = 0 And gInCommand Then
            gEndofWord = True
        End If
    Wend
    
    If l = 0 Then l = Len(strLine)
    NabNextWord = Left(strLine, l - 1)
    While Len(NabNextWord) > 0 And InStr("{}", Right(NabNextWord, 1))
        NabNextWord = Left(NabNextWord, Len(NabNextWord) - 1)
    Wend
    While Len(NabNextWord) > 0 And InStr("{}", Left(NabNextWord, 1))
        NabNextWord = Right(NabNextWord, Len(NabNextWord) - 1)
    Wend
    strLine = Mid(strLine, l)
    If Left(strLine, 1) = " " Then strLine = Mid(strLine, 2)
finally:
End Function

Function NabSection(strRTF As String, lPos As Long) As String
    'grab section surrounding lPos, strip section out of strRTF and return it
    Dim lBOS As Long         'beginning of section
    Dim lEOS As Long         'ending of section
    Dim strChar As String
    Dim lLev As Long         'level of brackets/parens
    Dim lRTFLen As Long
    
    lRTFLen = Len(strRTF)
    
    lBOS = lPos
    strChar = Mid(strRTF, lBOS, 1)
    lLev = 1
    While lLev > 0
        lBOS = lBOS - 1
        If lBOS <= 0 Then
            lLev = lLev - 1
        Else
            strChar = Mid(strRTF, lBOS, 1)
            If strChar = "}" Then
                lLev = lLev + 1
            ElseIf strChar = "{" Then
                lLev = lLev - 1
            End If
        End If
    Wend
    lBOS = lBOS - 1
    If lBOS < 1 Then lBOS = 1
    
    lEOS = lPos
    strChar = Mid(strRTF, lEOS, 1)
    lLev = 1
    While lLev > 0
        lEOS = lEOS + 1
        If lEOS >= lRTFLen Then
            lLev = lLev - 1
        Else
            strChar = Mid(strRTF, lEOS, 1)
            If strChar = "{" Then
                lLev = lLev + 1
            ElseIf strChar = "}" Then
                lLev = lLev - 1
            End If
        End If
    Wend
    lEOS = lEOS + 1
    If lEOS > lRTFLen Then lEOS = lRTFLen
    NabSection = Mid(strRTF, lBOS + 1, lEOS - lBOS - 1)
    strRTF = Mid(strRTF, 1, lBOS) & Mid(strRTF, lEOS)
    strRTF = rtf2html_replace(strRTF, vbCrLf & vbCrLf, vbCrLf)
End Function

Function Next2Codes()
    'move codes from pending ("next") stack to current stack
    Dim lNumCodes As Long
    Dim l As Long
    
    If UBound(NextCodes) > 0 Then
        lNumCodes = UBound(Codes)
        ReDim Preserve Codes(lNumCodes + UBound(NextCodes))
        ReDim Preserve CodesBeg(lNumCodes + UBound(NextCodes))
        For l = 1 To UBound(NextCodes)
            Codes(lNumCodes + l) = NextCodes(l)
            CodesBeg(lNumCodes + l) = NextCodesBeg(l)
        Next l
        ReDim NextCodes(0)
        ReDim NextCodesBeg(0)
    End If
End Function

Function Codes2Next()
    'move codes from "current" stack to pending ("next") stack
    Dim lNumCodes As Long
    Dim l As Long
    
    If UBound(Codes) > 0 Then
        lNumCodes = UBound(NextCodes)
        ReDim Preserve NextCodes(lNumCodes + UBound(Codes))
        ReDim Preserve NextCodesBeg(lNumCodes + UBound(Codes))
        For l = 1 To UBound(Codes)
            NextCodes(lNumCodes + l) = Codes(l)
            NextCodesBeg(lNumCodes + l) = CodesBeg(l)
        Next l
        ReDim Codes(0)
        ReDim CodesBeg(0)
    End If
End Function

Function ParseFont(strColor As String, strSize As String) As String
    Dim strTmpFont As String
    
    strTmpFont = "<font"
    If strColor <> "" Then
       strTmpFont = strTmpFont & " color=""" & strColor & """"
    End If
    If strSize <> "" And strSize <> "2" Then
        strTmpFont = strTmpFont & " size=" & strSize
    End If
    strTmpFont = strTmpFont & ">"
    ParseFont = strTmpFont
End Function

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

Function GetAllCodes() As String
    Dim strTmp As String
    Dim l As Long
    
    strTmp = ""
    If UBound(Codes) > 0 Then
        For l = UBound(Codes) To 1 Step -1
            strTmp = strTmp & Codes(l)
        Next l
    End If
    GetAllCodes = strTmp
End Function

Function GetAllNextCodes() As String
    Dim strTmp As String
    Dim l As Long
    
    strTmp = ""
    If UBound(NextCodes) > 0 Then
        For l = 1 To UBound(NextCodes)
            strTmp = strTmp & NextCodes(l)
        Next l
    End If
    GetAllNextCodes = strTmp
End Function

Function GetAllCodesBeg() As String
    Dim strTmp As String
    Dim l As Long
    
    strTmp = ""
    If UBound(CodesBeg) > 0 Then
        For l = 1 To UBound(CodesBeg)
            strTmp = strTmp & CodesBeg(l)
        Next l
    End If
    GetAllCodesBeg = strTmp
End Function

Function GetAllNextCodesBeg() As String
    Dim strTmp As String
    Dim l As Long
    
    strTmp = ""
    If UBound(NextCodesBeg) > 0 Then
        For l = 1 To UBound(NextCodesBeg)
            strTmp = strTmp & NextCodesBeg(l)
        Next l
    End If
    GetAllNextCodesBeg = strTmp
End Function


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

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