<%
'Web RTF2HTML
'adapted by Andrew Powell for vbscript from rtf2html 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
'problems with vbscript email ajp@infoaccelerator.net
Class rtf2html
Dim strCurPhrase
Dim strHTML
Dim Codes()
Dim NextCodes()
Dim CodesBeg() 'beginning codes
Dim NextCodesBeg 'beginning codes for next text
Dim CodesTmp() 'temp stack for copying
Dim CodesTmpBeg() 'temp stack for copying beg
Public strCR 'string to use for CRs - blank if +CR not chosen in options
Dim strBeforeText
Dim strBeforeText2
Dim strBeforeText3
Dim gPlain 'true if all codes shouls be popped before next text
Dim gWBPlain 'plain will be true after next text
Dim strColorTable() 'table of colors
Dim lColors '# of colors
Dim strFontTable() 'table of fonts
Dim lFonts '# of fonts
Dim strEOL 'string to include before
Dim strBOL 'string to include after
Dim lSkipWords 'number od words to skip from current
Dim gBOL 'a
was inserted but no non-whitespace text has been inserted
Dim strFont
Dim strTable
Dim strFontColor 'current font color for setting up fontstring
Dim strFontSize 'current font size for setting up fontstring
Dim lFontSize
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)
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
Function IIf(blnExpression, vTrueResult, vFalseResult)
If blnExpression Then
IIf = vTrueResult
Else
IIf = vFalseResult
End If
End Function
Function 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 Function
Function GetFontTable(strSecTmp, strFontTable())
'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 Function
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
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
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
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 = "}"
Exit Function
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)
End Function
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
Function 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))
' May need to change to l = 0 to UBound(NextCodes)
For l = 1 To UBound(NextCodes)
Codes(lNumCodes + l) = NextCodes(l)
CodesBeg(lNumCodes + l) = NextCodesBeg(l)
Next
ReDim NextCodes(0)
ReDim NextCodesBeg(0)
End If
End Function
Function 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
ReDim Codes(0)
ReDim CodesBeg(0)
End If
End Function
Function ParseFont(strColor, strSize)
Dim strTmpFont
strTmpFont = " "" Then
strTmpFont = strTmpFont & " color=""" & strColor & """"
End If
' Let the font size be determined by the page's stylesheet / style
'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
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
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
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
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
Function ProcessWord(strWord)
Dim strTmp
Dim strTmpbeg
Dim l
Dim gPopAll
Dim strTableAlign 'current table alignment for setting up tablestring
Dim strTableWidth '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
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 = CLng(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 = CLng(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
ClearFont
ElseIf strWord = "\plain" Then
For l = 1 To UBound(CodesBeg)
CodesBeg(l) = ""
Next
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 Function
Function PushCode(strCode)
ReDim Preserve Codes(UBound(Codes) + 1)
Codes(UBound(Codes)) = strCode
End Function
Function PushTmp(strCode)
ReDim Preserve CodesTmp(UBound(CodesTmp) + 1)
CodesTmp(UBound(CodesTmp)) = strCode
End Function
Function PushTmpBeg(strCode)
ReDim Preserve CodesTmpBeg(UBound(CodesTmpBeg) + 1)
CodesTmpBeg(UBound(CodesTmpBeg)) = strCode
End Function
Function PushCodeBeg(strCode)
ReDim Preserve CodesBeg(UBound(CodesBeg) + 1)
CodesBeg(UBound(CodesBeg)) = strCode
End Function
Function PushNext(strCode)
If Len(strCode) > 0 Then
ReDim Preserve NextCodes(UBound(NextCodes) + 1)
NextCodes(UBound(NextCodes)) = strCode
End If
End Function
Function PushNextBeg(strCode)
ReDim Preserve NextCodesBeg(UBound(NextCodesBeg) + 1)
NextCodesBeg(UBound(NextCodesBeg)) = strCode
End Function
Function 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 Function
Function 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
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, 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
Function 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 Function
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, are you paying attention?
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
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, "
", "")
strBeforeText2 = rtf2html_replace(strBeforeText2, vbCrLf, "")
strCurPhrase = strCurPhrase & strBeforeText & strBeforeText2 & strEndText
strBeforeText = ""
strBeforeText2 = ""
strBeforeText3 = ""
strHTML = strHTML & strCurPhrase
strCurPhrase = ""
rtf2html = strHTML
End Function
Function ShowCodes()
Dim strTmp
Dim l
strTmp = "Codes: "
For l = 1 To UBound(Codes)
strTmp = strTmp & Codes(l) & ", "
Next
strTmp = strTmp & vbCrLf & "BegCodes: "
For l = 1 To UBound(CodesBeg)
strTmp = strTmp & CodesBeg(l) & ", "
Next
strTmp = strTmp & vbCrLf & "NextCodes: "
For l = 1 To UBound(NextCodes)
strTmp = strTmp & NextCodes(l) & ", "
Next
strTmp = strTmp & vbCrLf & "NextBegCodes: "
For l = 1 To UBound(NextCodesBeg)
strTmp = strTmp & NextCodesBeg(l) & ", "
Next
MsgBox (strTmp)
End Function
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
%>