Sub Serienbrief_Mailing()
Dim iBrief As Integer, sBrief As String
Dim AppShell As Object
Dim BrowseDir As Variant
Dim Path As String
Dim objOLOutlook As Object
Dim objOLMail As Object
Dim lngMailNr As Long
Dim lngZaehler As Long
Dim strAttachmentPfad1 As String
Dim strSignature As String
Dim Pfad1 As String
On Error GoTo ErrorHandling
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Speicherort für Serienbriefe auswählen", 0, 16)
If BrowseDir = "Desktop" Then
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Else
Path = BrowseDir.items().Item().Path
End If
If Path = "" Then GoTo ErrorHandling
Path = Path & "\ "
On Error GoTo ErrorHandling
MsgBox "Serienbriefe werden exportiert. Dieser Vorgang kann einige Minuten dauern - Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation
Application.Visible = False
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
sBrief = Path & .DataFields("Anreisedatum").Value & "_" & .DataFields("Anreisende_Gäste").Value & ".pdf"
End With
.Execute Pause:=False
If .DataSource.DataFields("Anreisende_Gäste").Value > "" Then
ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatPDF
End If
ActiveDocument.Close False
Set objOLOutlook = CreateObject("Outlook.Application")
strAttachmentPfad1 = "C:\Users\Kaiser\Desktop\Serienbriefe\Brief\05.12.22_Herr Biyan Abdo.pdf"
Set objOLMail = objOLOutlook.CreateItem(olMailItem)
With objOLMail
.BodyFormat = olFormatHTML
.Display
End With
strSignature = objOLMail.HTMLBody
With objOLMail
.To = "kaiser.webphone@googlemail.com"
.CC = ""
.BCC = ""
.Subject = "Neue Mail"
.BodyFormat = olFormatHTML
.HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">" & _
"Sehr geehrte Damen und Herren,<br><br>" & _
"in der Anlage senden wir Ihnen die Anreiseerinnerung für Ihre:n Auszubildende:n. <br>" & _
"Für Rückfragen stehen wir gern zur Verfügung.</font>" & _
strSignature
.Attachments.Add strAttachmentPfad1
.Send
End With
Set objOLMail = Nothing
Set objOLOutlook = Nothing
If .DataSource.ActiveRecord < .DataSource.RecordCount Then
.DataSource.ActiveRecord = wdNextRecord
Else
Exit Do
End If
Loop
End With
ErrorHandling:
Application.Visible = True
If Err.Number = 76 Then
MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 5852 Then
MsgBox "Das Dokument ist kein Serienbrief"
ElseIf Err.Number = 4198 Then
MsgBox "Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 91 Then
MsgBox "Exportieren von Serienbriefen abgebrochen", vbOKOnly + vbExclamation
ElseIf Err.Number > 0 Then
MsgBox "Unbekannter Fehler: " & Err.Number & " - Bitte Makro erneut ausführen.", vbOKOnly + vbCritical
Else
MsgBox "Serienbriefe erfolgreich exportiert", vbOKOnly + vbInformation
End If
End Sub