<%
Response.Buffer = False
Class RTFConvert
'Version 3.01 Beta 3
'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
'bradyh@bitstream.net
Public strCurPhrase
Public strHTML
Public Codes()
Public NextCodes()
Public CodesBeg() 'beginning codes
Public NextCodesBeg() 'beginning codes for next text
Public CodesTmp() 'temp stack for copying
Public CodesTmpBeg() 'temp stack for copying beg
Public strCR 'string to use for CRs - blank if +CR not chosen in options
Public strBeforeText
Public strBeforeText2
Public strBeforeText3
Public gPlain 'true if all codes shouls be popped before next text
Public gWBPlain 'plain will be true after next text
Public strColorTable() 'table of colors
Public lColors '# of colors
Public strFontTable() 'table of fonts
Public lFonts '# of fonts
Public strEOL 'string to include before
Public strBOL 'string to include after
Public lSkipWords 'number od words to skip from current
Public gBOL 'a
was inserted but no non-whitespace text has been inserted
Public strFont
Public strTable
Public strFontColor 'current font color for setting up fontstring
Public strFontSize 'current font size for setting up fontstring
Public lFontSize
Sub ClearCodes()
ReDim Codes(0)
ReDim NextCodes(0)
ReDim CodesBeg(0)
ReDim NextCodesBeg(0)
End Sub
Sub ClearFont()
strFont = ""
strTable = ""
strFontColor = ""
strFontSize = ""
lFontSize = 0
End Sub
Function Codes2NextTill(strCode)
Dim strTmp
Dim strTmpbeg
' strTmp = PopCode
' strTmpbeg = PopCodeBeg
' If strTmp <> strCode Then
' PushNext strTmp
' PushNextBeg strTmpbeg
' End If
' While strTmp <> "" And strTmp <> strCode
' strTmp = PopCode
' strTmpbeg = PopCodeBeg
' If strTmp <> strCode Then
' PushNext strTmp
' PushNextBeg strTmpbeg
' End If
' Wend
' If strTmp = strCode Then
' PushCode strTmp
' PushCodeBeg "" 'blank beginning so it won't get output next time
' End If
Dim l
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
Private Function IIf(IIFStatement, IIFTrue, IIFFalse)
If Eval(IIFStatement) Then
IIf = Eval(IIFTrue)
Else
IIf = Eval(IIFFalse)
End If
End Function
Public Sub GetColorTable(strSecTmp, strColorTable())
'get color table data and fill in strColorTable array
Dim lColors
Dim lBOS
Dim lEOS
Dim strTmp
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 Sub
Public Sub GetFontTable(strSecTmp As String, strFontTable() As String)
'get font table data and fill in strFontTable array
Dim lFonts
Dim lBOS
Dim lEOS
Dim strTmp
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 Sub
Public Function InNext(strTmp)
Dim gTmp
Dim l
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
Public Function InCodes(strTmp)
Dim gTmp
Dim l
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
Public Function NabNextLine(strRTF)
Dim l
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
Public Function NabNextWord(strLine)
Dim l
Dim lvl
Dim gEndofWord
Dim gInCommand '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
Public Function NabSection(strRTF, lPos)
'grab section surrounding lPos, strip section out of strRTF and return it
Dim lBOS 'beginning of section
Dim lEOS 'ending of section
Dim strChar
Dim lLev 'level of brackets/parens
Dim lRTFLen
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
Public Sub Next2Codes()
'move codes from pending ("next") stack to current stack
Dim lNumCodes
Dim l
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 Sub
Public Sub Codes2Next()
'move codes from "current" stack to pending ("next") stack
Dim lNumCodes
Dim l
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 Sub
Public Function ParseFont(strColor, strSize)
Dim strTmpFont
strTmpFont = " "" 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()
If UBound(Codes) > 0 Then
PopCode = Codes(UBound(Codes))
ReDim Preserve Codes(UBound(Codes) - 1)
End If
End Function
Function GetAllCodes()
Dim strTmp
Dim l
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()
Dim strTmp
Dim l
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()
Dim strTmp
Dim l
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()
Dim strTmp
Dim l
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()
If UBound(CodesBeg) > 0 Then
PopCodeBeg = CodesBeg(UBound(CodesBeg))
ReDim Preserve CodesBeg(UBound(CodesBeg) - 1)
End If
End Function
Function PopTmp()
If UBound(CodesTmp) > 0 Then
PopTmp = CodesTmp(UBound(CodesTmp))
ReDim Preserve CodesTmp(UBound(CodesTmp) - 1)
End If
End Function
Function PopTmpBeg()
If UBound(CodesTmp) > 0 Then
PopTmpBeg = CodesTmpBeg(UBound(CodesTmpBeg))
ReDim Preserve CodesTmpBeg(UBound(CodesTmpBeg) - 1)
End If
End Function
Function PopNext()
If UBound(NextCodes) > 0 Then
PopNext = NextCodes(UBound(NextCodes))
ReDim Preserve NextCodes(UBound(NextCodes) - 1)
End If
End Function
Function PopNextBeg()
If UBound(NextCodesBeg) > 0 Then
PopNextBeg = NextCodesBeg(UBound(NextCodesBeg))
ReDim Preserve NextCodesBeg(UBound(NextCodesBeg) - 1)
End If
End Function
Sub ProcessWord(strWord)
Dim strTmp As String
Dim strTmpbeg As String
Dim l As Long
Dim gPopAll As Boolean
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)) <> "" Or (Codes(UBound(Codes)) = "" And CodesBeg(UBound(Codes)) = "") Then
PushNext ("")
PushNextBeg ("")
End If
ElseIf strWord = "\bullet" Then
ElseIf strWord = "\b0" Then 'bold off
If InCodes("") Then
Codes2NextTill ("")
ElseIf InNext("") Then
RemoveFromNext ("")
End If
End If
Case "\c"
If strWord = "\cf0" Then 'color font off
If InCodes("") Then
Codes2NextTill ("")
ElseIf InNext("") Then
RemoveFromNext ("")
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("") Then
ReplaceInNextBeg "", strFont
ElseIf InCodes("") Then
PushNext ("")
PushNextBeg (strFont)
Codes2NextTill ""
Else
PushNext ("")
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("") Then
ReplaceInNextBeg "", strFont
ElseIf InCodes("") Then
PushNext ("")
PushNextBeg (strFont)
Codes2NextTill ""
Else
PushNext ("")
PushNextBeg (strFont)
End If
End If
End If
Case "\i"
If strWord = "\i" Then 'italics
If Codes(UBound(Codes)) <> "" Or (Codes(UBound(Codes)) = "" And CodesBeg(UBound(Codes)) = "") Then
PushNext ("")
PushNextBeg ("")
End If
ElseIf strWord = "\i0" Then 'italics off
If InCodes("") Then
Codes2NextTill ("")
ElseIf InNext("") Then
RemoveFromNext ("")
End If
End If
Case "\l"
'If strWord = "\listname" Then
' lSkipWords = 1
'End If
Case "\p"
If strWord = "\par" Then
strBeforeText2 = strBeforeText2 & strEOL & "
" & strCR
gBOL = True
'If Len(strBOL) > 0 Then
' PushNext ("")
' PushNextBeg ("")
'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)) = "" Then
' strTmp = PopCode
' strTmp = PopCodeBeg
'End If
'PushNext ("")
'PushNextBeg ("")
'strBOS = ""
'strBOL = "- "
'strEOL = "
"
'strEOP = "
"
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("") Then
'?
Else
strTable = "") Then
ReplaceInNextBeg "", strTable
ElseIf InCodes("") Then
PushNext ("")
PushNextBeg (strTable)
Codes2NextTill ""
Else
PushNext ("")
PushNextBeg (strTable)
End If
ElseIf strWord = "\qr" Then 'right justified
strTableAlign = "right"
strTableWidth = "100%"
If InNext("") Then
'?
Else
strTable = "") Then
ReplaceInNextBeg "", strTable
ElseIf InCodes("") Then
PushNext ("")
PushNextBeg (strTable)
Codes2NextTill ""
Else
PushNext ("")
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)) <> "" Or (Codes(UBound(Codes)) = "" And CodesBeg(UBound(Codes)) = "") Then
PushNext ("")
PushNextBeg ("")
End If
ElseIf strWord = "\ulnone" Then 'stop underline
If InCodes("") Then
Codes2NextTill ("")
ElseIf InNext("") Then
RemoveFromNext ("")
End If
End If
End Select
Else
If Len(strWord) > 0 Then
If Trim(strWord) = "" Then
If gBOL Then strWord = rtf2html_replace(strWord, " ", " ")
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 Sub
Sub PushCode(strCode)
ReDim Preserve Codes(UBound(Codes) + 1)
Codes(UBound(Codes)) = strCode
End Sub
Sub PushTmp(strCode)
ReDim Preserve CodesTmp(UBound(CodesTmp) + 1)
CodesTmp(UBound(CodesTmp)) = strCode
End Function
Sub PushTmpBeg(strCode)
ReDim Preserve CodesTmpBeg(UBound(CodesTmpBeg) + 1)
CodesTmpBeg(UBound(CodesTmpBeg)) = strCode
End Sub
Sub PushCodeBeg(strCode)
ReDim Preserve CodesBeg(UBound(CodesBeg) + 1)
CodesBeg(UBound(CodesBeg)) = strCode
End Sub
Sub PushNext(strCode)
If Len(strCode) > 0 Then
ReDim Preserve NextCodes(UBound(NextCodes) + 1)
NextCodes(UBound(NextCodes)) = strCode
End If
End Sub
Sub PushNextBeg(strCode)
ReDim Preserve NextCodesBeg(UBound(NextCodesBeg) + 1)
NextCodesBeg(UBound(NextCodesBeg)) = strCode
End Sub
Sub RemoveBlanks()
Dim l
Dim lOffSet
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 Sub
Sub RemoveFromNext(strRem)
Dim l
Dim m
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 Sub
Function rtf2html_replace(ByVal strIn, ByVal strRepl, ByVal strWith)
'replace all instances of strRepl in strIn with strWith
Dim i
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
Sub ReplaceInNextBeg(strCode, strWith)
Dim l
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 Sub
Function rtf2html(strRTF, strOptions)
'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
'bradyh@bitstream.net
'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
s
'+I keep html codes intact
Dim strHTML
Dim strRTFTmp
Dim l
Dim lTmp
Dim lTmp2
Dim lTmp3
Dim lRTFLen
Dim lBOS 'beginning of section
Dim lEOS 'end of section
Dim strTmp
Dim strTmp2
Dim strEOS 'string to be added to end of section
Dim strBOS 'string to be added to beginning of section
Dim strEOP 'string to be added to end of paragraph
Dim strBOL 'string to be added to the begining of each new line
Dim strEOL 'string to be added to the end of each new line
Dim strEOLL 'string to be added to the end of previous line
Dim strCurFont 'current font code eg: "f3"
Dim strCurFontSize 'current font size eg: "fs20"
Dim strCurColor 'current font color eg: "cf2"
Dim strFontFace 'Font face for current font
Dim strFontColor 'Font color for current font
Dim lFontSize 'Font size for current font
Const gHellFrozenOver = False 'always false
Dim gSkip 'skip to next word/command
Dim strCodes 'codes for ascii to HTML char conversion
Dim strCurLine 'temp storage for text for current line before being added to strHTML
Dim strFontCodes 'list of font code modifiers
Dim gSeekingText 'True if we have to hit text before inserting a
Dim gText 'true if there is text (as opposed to a control code) in strTmp
Dim strAlign '"center" or "right"
Dim gAlign 'if current text is aligned
Dim strGen 'Temp store for Generator Meta Tag if requested
Dim strTitle 'Temp store for Title if requested
Dim gHTML 'true if html codes should be left intact
Dim strSecTmp 'temporary section buffer
Dim strWordTmp 'temporary word buffer
Dim strEndText 'ending text
Call 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)
Call GetColorTable(strSecTmp, strColorTable())
End If
'setup font table
lBOS = InStr(strRTFTmp, "\fonttbl")
If lBOS > 0 Then
strSecTmp = NabSection(strRTFTmp, lBOS)
Call 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, "
", "")
strBeforeText2 = rtf2html_replace(strBeforeText2, vbCrLf, "")
strCurPhrase = strCurPhrase & strBeforeText & strBeforeText2 & strEndText
strBeforeText = ""
strBeforeText2 = ""
strBeforeText3 = ""
strHTML = strHTML & strCurPhrase
strCurPhrase = ""
rtf2html = strHTML
End Function
Sub ShowCodes()
Dim strTmp
Dim l
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 Sub
Function TrimAll(ByVal strTmp)
Dim l
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)
'given rtf code return html code
Select Case strRTFCode
Case "00"
HTMLCode = " "
Case "a9"
HTMLCode = "©"
Case "b4"
HTMLCode = "´"
Case "ab"
HTMLCode = "«"
Case "bb"
HTMLCode = "»"
Case "a1"
HTMLCode = "¡"
Case "bf"
HTMLCode = "¿"
Case "c0"
HTMLCode = "À"
Case "e0"
HTMLCode = "à"
Case "c1"
HTMLCode = "Á"
Case "e1"
HTMLCode = "á"
Case "c2"
HTMLCode = "Â"
Case "e2"
HTMLCode = "â"
Case "c3"
HTMLCode = "Ã"
Case "e3"
HTMLCode = "ã"
Case "c4"
HTMLCode = "Ä"
Case "e4"
HTMLCode = "TM"
Case "c5"
HTMLCode = "Å"
Case "e5"
HTMLCode = "å"
Case "c6"
HTMLCode = "Æ"
Case "e6"
HTMLCode = "æ"
Case "c7"
HTMLCode = "Ç"
Case "e7"
HTMLCode = "ç"
Case "d0"
HTMLCode = "Ð"
Case "f0"
HTMLCode = "ð"
Case "c8"
HTMLCode = "È"
Case "e8"
HTMLCode = "è"
Case "c9"
HTMLCode = "É"
Case "e9"
HTMLCode = "é"
Case "ca"
HTMLCode = "Ê"
Case "ea"
HTMLCode = "ê"
Case "cb"
HTMLCode = "Ë"
Case "eb"
HTMLCode = "ë"
Case "cc"
HTMLCode = "Ì"
Case "ec"
HTMLCode = "ì"
Case "cd"
HTMLCode = "Í"
Case "ed"
HTMLCode = "í"
Case "ce"
HTMLCode = "Î"
Case "ee"
HTMLCode = "î"
Case "cf"
HTMLCode = "Ï"
Case "ef"
HTMLCode = "ï"
Case "d1"
HTMLCode = "Ñ"
Case "f1"
HTMLCode = "ñ"
Case "d2"
HTMLCode = "Ò"
Case "f2"
HTMLCode = "ò"
Case "d3"
HTMLCode = "Ó"
Case "f3"
HTMLCode = "ó"
Case "d4"
HTMLCode = "Ô"
Case "f4"
HTMLCode = "ô"
Case "d5"
HTMLCode = "Õ"
Case "f5"
HTMLCode = "õ"
Case "d6"
HTMLCode = "Ö"
Case "f6"
HTMLCode = "ö"
Case "d8"
HTMLCode = "Ø"
Case "f8"
HTMLCode = "ø"
Case "d9"
HTMLCode = "Ù"
Case "f9"
HTMLCode = "ù"
Case "da"
HTMLCode = "Ú"
Case "fa"
HTMLCode = "ú"
Case "db"
HTMLCode = "Û"
Case "fb"
HTMLCode = "û"
Case "dc"
HTMLCode = "Ü"
Case "fc"
HTMLCode = "ü"
Case "dd"
HTMLCode = "Ý"
Case "fd"
HTMLCode = "ý"
Case "ff"
HTMLCode = "ÿ"
Case "de"
HTMLCode = "Þ"
Case "fe"
HTMLCode = "þ"
Case "df"
HTMLCode = "ß"
Case "a7"
HTMLCode = "§"
Case "b6"
HTMLCode = "¶"
Case "b5"
HTMLCode = "µ"
Case "a6"
HTMLCode = "¦"
Case "b1"
HTMLCode = "±"
Case "b7"
HTMLCode = "·"
Case "a8"
HTMLCode = "¨"
Case "b8"
HTMLCode = "¸"
Case "aa"
HTMLCode = "ª"
Case "ba"
HTMLCode = "º"
Case "ac"
HTMLCode = "¬"
Case "ad"
HTMLCode = ""
Case "af"
HTMLCode = "¯"
Case "b0"
HTMLCode = "°"
Case "b9"
HTMLCode = "¹"
Case "b2"
HTMLCode = "²"
Case "b3"
HTMLCode = "³"
Case "bc"
HTMLCode = "¼"
Case "bd"
HTMLCode = "½"
Case "be"
HTMLCode = "¾"
Case "d7"
HTMLCode = "×"
Case "f7"
HTMLCode = "÷"
Case "a2"
HTMLCode = "¢"
Case "a3"
HTMLCode = "£"
Case "a4"
HTMLCode = "¤"
Case "a5"
HTMLCode = "¥"
Case "85"
HTMLCode = "..."
End Select
End Function
Function TrimifCmd(ByVal strTmp)
Dim l
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
End Class
%>