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