Excel vba: RTF in HTML umwandeln
Dieser vba Code wandelt RTF formatierten Text aus einem Excel Text-Feld in HTML für eine HTML formatierte EMail um
Die Ausgabe erscheint wie hier unten gezeigt in der Email als HTML formatiert.
Vba Code
'------< RTF in HTML umwandeln >-------- Dim sHTML As String 'sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text 'Dim iLenHTML As Long 'iLenHTML = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Characters.Length sHTML = "" Dim bChange As Boolean
Dim intColor As Long intColor = 0 Dim intRed As Long, intGreen As Long, intBlue As Long
Dim sFontName As String sFontName = "" Dim sFontSize As String sFontSize = "" Dim sUnderline As String sUnderline = ""
Dim bBold As Integer bBold = 0
'------< @Loop: Characters >------ Dim varChar For Each varChar In Sheets("_Text").Shapes("TextBox 3").TextFrame2.TextRange.Characters '----< Character >---- bChange = False
'< get Character > Dim char_Text As String char_Text = varChar.Text
Dim char_FontName As String char_FontName = varChar.Font.Name
Dim char_FontSize As String char_FontSize = varChar.Font.Size
Dim char_Underline As String char_Underline = varChar.Font.UnderlineStyle
Dim char_RGB As Long char_RGB = varChar.Font.Fill.ForeColor.RGB
Dim char_Bold As Integer char_Bold = varChar.Font.Bold '</ get Character >
'< Font > If Not sFontName Like char_FontName Then bChange = True sFontName = char_FontName End If '</ Font >
'< FontSize > If Not sFontSize Like char_FontSize Then bChange = True sFontSize = char_FontSize End If '</ FontSize >
'< Underline > If Not sUnderline Like char_Underline Then bChange = True sUnderline = char_Underline End If '</ Underline >
'< Color > If Not intColor Like char_RGB Then bChange = True intColor = char_RGB intRed = (intColor And &HFF) \ 256 ^ 0 ' &HFF hexadecimal = 255 decimal intGreen = (intColor And &HFF00&) \ 256 ^ 1 ' &HFF00& hexadecimal = 65280 decimal intBlue = intColor \ 256 ^ 2 End If '</ Color >
'< Bold > If Not bBold Like char_Bold Then bChange = True bBold = char_Bold End If '</ Bold >
'< Korrekturen > char_Text = Replace(char_Text, vbCrLf, "<br>") char_Text = Replace(char_Text, vbLf, "<br>")
'</ Korrekturen >
'< Formatierung HTML > If bChange Then sHTML = sHTML & "</span>" sHTML = sHTML & vbCrLf & "<span style=""" sHTML = sHTML & " font-family:" & sFontName & ";" sHTML = sHTML & " font-size:" & sFontSize & "pt;" If Not sUnderline Like "0" Then sHTML = sHTML & " text-decoration:underline;" End If sHTML = sHTML & " color:rgb(" & intRed & "," & intGreen & "," & intBlue & ") ;" If bBold <> 0 Then sHTML = sHTML & " font-weight:font-weight: bold;" Else sHTML = sHTML & " font-weight:font-weight: normal;" End If sHTML = sHTML & """>" End If '</ Formatierung HTML >
'< Text_anfuegen > sHTML = sHTML & char_Text '</ Text_anfuegen > '----</ Character >---- Next '------</ @Loop: Characters >------ '< Korrektur > sHTML = sHTML & "</span>" '</ Korrektur >
'sTemplate = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Characters.Text '(1, iLenHTML) 'sTemplate = Sheets("_Text").Shapes(1).TextFrame.Text 'sHTML = "<html><body>" & vbCrLf & sHTML & vbCrLf & "</body></htmll>" '</ Text > '------</ RTF in HTML umwandeln >-------- |