Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Excel vba: RTF in HTML umwandeln

27.02.2020 (👁911)

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