Título: Modulo RTF to HTML
Publicado por: Krnl64 en 25 Mayo 2006, 05:58 am
Aqui les hago otro regalito. Convierte texto con formato Ritch a HTML Que lo disfuten
Function RTF2HTML(strRTF As String, Optional strOptions As String, Optional strHeader As String, Optional strFooter As String) As String
'Version 2.9
'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)
Dim strHTML As String
Dim l As Long
Dim lTmp As Long
Dim lTmp2 As Long
Dim lTmp3 As Long
Dim lRTFLen As Long
Dim lBOS As Long 'beginning of section
Dim lEOS As Long 'end of section
Dim strTmp As String
Dim strTmp2 As String
Dim strEOS As String 'string to be added to end of section
Dim strBOS As String 'string to be added to beginning of section
Dim strEOP As String 'string to be added to end of paragraph
Dim strBOL As String 'string to be added to the begining of each new line
Dim strEOL As String 'string to be added to the end of each new line
Dim strEOLL As String 'string to be added to the end of previous line
Dim strCurFont As String 'current font code eg: "f3"
Dim strCurFontSize As String 'current font size eg: "fs20"
Dim strCurColor As String 'current font color eg: "cf2"
Dim strFontFace As String 'Font face for current font
Dim strFontColor As String 'Font color for current font
Dim lFontSize As Integer 'Font size for current font
Const gHellFrozenOver = False 'always false
Dim gSkip As Boolean 'skip to next word/command
Dim strCodes As String 'codes for ascii to HTML char conversion
Dim strCurLine As String 'temp storage for text for current line before being added to strHTML
Dim strColorTable() As String 'table of colors
Dim lColors As Long '# of colors
Dim strFontTable() As String 'table of fonts
Dim lFonts As Long '# of fonts
Dim strFontCodes As String 'list of font code modifiers
Dim gSeekingText As Boolean 'True if we have to hit text before inserting a </FONT>
Dim gText As Boolean 'true if there is text (as opposed to a control code) in strTmp
Dim strAlign As String '"center" or "right"
Dim gAlign As Boolean 'if current text is aligned
Dim strGen As String 'Temp store for Generator Meta Tag if requested
Dim strTitle As String 'Temp store for Title if requested
'setup HTML codes
strCodes = " {00}© {a9}´ {b4}« {ab}» {bb}¡ {a1}¿{bf}À{c0}à{e0}Á{c1}"
strCodes = strCodes & "á{e1}Â {c2}â {e2}Ã{c3}ã{e3}Ä {c4}ä {e4}Å {c5}å {e5}Æ {c6}"
strCodes = strCodes & "æ {e6}Ç{c7}ç{e7}Ð {d0}ð {f0}È{c8}è{e8}É{c9}é{e9}Ê {ca}"
strCodes = strCodes & "ê {ea}Ë {cb}ë {eb}Ì{cc}ì{ec}Í{cd}í{ed}Î {ce}î {ee}Ï {cf}"
strCodes = strCodes & "ï {ef}Ñ{d1}ñ{f1}Ò{d2}ò{f2}Ó{d3}ó{f3}Ô {d4}ô {f4}Õ{d5}"
strCodes = strCodes & "õ{f5}Ö {d6}ö {f6}Ø{d8}ø{f8}Ù{d9}ù{f9}Ú{da}ú{fa}Û {db}"
strCodes = strCodes & "û {fb}Ü {dc}ü {fc}Ý{dd}ý{fd}ÿ {ff}Þ {de}þ {fe}ß {df}§ {a7}"
strCodes = strCodes & "¶ {b6}µ {b5}¦{a6}±{b1}·{b7}¨ {a8}¸ {b8}ª {aa}º {ba}¬ {ac}"
strCodes = strCodes & "­ {ad}¯ {af}° {b0}¹ {b9}² {b2}³ {b3}¼{bc}½{bd}¾{be}× {d7}"
strCodes = strCodes & "÷{f7}¢ {a2}£ {a3}¤{a4}¥ {a5}... {85}"
'setup color table
lColors = 0
ReDim strColorTable(0)
lBOS = InStr(strRTF, "\colortbl")
If lBOS <> 0 Then
lEOS = InStr(lBOS, strRTF, ";}")
If lEOS <> 0 Then
lBOS = InStr(lBOS, strRTF, "\red")
While ((lBOS <= lEOS) And (lBOS <> 0))
ReDim Preserve strColorTable(lColors)
strTmp = Trim(Hex(mID(strRTF, lBOS + 4, 1) & IIf(IsNumeric(mID(strRTF, lBOS + 5, 1)), mID(strRTF, lBOS + 5, 1), "") & IIf(IsNumeric(mID(strRTF, lBOS + 6, 1)), mID(strRTF, lBOS + 6, 1), "")))
If Len(strTmp) = 1 Then strTmp = "0" & strTmp
strColorTable(lColors) = strColorTable(lColors) & strTmp
lBOS = InStr(lBOS, strRTF, "\green")
strTmp = Trim(Hex(mID(strRTF, lBOS + 6, 1) & IIf(IsNumeric(mID(strRTF, lBOS + 7, 1)), mID(strRTF, lBOS + 7, 1), "") & IIf(IsNumeric(mID(strRTF, lBOS + 8, 1)), mID(strRTF, lBOS + 8, 1), "")))
If Len(strTmp) = 1 Then strTmp = "0" & strTmp
strColorTable(lColors) = strColorTable(lColors) & strTmp
lBOS = InStr(lBOS, strRTF, "\blue")
strTmp = Trim(Hex(mID(strRTF, lBOS + 5, 1) & IIf(IsNumeric(mID(strRTF, lBOS + 6, 1)), mID(strRTF, lBOS + 6, 1), "") & IIf(IsNumeric(mID(strRTF, lBOS + 7, 1)), mID(strRTF, lBOS + 7, 1), "")))
If Len(strTmp) = 1 Then strTmp = "0" & strTmp
strColorTable(lColors) = strColorTable(lColors) & strTmp
lBOS = InStr(lBOS, strRTF, "\red")
lColors = lColors + 1
Wend
End If
End If
'setup font table
lFonts = 0
ReDim strFontTable(0)
lBOS = InStr(strRTF, "\fonttbl")
If lBOS <> 0 Then
lEOS = InStr(lBOS, strRTF, ";}}")
If lEOS <> 0 Then
lBOS = InStr(lBOS, strRTF, "\f0")
While ((lBOS <= lEOS) And (lBOS <> 0))
ReDim Preserve strFontTable(lFonts)
While ((mID(strRTF, lBOS, 1) <> " ") And (lBOS <= lEOS))
lBOS = lBOS + 1
Wend
lBOS = lBOS + 1
strTmp = mID(strRTF, lBOS, InStr(lBOS, strRTF, ";") - lBOS)
strFontTable(lFonts) = strFontTable(lFonts) & strTmp
lBOS = InStr(lBOS, strRTF, "\f" & (lFonts + 1))
lFonts = lFonts + 1
Wend
End If
End If
strHTML = ""
lRTFLen = Len(strRTF)
'seek first line with text on it
lBOS = InStr(strRTF, vbCrLf & "\deflang")
If lBOS = 0 Then GoTo finally Else lBOS = lBOS + 2
lEOS = InStr(lBOS, strRTF, vbCrLf & "\par")
If lEOS = 0 Then GoTo finally
While Not gHellFrozenOver
strTmp = mID(strRTF, lBOS, lEOS - lBOS)
l = lBOS
While l <= lEOS
strTmp = mID(strRTF, l, 1)
Select Case strTmp
Case "{"
l = l + 1
Case "}"
strCurLine = strCurLine & strEOS
strEOS = ""
l = l + 1
Case "\" 'special code
l = l + 1
strTmp = mID(strRTF, l, 1)
Select Case strTmp
Case "b"
If ((mID(strRTF, l + 1, 1) = " ") Or (mID(strRTF, l + 1, 1) = "\")) Then
'b = bold
strCurLine = strCurLine & "<B>"
strEOS = "</B>" & strEOS
If (mID(strRTF, l + 1, 1) = " ") Then l = l + 1
ElseIf (mID(strRTF, l, 7) = "bullet ") Then
strTmp = "•" 'bullet
l = l + 6
gText = True
Else
gSkip = True
End If
Case "c"
If ((mID(strRTF, l, 2) = "cf") And (IsNumeric(mID(strRTF, l + 2, 1)))) Then
'cf = color font
lTmp = Val(mID(strRTF, l + 2, 5))
If lTmp <= UBound(strColorTable) Then
strCurColor = "cf" & lTmp
strFontColor = "#" & strColorTable(lTmp)
gSeekingText = True
End If
'move "cursor" position to next rtf code
lTmp = l
While ((mID(strRTF, lTmp, 1) <> " ") And (mID(strRTF, lTmp, 1) <> "\"))
lTmp = lTmp + 1
Wend
If (mID(strRTF, lTmp, 1) = " ") Then
l = lTmp
Else
l = lTmp - 1
End If
Else
gSkip = True
End If
Case "e"
If (mID(strRTF, l, 7) = "emdash ") Then
strTmp = "—"
l = l + 6
gText = True
Else
gSkip = True
End If
Case "f"
If IsNumeric(mID(strRTF, l + 1, 1)) Then
'f# = font
'first get font number
lTmp = l + 2
strTmp2 = mID(strRTF, l + 1, 1)
While IsNumeric(mID(strRTF, lTmp, 1))
strTmp2 = strTmp2 & mID(strRTF, lTmp2, 1)
lTmp = lTmp + 1
Wend
lTmp = Val(strTmp2)
strCurFont = "f" & lTmp
If ((lTmp <= UBound(strFontTable)) And (strFontTable(lTmp) <> strFontTable(0))) Then
'insert codes if lTmp is a valid font # AND the font is not the default font
strFontFace = strFontTable(lTmp)
gSeekingText = True
End If
'move "cursor" position to next rtf code
lTmp = l
While ((mID(strRTF, lTmp, 1) <> " ") And (mID(strRTF, lTmp, 1) <> "\"))
lTmp = lTmp + 1
Wend
If (mID(strRTF, lTmp, 1) = " ") Then
l = lTmp
Else
l = lTmp - 1
End If
ElseIf ((mID(strRTF, l + 1, 1) = "s") And (IsNumeric(mID(strRTF, l + 2, 1)))) Then
'fs# = font size
'first get font size
lTmp = l + 3
strTmp2 = mID(strRTF, l + 2, 1)
While IsNumeric(mID(strRTF, lTmp, 1))
strTmp2 = strTmp2 & mID(strRTF, lTmp, 1)
lTmp = lTmp + 1
Wend
lTmp = Val(strTmp2)
strCurFontSize = "fs" & lTmp
lFontSize = Int((lTmp / 5) - 2)
If lFontSize = 2 Then
strCurFontSize = ""
lFontSize = 0
Else
gSeekingText = True
If lFontSize > 8 Then lFontSize = 8
If lFontSize < 1 Then lFontSize = 1
End If
'move "cursor" position to next rtf code
lTmp = l
While ((mID(strRTF, lTmp, 1) <> " ") And (mID(strRTF, lTmp, 1) <> "\"))
lTmp = lTmp + 1
Wend
If (mID(strRTF, lTmp, 1) = " ") Then
l = lTmp
Else
l = lTmp - 1
End If
Else
gSkip = True
End If
Case "i"
If ((mID(strRTF, l + 1, 1) = " ") Or (mID(strRTF, l + 1, 1) = "\")) Then
strCurLine = strCurLine & "<I>"
strEOS = "</I>" & strEOS
If (mID(strRTF, l + 1, 1) = " ") Then l = l + 1
Else
gSkip = True
End If
Case "l"
If (mID(strRTF, l, 10) = "ldblquote ") Then
'left doublequote
strTmp = "“"
l = l + 9
gText = True
ElseIf (mID(strRTF, l, 7) = "lquote ") Then
'left quote
strTmp = "‘"
l = l + 6
gText = True
Else
gSkip = True
End If
Case "p"
If ((mID(strRTF, l, 6) = "plain\") Or (mID(strRTF, l, 6) = "plain ")) Then
If (Len(strFontColor & strFontFace) > 0) Then
If Not gSeekingText Then strCurLine = strCurLine & "</FONT>"
strFontColor = ""
strFontFace = ""
End If
If gAlign Then
strCurLine = strCurLine & "</TD></TR></TABLE><BR>"
gAlign = False
End If
strCurLine = strCurLine & strEOS
strEOS = ""
If mID(strRTF, l + 5, 1) = "\" Then l = l + 4 Else l = l + 5 'catch next \ but skip a space
ElseIf (mID(strRTF, l, 9) = "pnlvlblt\") Then
'bulleted list
strEOS = ""
strBOS = "<UL>"
strBOL = "<LI>"
strEOL = "</LI>"
strEOP = "</UL>"
l = l + 7 'catch next \
ElseIf (mID(strRTF, l, 7) = "pntext\") Then
l = InStr(l, strRTF, "}") 'skip to end of braces
ElseIf (mID(strRTF, l, 6) = "pntxtb") Then
l = InStr(l, strRTF, "}") 'skip to end of braces
ElseIf (mID(strRTF, l, 10) = "pard\plain") Then
strCurLine = strCurLine & strEOS & strEOP
strEOS = ""
strEOP = ""
strBOL = ""
strEOL = "<BR>"
l = l + 3 'catch next \
Else
gSkip = True
End If
Case "q"
If ((mID(strRTF, l, 3) = "qc\") Or (mID(strRTF, l, 3) = "qc ")) Then
'qc = centered
strAlign = "center"
'move "cursor" position to next rtf code
If (mID(strRTF, l + 2, 1) = " ") Then l = l + 2
l = l + 1
ElseIf ((mID(strRTF, l, 3) = "qr\") Or (mID(strRTF, l, 3) = "qr ")) Then
'qr = right justified
strAlign = "right"
'move "cursor" position to next rtf code
If (mID(strRTF, l + 2, 1) = " ") Then l = l + 2
l = l + 1
Else
gSkip = True
End If
Case "r"
If (mID(strRTF, l, 7) = "rquote ") Then
'reverse quote
strTmp = "’"
l = l + 6
gText = True
ElseIf (mID(strRTF, l, 10) = "rdblquote ") Then
'reverse doublequote
strTmp = "”"
l = l + 9
gText = True
Else
gSkip = True
End If
Case "s"
'strikethrough
If ((mID(strRTF, l, 7) = "strike\") Or (mID(strRTF, l, 7) = "strike ")) Then
strCurLine = strCurLine & "<STRIKE>"
strEOS = "</STRIKE>" & strEOS
l = l + 6
Else
gSkip = True
End If
Case "t"
If (mID(strRTF, l, 4) = "tab ") Then
strTmp = "	" 'tab
l = l + 2
gText = True
Else
gSkip = True
End If
Case "u"
'underline
If ((mID(strRTF, l, 3) = "ul ") Or (mID(strRTF, l, 3) = "ul\")) Then
strCurLine = strCurLine & "<U>"
strEOS = "</U>" & strEOS
l = l + 1
Else
gSkip = True
End If
Case "'"
'special characters
strTmp2 = "{" & mID(strRTF, l + 1, 2) & "}"
lTmp = InStr(strCodes, strTmp2)
If lTmp = 0 Then
strTmp = Chr("&H" & mID(strTmp2, 2, 2))
Else
strTmp = Trim(mID(strCodes, lTmp - 8, 8))
End If
l = l + 1
gText = True
Case "~"
strTmp = " "
gText = True
Case "{", "}", "\"
gText = True
Case vbLf, vbCr, vbCrLf 'always use vbCrLf
strCurLine = strCurLine & vbCrLf
Case Else
gSkip = True
End Select
If gSkip = True Then
'skip everything up until the next space or "\" or "}"
While InStr(" \}", mID(strRTF, l, 1)) = 0
l = l + 1
Wend
gSkip = False
If (mID(strRTF, l, 1) = "\") Then l = l - 1
End If
l = l + 1
Case vbLf, vbCr, vbCrLf
l = l + 1
Case Else
gText = True
End Select
If gText Then
If ((Len(strFontColor & strFontFace) > 0) And gSeekingText) Then
If Len(strAlign) > 0 Then
gAlign = True
If strAlign = "center" Then
strCurLine = strCurLine & "<TABLE ALIGN=""left"" CELLSPACING=0 CELLPADDING=0 WIDTH=""100%""><TR ALIGN=""center""><TD>"
ElseIf strAlign = "right" Then
strCurLine = strCurLine & "<TABLE ALIGN=""left"" CELLSPACING=0 CELLPADDING=0 WIDTH=""100%""><TR ALIGN=""right""><TD>"
End If
strAlign = ""
End If
If Len(strFontFace) > 0 Then
strFontCodes = strFontCodes & " FACE=" & strFontFace
End If
If Len(strFontColor) > 0 Then
strFontCodes = strFontCodes & " COLOR=" & strFontColor
End If
If Len(strCurFontSize) > 0 Then
strFontCodes = strFontCodes & " SIZE = " & lFontSize
End If
strCurLine = strCurLine & "<FONT" & strFontCodes & ">"
strFontCodes = ""
End If
strCurLine = strCurLine & strTmp
l = l + 1
gSeekingText = False
gText = False
End If
Wend
lBOS = lEOS + 2
lEOS = InStr(lEOS + 1, strRTF, vbCrLf & "\par")
strHTML = strHTML & strEOLL & strBOS & strBOL & strCurLine & vbCrLf
strEOLL = strEOL
If Len(strEOL) = 0 Then strEOL = "<BR>"
If lEOS = 0 Then GoTo finally
strBOS = ""
strCurLine = ""
Wend
finally:
strHTML = strHTML & strEOS
'clear up any hanging fonts
If (Len(strFontColor & strFontFace) > 0) Then strHTML = strHTML & "</FONT>" & vbCrLf
'Add Generator Metatag if requested
If InStr(strOptions, "+G") <> 0 Then
strGen = "<META NAME=""GENERATOR"" CONTENT=""RTF2HTML by Brady Hegberg"">"
Else
strGen = ""
End If
'Add Title if requested
If InStr(strOptions, "+T") <> 0 Then
lTmp = InStr(strOptions, "+T") + 3
lTmp2 = InStr(lTmp + 1, strOptions, """")
strTitle = mID(strOptions, lTmp, lTmp2 - lTmp)
Else
strTitle = ""
End If
'add header and footer if requested
If InStr(strOptions, "+H") <> 0 Then strHTML = strHeader & vbCrLf _
& strHTML _
& strFooter
RTF2HTML = strHTML
End Function
Salu2
Título: Re: Modulo RTF to HTML
Publicado por: _Sergi_ en 26 Mayo 2006, 04:14 am
Gracias por estos tus regalos xD
¿Crees que se podría modificar para usarlos con los codigos BBC de los foros? En teoría si, pero parece mucho trabajo....... Así se podría crear un programa para hacer post de manera visual. Ideal para post largos o que requieran una estructura o formateo complejo.
Un saludo!
Título: Re: Modulo RTF to HTML
Publicado por: Krnl64 en 26 Mayo 2006, 04:29 am
Llevas toda la razon.
Es laborioso, pero quizá merezca la pena.
Cosa de codear cada dia 1 poquito.
Salu2
|