Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA Outlook Schrityp ändern/ kopieren
#1
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
Antwortento top
#2
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.
   \\\|///      Hoffe, geholfen zu haben.
   ( ô ô )      Grüße, André aus G in T  
 ooO-(_)-Ooo    (Excel 97-2016)
Antwortento top
#3
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
Antwortento top
#4
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 :(
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste