AW: Sammelemail / Serienemail
20.05.2019 12:01:32
peterk
Hallo
Sub Erinnerungsfunktion()
Dim lz As Long
Dim objDic As Object
Dim objDicEmail As Object
Dim i As Long
Dim k As Variant
If Worksheets("Zwischenablage").FilterMode Then Worksheets("Zwischenablage").ShowAllData 'Filter löschen
With Worksheets("Zwischenablage") 'Tabellenname anpassen
lz = .Range("A" & .Rows.Count).End(xlUp).Row 'letzte Zeile
'eindeutige Lieferanten holen
Set objDic = CreateObject(Class:="Scripting.Dictionary")
For i = 2 To lz
If Not objDic.Exists(Key:=.Cells(i, 4).Text) Then
objDic.Add Key:=.Cells(i, 4).Text, Item:=0
End If
Next i
End With
With Worksheets("Einstellung_Anrede") 'Tabellenname anpassen
lz = .Range("A" & .Rows.Count).End(xlUp).Row 'letzte Zeile
'eindeutige Lieferanten holen
Set objDicEmail = CreateObject(Class:="Scripting.Dictionary")
For i = 2 To lz
If Not objDicEmail.Exists(Key:=.Cells(i, 1).Text) Then
objDicEmail.Add Key:=.Cells(i, 1).Text, Item:=i
End If
Next i
End With
For Each k In objDic.keys
Worksheets("Zwischenablage").Range("A:H").AutoFilter Field:=4, Criteria1:=k
Send_Email objDicEmail(k)
Next k
Set objDic = Nothing
End Sub
Private Sub Send_Email(TextIdx As Long)
Dim objOL As Object
Dim objMail As Object
Dim sHtml As String
Dim StartText As String
Dim EndText As String
On Error Resume Next
Set objOL = GetObject(, "OUTLOOK.Application")
If objOL Is Nothing Then
Set objOL = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If Not objOL Is Nothing Then
Set objMail = objOL.CreateItem(0)
With objMail
' --- Signatur retten ---
.BodyFormat = 2 'olFormatHTML
.GetInspector
sHtml = .HtmlBody
' -----------------------
.To = Worksheets("Einstellung_Anrede").Cells(TextIdx, 2).Text
.Subject = "Betreff"
StartText = "<html> <head> <style> p { font-size: 22px; } </style> </head> <body> <p> " & _
Replace(Worksheets("Einstellung_Anrede").Cells(TextIdx, 3).Text, vbLf, "<br>") & _
"</p> </body> </html>"
EndText = "<html> <head> <style> p { font-size: 22px; } </style> </head> <body> <p> " & _
Replace(Worksheets("Einstellung_Anrede").Cells(TextIdx, 4).Text, vbLf, "<br>") & _
"</p> </body> </html>"
'Signatur dranhängen
.HtmlBody = StartText & _
RangetoHTML() & _
EndText & _
sHtml
.Display
End With
Else
MsgBox "Auf diesem PC/Notebook ist kein Outlook installiert!", _
vbMsgBoxSetForeground + 16, "zur Information..."
End If
Set objOL = Nothing
Set objMail = Nothing
End Sub
Function RangetoHTML() As String
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim PO As PublishObject
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
For Each PO In ActiveWorkbook.PublishObjects
PO.Delete
Next PO
Set PO = ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceAutoFilter, _
Filename:=TempFile, _
Sheet:="zwischenablage", _
HtmlType:=xlHtmlStatic, _
DivID:="Test")
PO.AutoRepublish = False
PO.Publish (True)
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set PO = Nothing
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0