Wie können mit VBA Mails mit mehreren Dateianhängen an mehrere Empfänger gesendet werden?
Die Aufgabenstellung, per Mausklick oder automatisiert Mails zu versenden, ist sehr weit verbreitet. Es gibt auch viele Tipps, wie das mit Outlook erfolgen kann. Jedoch gibt es immer wieder Probleme, sei es durch Rechtebeschränkungen, wegzuklickende Meldungen von Outlook usw.
Am sinnvollsten ist deshalb eine Lösung, mit der man weitestgehend unabhängig von Officeprogrammen ist. Hier besteht die Möglichkeit, VBA nur zum Versand der Maildaten an einen Server zu benötigen, der dann den Rest des Erstellens und Versands der Mail übernimmt.
Voraussetzung für dieses Beispiel ist, dass auf dem Server ein eigenes PHP-Script erstellt werden kann, das dann natürlich auch eine Adresse (URL) hat.
Basis ist der Beitrag Dateiupload. Der VBA-Code dazu wurde hier um die Möglichkeit, Text zu versenden, erweitert. Prinzipiell trifft hier aber das Gleiche zu - vor allem, dass die oben verwendeten Konstanten auch dynamisch verwendet werden können. Hier wird nur das Prinzip aufgezeigt, die Anpassungen müssen dann entsprechend der eigenen Gegebenheiten erfolgen. Dies betrifft insbesondere auch die Sicherheit. Denken Sie daran, die manuell zu ändernden Daten vorher zu prüfen. Diese Scripte sind auch leicht zum Versand von Massenspam zu verwenden.
Dies ist der VBA-Code, der um die Text-Funktion erweitert wurde:
Private Const strURL As String = "https://â?¦Ihre URLâ?¦/â?¦Ihre PHP-Dateiâ?¦.php"
Private Const strDatei1 As String = "C:\â?¦\test1.jpg"
Private Const strDatei2 As String = "C:\â?¦\test2.jpg"
Private Const strDatei3 As String = "C:\â?¦\test3.jpg"
Private Const strMailEmpfaenger As String = "info1@example.org;info2@example.org;info3@example.org"
Private Const strAbsText As String = "Max Mütze"
Private Const strAbsMail As String = "xyz@example.org"
Private Const strBoundary As String = "---------------------------7da24f2e50046"
Sub DateiUploadUndMail()
Dim strPostDaten As String
strPostDaten = ""
strPostDaten = strPostDaten & Header_Text("empfaenger", strMailEmpfaenger, "text/plain", strBoundary)
strPostDaten = strPostDaten & Header_Text("abstext", strAbsText, "text/plain", strBoundary)
strPostDaten = strPostDaten & Header_Text("absmail", strAbsMail, "text/plain", strBoundary)
strPostDaten = strPostDaten & Header_Text("betreff", "Das ist der Betreff.", "text/plain", strBoundary)
strPostDaten = strPostDaten & Header_Text("mailtext", "Hallo!" & vbNewLine & vbNewLine & "Ich bin der Mailtext.", "text/html", strBoundary)
strPostDaten = strPostDaten & Header_Datei(strDatei1, strBoundary)
strPostDaten = strPostDaten & Header_Datei(strDatei2, strBoundary)
strPostDaten = strPostDaten & Header_Datei(strDatei3, strBoundary)
strPostDaten = strPostDaten & "--" & strBoundary & "--"
With CreateObject("Microsoft.XMLHTTP")
.Open "POST", strURL, False
.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & strBoundary
.Send SendDaten(strPostDaten)
MsgBox .ResponseText
End With
End Sub
Function Header_Text(strKey As String, strValue As String, strMime As String, strBoundary)
Header_Text = "--" & strBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""" & strKey & """;" & vbCrLf & _
"Content-Type: " & strMime & "; charset=UTF-8" & vbCrLf & vbCrLf & strValue & vbCrLf
End Function
Function Header_Datei(strDateiPfad As String, strBoundary As String)
Dim strDateiKonv As String, strDateiName As String
Header_Datei = ""
If strDateiPfad <> "" Then
strDateiName = DateiName(strDateiPfad)
strDateiKonv = DateiKonv(strDateiPfad)
Header_Datei = "--" & strBoundary & vbCrLf & _
"Content-Disposition: form-data; name=""file[]""; filename=""" & strDateiName & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & strDateiKonv & vbCrLf
End If
End Function
Function DateiName(strpfad As String)
DateiName = ""
If strpfad <> "" Then DateiName = Mid$(strpfad, InStrRev(strpfad, "\") + 1)
End Function
Function DateiKonv(strpfad As String)
Dim lngDNr As LongPtr, bytBuffer() As Byte
DateiKonv = ""
lngDNr = FreeFile
Open strpfad For Binary Access Read As lngDNr
If LOF(lngDNr) > 0 Then
ReDim bytBuffer(0 To LOF(lngDNr) - 1) As Byte
Get lngDNr, , bytBuffer
DateiKonv = StrConv(bytBuffer, vbUnicode)
End If
Close lngDNr
End Function
Private Function SendDaten(strText As String) As Byte()
SendDaten = StrConv(strText, vbFromUnicode)
End Function
Damit werden die Daten an das PHP-Script gesendet, das diese empfängt und daraus die Mails erstellt sowie diese versendet. Auch hier unbedingt daran denken, die Daten noch auf Gültigkeit zu prüfen!
Das komplette PHP-Script:
/*
Wichtig:
Da das Script prinzipiell auch zu Versand von Massenspam geeignet ist,
sollten ganz am Anfang noch Kennwort und Nutzername (oder eine andere Absicherung)
abgefragt werden. Diese Angaben können von VBA aus ganz einfach als POST-Paare
mitgeschickt werden.
*/
// Verzeichnis, in dem die Anhänge zwischengespeichert werden:
$anhangverz = 'uploadtest/';
// Vorsicht: Ggf. prüfen, ob vorhanden und leer.
// Mailadressen durch Semikolon getrennt
$empfstrings = $_POST['empfaenger'];
// Text, der als Absender erscheint:
$abstext = $_POST['abstext'];
// Mailadresse des Absenders:
$absmail = $_POST['absmail'];
$betreff = utf8_encode($_POST['betreff']);
$mailtext = utf8_encode($_POST['mailtext']);
// File[]-Array sinnvoll sortieren:
$dateiarray = array();
foreach($_FILES['file'] as $k1 => $v1) {
foreach($v1 as $k2 => $v2) {
$dateiarray[$k2][$k1] = $v2;
}
}
// Anhänge speichern, Daten für Versand aufbereiten
$anhangarray = array(); $a = 0;
foreach ($dateiarray as $file) {
// Ggf. prüfen, ob Dateiname schon im Verzeichnis vorhanden ist und
// ggf. umbenennen:
$datname = basename($file['name']);
$uploadpfad = $anhangverz . $datname;
if (move_uploaded_file($file['tmp_name'], $uploadpfad)) {
$a++;
$anhangarray[$a]['pfad'] = $uploadpfad;
$anhangarray[$a]['dateiname'] = $datname;
$anhangarray[$a]['groesse'] = filesize($uploadpfad);
$dateiinhalt = fread(fopen($uploadpfad, "r"), filesize($uploadpfad));
$anhangarray[$a]['data'] = chunk_split(base64_encode($dateiinhalt));
}
}
$empf_array = explode(";",$empfstrings);
$encoding = mb_detect_encoding($mailtext, "utf-8, iso-8859-1, cp-1252");
$mime_boundary = "-----=" . md5(uniqid(microtime(), true));
$versendet = 0;
// Mail an jeden Empfänger schicken:
foreach($empf_array as $einzelmail) {
if (trim($einzelmail) != "") {
$header ="From:" . $abstext . "<" . $absmail . ">\n";
$header.= "MIME-Version: 1.0\r\n";
$header.= "Content-Type: multipart/mixed;\r\n";
$header.= " boundary=\"" . $mime_boundary . "\"\r\n";
$content = "This is a multi-part message in MIME format.\r\n\r\n";
$content.= "--".$mime_boundary."\r\n";
$content.= "Content-Type: text/plain; charset=\"$encoding\"\r\n";
$content.= "Content-Transfer-Encoding: 8bit\r\n\r\n";
$content.= $mailtext . "\r\n";
if ($a > 0) { // Ggf. Mailanhänge anfügen
for ( $n = 1; $n <= $a; $n++) {
$content.= "--" . $mime_boundary . "\r\n";
$content.= "Content-Disposition: attachment;\r\n";
$content.= "\tfilename=\"" . $anhangarray[$n]['dateiname'] . "\";\r\n";
$content.= "Content-Length: " . $anhangarray[$n]['groesse'] . ";\r\n";
$content.= "Content-Type: application/pdf; name=\"" . $anhangarray[$n]['dateiname'] . "\"\r\n";
$content.= "Content-Transfer-Encoding: base64\r\n\r\n";
$content.= $anhangarray[$n]['data'] . "\r\n";
}
}
$content .= "--" . $mime_boundary . "--";
if (mail($einzelmail, $betreff, $content, $header)) { $versendet++; }
}
}
// Ggf. Mailanhänge löschen
if ($a > 0) {
for ( $n = 1; $n <= $a; $n++) {
if ($anhangarray[$n]['pfad'] != "") {unlink($anhangarray[$n]['pfad']);}
}
}
// Meldung, die in VBA in der MsgBox als .ResponseText erscheint:
echo $versendet . " Mail(s) erfolgreich gesendet.";
Suchergebnisse (7 Treffer, 1 Begriff) 
Kategorien: 
Chat
