Excel VBA - E-Mail mit Grafik versenden
14.02.2017 13:59:15
Schmecks
ich brauche mal wieder Eure Hilfe. Ich möchte aus Excel eine E-Mail mit bestimmten Inhalten aus bestimmten Zellen senden. Es handelt sich hierbei um eine Login-Anleitung mit jeweils auf den Adressaten zugeschnittenen Logindaten und Passwörtern (variabler Teil). Das klappt soweit ganz gut. Nun möchte ich auch noch eine Anleitung zur Passwortänderung nach der Erstanmeldung hinzufügen (immer gleicher Teil der E-mail). Dazu habe ich bereits die E-Mail als HTML-Body definiert und das wird auch so umgesetzt.
Die Logindaten stehen in den Spalten E & F des Tabellenblattes.
Ich habe den Code direkt in das Tabellenblatt eingefügt in dem die Informationen entnommen werden.
Option Explicit
Private Sub CommandButton21_Click()
Dim olApp As Object, olMailItm As Object, i, lz, k As Integer, Pfad As String
Pfad = "C:\Data\" 'Hier Pfad anpassen
lz = Cells(Rows.Count, 1).End(xlUp).Row
i = 2
weiter:
Do Until i > lz
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Cells(i, 1).Select
If ActiveCell.Value "" Then
With olMailItm
.To = Cells(i, 1).Value
.Subject = Cells(i, 2).Value
.BodyFormat = 2 'olFormatHTML (HTML -Mail-Format)
.HTMLBody = "Text" 'HTML -Mail
.Body = _
"Hallo " & Cells(i, 3).Value & "," & _
Chr(13) & _
Chr(13) & _
"Ihre Zugangsdaten für " & Chr(34) & "Projekt X " & Chr(34) & "lauten :" & _
Chr(13) & _
Chr(13) & _
"Login" & vbTab & ": " & vbTab & Cells(i, 5).Value & _
Chr(13) & _
"Passwort " & ":" & vbTab & Cells(i, 6).Value & _
Chr(13) & _
"(dieses ist wie unter Punkt 4. beschrieben nach der Erstanmeldung zu ändern.)" & _
Chr(13) & _
Chr(13) & _
"Mit freundlichen Grüßen" & _
Chr(13) & _
'Chr(13)
.OriginatorDeliveryReportRequested = True 'Übermittlungsbestätigung anfordern ( _
Nachverfolgungsoption)
.ReadReceiptRequested = True ' Lesebestätigung anforndern
If Dir(Pfad & Cells(i, 4).Value) "" Then 'Abfrage ob Anhang vorhanden
.Attachments.Add Pfad & Cells(i, 4).Value
End If
.Display 'alternativ ".Send" für direktes Versenden
.Sensitivity = 3 ' Vertraulichkeit (0 = Normal, 1 = Persönlich, 2 = Privat, 3 = Vertraulich) _
_
_
.Importance = 2 ' Wichtigkeit (0 = Niedrig, 1 = Normal, 2 = Hoch)
End With
Else
MsgBox "Für das Dokument " & Cells(i, 1).Value & " ist kein Empfänger eingtragen"
End If
Set olMailItm = Nothing
Set olApp = Nothing
i = i + 1
Loop
If i > lz Then
End
End If
End Sub
mfg der Schmecks