AW: Excel-Text in HTML umwandeln
20.01.2022 14:44:08
volti
Hallo Basti,
wenn Du HTML-Text zur Schriftart und Hintergrund zu einer Excel benötigst, kannst Du das u.a. Makro mal ausprobieren...
Wenn Du eine Zelle/einen Bereich oder ein Bild in eine Mail einfügen möchtest, findest Du nachfolgend ein Beispiel der über den WordEditor arbeitet.
Weitere Möglichkeit bietet RangeToHTML bzw. Range2HTML. Hierzu mal googlen oder hier noch mal ansprechen.
Oder Du stellst wie von Rudi schon angesprochen Deine Datei hier ein.
Code:
[Cc][+][-]
Sub Test()
Debug.Print GetHTML(Range("A1"))
End Sub
Function GetHTML(rZelle As Range, Optional bHG As Boolean) As String
' RTF in HTML umwandeln Version für <<<Excel-Zellen>>>
Dim sHTML As String, sText As String, iPos As Integer
Dim sFontName As String, sFontSize As String, sUnderline As String
Dim iColor As Long, iUnderline As Long, sBackground As String
Dim bItalic As Boolean, bBold As Boolean
If bHG Then ' Hintergrundfarbe
sBackground = " background-" _
& GetHexColor(rZelle.Interior.Color) & ";"
End If
For iPos = 1 To Len(rZelle.Value)
With rZelle.Characters(iPos, 1)
sText = Replace(.Text, vbLf, "<br>") ' Zeilenumbrüche einbauen
With .Font
If sFontName <> .Name Or sFontSize <> .Size _
Or iColor <> .Color Or bItalic <> .Italic _
Or iUnderline <> .Underline Or bBold <> .Bold Then
sFontName = .Name ' Schriftart
sFontSize = .Size: iColor = .Color ' Schriftgröße, -farbe
iUnderline = .Underline ' Unterstreichen
bItalic = .Italic: bBold = .Bold ' Kursiv und Fett
If sHTML Like "*<span*" Then
sHTML = sHTML & "</span>" ' Span-Abschluss
End If
sHTML = sHTML & "<span style='" _
& "font-family:" & sFontName & ";" _
& " font-size:" & sFontSize & "pt;" _
& " " & GetHexColor(iColor) & ";" _
& " font-weight: " & IIf(bBold, "bold;", "normal;") _
& " font-style: " & IIf(bItalic, "italic;", "normal;") _
& " text-decoration: " & IIf(iUnderline > 0, "underline;", "none;") _
& sBackground & "'>" ' Formatierung HTML
End If
End With
sHTML = sHTML & sText ' Text_anfügen
End With
Next iPos
GetHTML = sHTML & "</span>"
End Function
Private Function GetHexColor(oCol As Variant) As String
GetHexColor = "color:#" _
& Right("00" & Hex(oCol And vbRed), 2) _
& Right("00" & Hex((oCol And vbGreen) \ &H100), 2) _
& Right("00" & Hex((oCol And vbBlue) \ &H10000), 2)
End Function
' ###################################################
Private Sub Mail_BereichalsBereich_Word()
' Sendet Mail mit integriertem Bereich als Bereich mit Signatur
' Das Bild wird über das Kürzel ~ im Text platziert
Dim WSh1 As Worksheet, WSh2 As Worksheet
Dim sMailtext As String, sSignatur As String
Dim sBer As String
sBer = "B2:B5" ' Kopierbereich
Set WSh1 = ThisWorkbook.Sheets("Tabelle1") ' Blatt mit Maildaten
Set WSh2 = ThisWorkbook.Sheets("Tabelle2") ' Datenblatt
WSh2.Range(sBer).Copy ' Bereich kopieren
With CreateObject("Outlook.Application").CreateItem(0)
.BodyFormat = 2 ' 2=HTML-Format, 3=Richtext
.Subject = WSh1.Range("A2").Value ' Betreff
.To = WSh1.Range("A3").Value ' Empfänger
.CC = WSh1.Range("A4").Value ' Kopie
sMailtext = WSh1.Range("A5").Value & vbLf
.GetInspector ' Signatur holen
.htmlbody = Replace(sMailtext, vbLf, "<br>") & .htmlbody
.Display
With .GetInspector.WordEditor.Application.Selection
.Start = Len(sMailtext) + 1
.Paste ' Bereich in Mail einfügen
End With
End With
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz