Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Public Function RTFtoHTML(ByVal RTFBox As RichTextBox) As String
Dim mRGB(2) As Byte
Const html_Break = "<BR>"
HTML$ = "<html>" & NL & "<body>" & NL
BullStyle$ = "{ margin-left: 15px; margin-bottom: 0px; margin-top: 0px; }"
curr_Align = -1
With RTFBox
txt$ = .Text
For A& = 0 To Len(txt$)
.SelStart = A&
If (A& <> 0) Then
If (Mid$(txt$, A&, 2) = "•" & vbTab) Then
HTML$ = HTML$ & "<UL class='bull'><LI>"
curr_Bullet = True
A& = A& + 1
GoTo s_Skip
End If
End If
If (curr_FontFace <> .SelFontName) Or (curr_FontSize <> .SelFontSize) Or (curr_ForeColour <> .SelColor) Then
CC& = .SelColor
CopyMemory mRGB(0), CC&, Len(CC&)
GC$ = Right$("0" & Hex$(mRGB(0)), 2) & Right$("0" & Hex$(mRGB(1)), 2) & Right$("0" & Hex$(mRGB(2)), 2)
HTML$ = HTML$ & IIf(A& = 0, "", "</span>") & "<span style='"
Lump$ = "{ font-family: " & .SelFontName & "; font-size: " & .SelFontSize & "pt; color: #" & GC$ & "; }"
If (A& = 0) Then MainStyle$ = Lump$
HTML$ = HTML$ & Lump$ & "'>"
curr_FontFace = .SelFontName
curr_FontSize = .SelFontSize
curr_ForeColour = .SelColor
End If
If (curr_Bold <> .SelBold) Then
HTML$ = HTML$ & IIf(.SelBold, "<B>", "</B>")
curr_Bold = .SelBold
End If
If (curr_Under <> .SelUnderline) Then
HTML$ = HTML$ & IIf(.SelUnderline, "<U>", "</U>")
curr_Under = .SelUnderline
End If
If (curr_Italic <> .SelItalic) Then
HTML$ = HTML$ & IIf(.SelItalic, "<I>", "</I>")
curr_Italic = .SelItalic
End If
If (curr_Align <> .SelAlignment) Then
HTML$ = HTML$ & IIf((A& <> 0) And (Ended = False), "</P>", "") & "<P style='{ margin-top: 0px; margin-bottom: 0px; }' Align='" & Choose(.SelAlignment + 1, "left", "right", "center") & "'>"
Ended = False
curr_Align = .SelAlignment
End If
If (A& <> 0) Then
If (Mid$(txt$, A&, 2) = vbCrLf) Then
If (curr_Bullet = True) Then
HTML$ = HTML$ & "</UL>"
Ended = True
curr_Bullet = False
Else
HTML$ = HTML$ & html_Break
End If
A& = A& + 1
ElseIf (Mid$(txt$, A&, 1) = "<") Then
HTML$ = HTML$ & "<"
ElseIf (Mid$(txt$, A&, 1) = ">") Then
HTML$ = HTML$ & ">"
Else
HTML$ = HTML$ & Mid$(txt$, A&, 1)
End If
End If
s_Skip:
Next A&
End With
HTML$ = Replace$(HTML$, html_Break & "</P>", "</P>")
HTML$ = Replace$(HTML$, "<span style='" & MainStyle$ & "'>", "<span class='core'>")
HTML$ = HTML$ & vbCrLf _
& "<style>" & vbCrLf _
& "span.core " & MainStyle$ & vbCrLf _
& "ul.bull " & BullStyle$ & vbCrLf _
& "</style>" & vbCrLf
RTFtoHTML = HTML$
End Function
Talk To Other Members