Clever-Excel-Forum

Hi Leute,

ich habe ein kleines VBA Script geschrieben, dass mir von meiner Excel- Datei automatisch bestimmte Zellen in eine E-Mail packt.

Ich möchte, dass hierzu noch die Schriftart ändern bzw. färben oder am besten einfach das was in den Excel Zellen steht ein-zu-eins kopieren/ übernehmen (also die Schriftart/Größe und Unterstriche)

Hier mein Code

Code:
Sub anwesenheit_senden()

Dim Mailadresse As String, Betreff As String

Dim olApp As Object

Set olApp = CreateObject("Outlook.Application")

Betreff = "Anwesenheit"

With olApp.CreateItem(0)

.to = "anonymus@hi.de"

.cc = "2me@hi.de"

.Subject = "Anwesenheit " & Sheets("Tabelle3").Range("B1").Value

.body = "Guten Tag zusammen," & Chr(13) & _

Chr(13) & _

Sheets("Tabelle3").Range("A3") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A4") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A6") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A7") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A8") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A10") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A11") & Chr(13) & Chr(13) & _

Sheets("Tabelle3").Range("A12") & Chr(13) & Chr(13) & _

""

.Display

End With

Set olApp = Nothing

End Sub

Hallöchen,

um Formate, Bilder usw. in eine E-Mail zu bekommen brauchst Du den htmlbody. Dann fügst Du z.B. Deine Daten als html-code ein mit den entsprechenden Formatierungs-Tags.

Hallo Chasi,

schau mal, ob Dich anliegender Code irgendwie weiterbringt....

Code:
Sub anwesenheit_senden()
 Dim WSh As Worksheet
 
 Set WSh = ThisWorkbook.Sheets("Tabelle3")
 With CreateObject("Outlook.Application").CreateItem(0)
   .BodyFormat = 2
   .To = "anonymus@hi.de"
   .cc = "2me@hi.de"
   .Subject = "Anwesenheit " & WSh.Range("B1").Value
   
   .Getinspector
   .htmlbody = "Guten Tag zusammen,<br><br>" & _
   GetHTML(WSh.Range("A3")) & "<br><br>" & _
   GetHTML(WSh.Range("A4")) & "<br><br>" & _
   GetHTML(WSh.Range("A6")) & "<br><br>" & _
   GetHTML(WSh.Range("A7")) & "<br><br>" & _
   GetHTML(WSh.Range("A8")) & "<br><br>" & _
   GetHTML(WSh.Range("A10")) & "<br><br>" & _
   GetHTML(WSh.Range("A11")) & "<br><br>" & _
   GetHTML(WSh.Range("A12")) & "<br><br>" & _
   .htmlbody
   .Display

 End With

End Sub

   
Function GetHTML(Obj As Range) As String
'RTF in HTML umwandeln
 Dim sHTML As String, sText As String, i As Integer
 Dim bCheck As Boolean, varChar, iColor As Long
 Dim sFontName As String, sFontSize As String, sUnderline As String
 Dim bItalic As Integer, bBold As Integer, iUnderline As Long
 
 iUnderline = -1
 For i = 1 To Len(Obj.Value)
   With Obj.Characters(i, 1)
    bCheck = False
       
    With .Font
'Schriftart
      If Not sFontName Like .Name Then bCheck = True:  sFontName = .Name
'Schriftgröße
      If Not sFontSize Like .Size Then bCheck = True:  sFontSize = .Size
'Schriftfarbe
      If iColor <> .Color Then bCheck = True: iColor = .Color
'Unterstreichen
      If iUnderline <> .Underline Then bCheck = True: iUnderline = .Underline
'Kursiv
      If Not bItalic Like .Italic Then bCheck = True:  bItalic = .Italic
'Fett
      If Not bBold Like .Bold Then bCheck = True:      bBold = .Bold
    End With
'Zeilenumbrüche einbauen
    sText = Replace(Replace(.Text, vbLf, "<br>"), vbCrLf, "<br>")
'Formatierung HTML
    If bCheck Then
       If sHTML Like "*<span*" Then sHTML = sHTML & "</span>"   'Span-Abschluss
       sHTML = sHTML & "<span style='" _
             & "font-family:" & sFontName & ";" _
             & " font-size:" & sFontSize & "pt;" _
             & " " & GetHexColor(iColor) & ";"
       sHTML = sHTML & " font-weight: " & IIf(bBold, "bold;", "normal;")
       sHTML = sHTML & " font-style: " & IIf(bItalic, "italic;", "normal;")
       sHTML = sHTML & " text-decoration: " & IIf(iUnderline > 0, "underline;", "none;")
       sHTML = sHTML & "'>"
    End If
'Text_anfuegen
    sHTML = sHTML & sText
   
   End With
 Next i
 
 sHTML = sHTML & "</span>"
 GetHTML = sHTML
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

____________________
viele Grüße aus Freigericht
Karl-Heinz

Code:
If bCheck Then

       If sHTML Like "*<span*" Then sHTML = sHTML & "</span>"   'Span-Abschluss

       sHTML = sHTML & "<span style='" _

             & "font-family:" & sFontName & ";" _

             & "font-size:" & sFontSize & "pt;" _

             & " " & GetHexColor(iColor) & ";"

       sHTML = sHTML & " font-weight: " & IIf(bBold, "bold;", "normal;")

       sHTML = sHTML & " font-style: " & IIf(bItalic, "italic;", "normal;")

       sHTML = sHTML & " text-decoration: " & IIf(iUnderline > 0, "underline;", "none;")

       sHTML = sHTML & "'>"

    End If

Vielen Dank für deine Antwort. Leider gibt der mir bei der Einzelschritt Begehung eine Fehlermeldung bei diesem Teil. Ich bin ganz ehrlich. Ich verstehe den Part auch nicht wirklich. Daher bin ich echt aufgeschmissen grade :(

Leider auch etwas spät,

aber mal zur Info: Der Code läuft bei mir einwandfrei.

Und ohne genaue Fehlerbeschreibung oder hochgeladener Mappe für einen Test kann Dir auch nicht geholfen werden.
Aber vielleicht ist es ja zwischenzeitlich zum Laufen gebracht worden.

viele Grüße
Karl-Heinz

CHASiN1994

schauan

volti

CHASiN1994

volti