⭐ 欢迎来到虫虫下载站！ | 📦 资源下载 📁 资源专辑 ℹ️ 关于我们
⭐ 虫虫下载站
📤 上传资源

📄 rtf2html3.bas

📁 简单、实用、特别。 有很多不足之处
💻 BAS
📖 第 1 页 / 共 3 页
字号:
🔍
123 
    
    ClearCodes
    strHTML = ""
    gPlain = False
    gBOL = True
    
    'setup +CR option
    If InStr(strOptions, "+CR") <> 0 Then strCR = vbCrLf Else strCR = ""
    'setup +HTML option
    If InStr(strOptions, "+I") <> 0 Then gHTML = True Else gHTML = False

    strRTFTmp = TrimAll(strRTF)

    If Left(strRTFTmp, 1) = "{" And Right(strRTFTmp, 1) = "}" Then strRTFTmp = Mid(strRTFTmp, 2, Len(strRTFTmp) - 2)
    
    'setup color table
    lBOS = InStr(strRTFTmp, "\colortbl")
    If lBOS > 0 Then
        strSecTmp = NabSection(strRTFTmp, lBOS)
        GetColorTable strSecTmp, strColorTable()
    End If
    
    'setup font table
    lBOS = InStr(strRTFTmp, "\fonttbl")
    If lBOS > 0 Then
        strSecTmp = NabSection(strRTFTmp, lBOS)
        GetFontTable strSecTmp, strFontTable()
    End If
    
    'setup stylesheets
    lBOS = InStr(strRTFTmp, "\stylesheet")
    If lBOS > 0 Then
        strSecTmp = NabSection(strRTFTmp, lBOS)
        'ignore stylesheets for now
    End If
    
    'setup info
    lBOS = InStr(strRTFTmp, "\info")
    If lBOS > 0 Then
        strSecTmp = NabSection(strRTFTmp, lBOS)
        'ignore info for now
    End If
    
    'list table
    lBOS = InStr(strRTFTmp, "\listtable")
    If lBOS > 0 Then
        strSecTmp = NabSection(strRTFTmp, lBOS)
        'ignore info for now
    End If
    
    'list override table
    lBOS = InStr(strRTFTmp, "\listoverridetable")
    If lBOS > 0 Then
        strSecTmp = NabSection(strRTFTmp, lBOS)
        'ignore info for now
    End If

    While Len(strRTFTmp) > 0
        strSecTmp = NabNextLine(strRTFTmp)
        While Len(strSecTmp) > 0
            strWordTmp = NabNextWord(strSecTmp)
            If Len(strWordTmp) > 0 Then ProcessWord strWordTmp
        Wend
    Wend
    
    'get any remaining codes in stack
    Next2Codes
    strEndText = strEndText & GetAllCodes
    strBeforeText2 = rtf2html_replace(strBeforeText2, "<br>", "")
    strBeforeText2 = rtf2html_replace(strBeforeText2, vbCrLf, "")
    strCurPhrase = strCurPhrase & strBeforeText & strBeforeText2 & strEndText
    strBeforeText = ""
    strBeforeText2 = ""
    strBeforeText3 = ""
    strHTML = strHTML & strCurPhrase
    strCurPhrase = ""
    
    Dim strTitel As String
    
    If InStr(strOptions, "+T=") > 0 Then
        strTitel = GetTitel(0, "+T=", strOptions)
    End If
    
    If InStr(strOptions, "+H") > 0 Then
        strHtmlBody = strHtmlBody + "<HTML>" + strCR
        strHtmlBody = strHtmlBody + "<HEAD>" + strCR
        strHtmlBody = strHtmlBody + "<TITLE>" + strTitel + "</TITLE>" + strCR
        strHtmlBody = strHtmlBody + "</HEAD>" + strCR
        strHtmlBody = strHtmlBody + "<BODY bgcolor=" + "white" + " text=" + "black" + ">" + strCR
    
        rtf2html = strHtmlBody + strHTML + "</BODY>" + strCR + "</HTML>"
    Else
        rtf2html = strHTML
    End If
End Function

Public Function GetTitel(intPosition As Long, SearchStr As String, ByRef strarray As String) As String

  Dim strTemp As String
  Dim strValue As String
  Dim Counter As Integer
  Dim StartPosi As Integer
  

    On Error GoTo error

    
    StartPosi = InStr(LCase$(strarray), SearchStr) + Len(SearchStr)

    Do
        strValue = strValue + strTemp
        strTemp = Mid$(strarray, StartPosi + Counter, 1)
        Counter = Counter + 1
    Loop Until strTemp = vbCrLf Or Counter = Len(strarray)

    'Remove the ""
    If Left$(strValue, 1) = Chr$(34) Then strValue = Right$(strValue, Len(strValue) - 1)
    If Right$(strValue, 1) = Chr$(34) Then strValue = Left$(strValue, Len(strValue) - 1)

    GetTitel = Replace(strValue, " ", "")

Exit Function

error:
    GetTitel = ""

End Function

Function ShowCodes()
    Dim strTmp As String
    Dim l As Long
    
    strTmp = "Codes: "
    For l = 1 To UBound(Codes)
        strTmp = strTmp & Codes(l) & ", "
    Next l
    strTmp = strTmp & vbCrLf & "BegCodes: "
    For l = 1 To UBound(CodesBeg)
        strTmp = strTmp & CodesBeg(l) & ", "
    Next l
    strTmp = strTmp & vbCrLf & "NextCodes: "
    For l = 1 To UBound(NextCodes)
        strTmp = strTmp & NextCodes(l) & ", "
    Next l
    strTmp = strTmp & vbCrLf & "NextBegCodes: "
    For l = 1 To UBound(NextCodesBeg)
        strTmp = strTmp & NextCodesBeg(l) & ", "
    Next l
    MsgBox (strTmp)
End Function

Function TrimAll(ByVal strTmp As String) As String
    Dim l As Long
    
    strTmp = Trim(strTmp)
    l = Len(strTmp) + 1
    While l <> Len(strTmp)
        l = Len(strTmp)
        If Right(strTmp, 1) = vbCrLf Then strTmp = Left(strTmp, Len(strTmp) - 1)
        If Left(strTmp, 1) = vbCrLf Then strTmp = Right(strTmp, Len(strTmp) - 1)
        If Right(strTmp, 1) = vbCr Then strTmp = Left(strTmp, Len(strTmp) - 1)
        If Left(strTmp, 1) = vbCr Then strTmp = Right(strTmp, Len(strTmp) - 1)
        If Right(strTmp, 1) = vbLf Then strTmp = Left(strTmp, Len(strTmp) - 1)
        If Left(strTmp, 1) = vbLf Then strTmp = Right(strTmp, Len(strTmp) - 1)
    Wend
    TrimAll = strTmp
End Function

Function HTMLCode(strRTFCode As String) As String
    'given rtf code return html code
    Select Case strRTFCode
    Case "00"
        HTMLCode = "&nbsp;"
    Case "a9"
        HTMLCode = "&copy;"
    Case "b4"
        HTMLCode = "&acute;"
    Case "ab"
        HTMLCode = "&laquo;"
    Case "bb"
        HTMLCode = "&raquo;"
    Case "a1"
        HTMLCode = "&iexcl;"
    Case "bf"
        HTMLCode = "&iquest;"
    Case "c0"
        HTMLCode = "&Agrave;"
    Case "e0"
        HTMLCode = "&agrave;"
    Case "c1"
        HTMLCode = "&Aacute;"
    Case "e1"
        HTMLCode = "&aacute;"
    Case "c2"
        HTMLCode = "&Acirc;"
    Case "e2"
        HTMLCode = "&acirc;"
    Case "c3"
        HTMLCode = "&Atilde;"
    Case "e3"
        HTMLCode = "&atilde;"
    Case "c4"
        HTMLCode = "&Auml;"
    Case "e4"
        HTMLCode = "<FONT SIZE=""-1""><SUP>TM</SUP></FONT>"
    Case "c5"
        HTMLCode = "&Aring;"
    Case "e5"
        HTMLCode = "&aring;"
    Case "c6"
        HTMLCode = "&AElig;"
    Case "e6"
        HTMLCode = "&aelig;"
    Case "c7"
        HTMLCode = "&Ccedil;"
    Case "e7"
        HTMLCode = "&ccedil;"
    Case "d0"
        HTMLCode = "&ETH;"
    Case "f0"
        HTMLCode = "&eth;"
    Case "c8"
        HTMLCode = "&Egrave;"
    Case "e8"
        HTMLCode = "&egrave;"
    Case "c9"
        HTMLCode = "&Eacute;"
    Case "e9"
        HTMLCode = "&eacute;"
    Case "ca"
        HTMLCode = "&Ecirc;"
    Case "ea"
        HTMLCode = "&ecirc;"
    Case "cb"
        HTMLCode = "&Euml;"
    Case "eb"
        HTMLCode = "&euml;"
    Case "cc"
        HTMLCode = "&Igrave;"
    Case "ec"
        HTMLCode = "&igrave;"
    Case "cd"
        HTMLCode = "&Iacute;"
    Case "ed"
        HTMLCode = "&iacute;"
    Case "ce"
        HTMLCode = "&Icirc;"
    Case "ee"
        HTMLCode = "&icirc;"
    Case "cf"
        HTMLCode = "&Iuml;"
    Case "ef"
        HTMLCode = "&iuml;"
    Case "d1"
        HTMLCode = "&Ntilde;"
    Case "f1"
        HTMLCode = "&ntilde;"
    Case "d2"
        HTMLCode = "&Ograve;"
    Case "f2"
        HTMLCode = "&ograve;"
    Case "d3"
        HTMLCode = "&Oacute;"
    Case "f3"
        HTMLCode = "&oacute;"
    Case "d4"
        HTMLCode = "&Ocirc;"
    Case "f4"
        HTMLCode = "&ocirc;"
    Case "d5"
        HTMLCode = "&Otilde;"
    Case "f5"
        HTMLCode = "&otilde;"
    Case "d6"
        HTMLCode = "&Ouml;"
    Case "f6"
        HTMLCode = "&ouml;"
    Case "d8"
        HTMLCode = "&Oslash;"
    Case "f8"
        HTMLCode = "&oslash;"
    Case "d9"
        HTMLCode = "&Ugrave;"
    Case "f9"
        HTMLCode = "&ugrave;"
    Case "da"
        HTMLCode = "&Uacute;"
    Case "fa"
        HTMLCode = "&uacute;"
    Case "db"
        HTMLCode = "&Ucirc;"
    Case "fb"
        HTMLCode = "&ucirc;"
    Case "dc"
        HTMLCode = "&Uuml;"
    Case "fc"
        HTMLCode = "&uuml;"
    Case "dd"
        HTMLCode = "&Yacute;"
    Case "fd"
        HTMLCode = "&yacute;"
    Case "ff"
        HTMLCode = "&yuml;"
    Case "de"
        HTMLCode = "&THORN;"
    Case "fe"
        HTMLCode = "&thorn;"
    Case "df"
        HTMLCode = "&szlig;"
    Case "a7"
        HTMLCode = "&sect;"
    Case "b6"
        HTMLCode = "&para;"
    Case "b5"
        HTMLCode = "&micro;"
    Case "a6"
        HTMLCode = "&brvbar;"
    Case "b1"
        HTMLCode = "&plusmn;"
    Case "b7"
        HTMLCode = "&middot;"
    Case "a8"
        HTMLCode = "&uml;"
    Case "b8"
        HTMLCode = "&cedil;"
    Case "aa"
        HTMLCode = "&ordf;"
    Case "ba"
        HTMLCode = "&ordm;"
    Case "ac"
        HTMLCode = "&not;"
    Case "ad"
        HTMLCode = "&shy;"
    Case "af"
        HTMLCode = "&macr;"
    Case "b0"
        HTMLCode = "&deg;"
    Case "b9"
        HTMLCode = "&sup1;"
    Case "b2"
        HTMLCode = "&sup2;"
    Case "b3"
        HTMLCode = "&sup3;"
    Case "bc"
        HTMLCode = "&frac14;"
    Case "bd"
        HTMLCode = "&frac12;"
    Case "be"
        HTMLCode = "&frac34;"
    Case "d7"
        HTMLCode = "&times;"
    Case "f7"
        HTMLCode = "&divide;"
    Case "a2"
        HTMLCode = "&cent;"
    Case "a3"
        HTMLCode = "&pound;"
    Case "a4"
        HTMLCode = "&curren;"
    Case "a5"
        HTMLCode = "&yen;"
    Case "85"
        HTMLCode = "..."
    End Select
End Function

Function TrimifCmd(ByVal strTmp As String) As String
    Dim l As Long
    
    l = 1
    While Mid(strTmp, l, 1) = " "
        l = l + 1
    Wend
    If Mid(strTmp, l, 1) = "\" Or Mid(strTmp, l, 1) = "{" Then
        strTmp = Trim(strTmp)
    Else
        If Left(strTmp, 1) = " " Then strTmp = Mid(strTmp, 2)
        strTmp = RTrim(strTmp)
    End If
    TrimifCmd = strTmp
End Function
123

⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -