AW: Outlook Mail aus EXCEL via VBA
29.06.2018 12:29:31
Rudi
Hallo,
teste mal:
Private Sub CommandButton1_Click()
Dim objTO As Object, objCC As Object
Dim lngCol As Long, rngC As Range
Dim strTo As String, strCC As String
Set objCC = CreateObject("scripting.dictionary")
Set objTO = CreateObject("scripting.dictionary")
lngCol = Application.Match(Range("A1"), Range("K1:W1"), 0) + 10
For Each rngC In Columns(lngCol).SpecialCells(xlCellTypeConstants)
Select Case UCase(rngC.Value)
Case "TO": objTO(rngC.Offset(, 3 - lngCol).Value) = 0
Case "CC": objCC(rngC.Offset(, 3 - lngCol).Value) = 0
End Select
Next
strTo = Join(objTO.keys, ";")
strCC = Join(objCC.keys, ";")
Call SendMail_Outlook(strTo, Range("A1"), "", strCC, "", "", True, False)
End Sub
Sub SendMail_Outlook _
(strTo As String, strSUBJECT As String, strTEXT As String, _
strCC As String, strBCC As String, strATT As String, _
bolSign As Boolean, bolSend As Boolean)
Dim MyMessage As Object, MyOutApp As Object, strSign As String
'Outlook Object erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Outlook Nachricht erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
If bolSign Then
'Signatur auslesen
.GetInspector.Display
strSign = .htmlbody
End If
'Empfänger
If Len(strTo) Then
.To = strTo
End If
'Kopie
If Len(strCC) Then
.CC = strCC
End If
'Blindkopie
If Len(strBCC) Then
.BCC = strBCC
End If
'Betreff
.Subject = strSUBJECT
'Anhang
If Len(strATT) Then
.Attachments.Add strATT
End If
If Len(strTEXT) Then
'normale Mail erstellen
'.Body = strTEXT
End If
'HTML Mail erstellen
'Dies kann zu Problemen führen, wenn der Empfänger
'nur TEXT Dateien empfangen darf.
If bolSign Then
'falls die Signatur angefügt werden soll
.htmlbody = strTEXT & "<p>" & strSign
Else
.htmlbody = strTEXT
End If
If bolSend Then
'direkt senden
.Send
Else
'erst anzeigen
.Display
End If
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
Gruß
Rudi