#

Download:

Datei 1: Demo_49_Excel_Serien_Emails_mit_X_Anhaengen_HTML.xlsm

 

 

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 >--------

 

Mobile

.