AW: Mail aus Excel mit mehreren Empfängern
13.09.2022 14:44:04
Rudi
Hallo,
Sub StartMail()
Dim vntArr, vntGrp
Dim objGrpTO As Object, objGrpCC As Object, objTO As Object
Dim strGrpTO As String, strGrpCC As String, strTo As String
Dim i As Integer, j As Integer
Set objGrpCC = CreateObject("scripting.dictionary")
Set objGrpTO = CreateObject("scripting.dictionary")
Set objTO = CreateObject("scripting.dictionary")
vntArr = Cells(1, 1).CurrentRegion
vntGrp = Cells(1, 6).CurrentRegion
'Gruppen
For i = 2 To UBound(vntGrp)
If vntGrp(i, 2) = "x" Then objGrpTO(vntGrp(i, 1)) = 0
If vntGrp(i, 3) = "x" Then objGrpCC(vntGrp(i, 1)) = 0
Next i
'Empfänger Individualversand
For i = 2 To UBound(vntArr)
If vntArr(i, 4) = "x" Then
objTO(vntArr(i, 3)) = 0
strTo = strTo & ";" & vntArr(i, 3)
End If
Next i
For i = 2 To UBound(vntArr)
If Not objTO.exists(vntArr(i, 3)) Then
If objGrpTO.exists(vntArr(i, 1)) Then
strGrpTO = strGrpTO & ";" & vntArr(i, 3)
End If
If objGrpCC.exists(vntArr(i, 1)) Then
strGrpCC = strGrpCC & ";" & vntArr(i, 3)
End If
End If
Next i
strTo = Mid(strTo, 2)
strGrpTO = Mid(strGrpTO, 2)
strGrpCC = Mid(strGrpCC, 2)
If Len(strTo) Then Call SendMail(strTo, "", "", "Testmail", "Testtext", "")
If Len(strGrpTO) Or Len(strGrpCC) Then Call SendMail(strGrpTO, strGrpCC, "", "Testmail", "Testtext", "")
Set objTO = Nothing
Set objGrpTO = Nothing
Set objGrpCC = Nothing
End Sub
Sub SendMail(strTo As String, strCC As String, strBCC As String, _
strSubject As String, strText As String, strATT As String)
'strTo, strCC, strBCC: mehrere Adressen müssen mit ; getrennt übergeben werden
'strATT: mehrere Anhänge müssen mit ; getrennt übergeben werden
Dim MyMessage As Object, MyOutApp As Object, i As Integer
If Len(strTo & strCC & strBCC) Then
'Outlook Object erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Outlook Nachricht erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Empfänger
.To = strTo
'Kopie
.CC = strCC
'Blindkopie
.BCC = strBCC
'Betreff
.Subject = strSubject
'Anhang
For i = 0 To UBound(Split(strATT, ";"))
.Attachments.Add Trim(Split(strATT, ";")(i))
Next
'Hier wird ein normaler Text erstellt
.Body = strText
'Hier wird eine HTML Mail erstellt
'Dies kann zu Problemen führen, wenn der Empfänger nur TEXT Dateien empfangen darf.
'.HTMLBody = "Das ist ein Test.
Bitte ignorieren."
'Hier wird die Mail nochmals angezeigt
' .Display
'Hier wird die Mail gleich in den Postausgang gelegt und gesendet
.Send
End With
End If
'Outlook schliessen
'MyOutApp.Quit
'Variablen leeren
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
Gruß
Rudi