Serienbrief mit Macro PDF Erstellen und Per Mail Versenden

Moderator: ModerationP

Serienbrief mit Macro PDF Erstellen und Per Mail Versenden

Beitragvon Feuerwehrmann » 19. Jul 2019, 21:56

Ich Begrüsse euch recht herzlich und hätte da auch gleich mal eine frage.

Ich arbeite derzeit an ein Projekt für Eine Freiwillige Feuerwehr. Die hätte gerne einen Serienbrief erstellt mit Daten Quelle aus eine Excel Tabelle, möchte diese dann einzeln als PDF abspeichern und dann an unterschiedliche Mail-Adressen (welche in der Excel Tabelle enthalten sind) senden.

Ich konnte bisher folgender erfolge verzeichnen: den Serienbrief einzeln als PDF speichern mit einem Individuellen Namen doch leider scheitere ich an der Möglichkeit die erzeugten PDF Dateien per Mail an die in der Excel vorhanden Adressen Zu Senden.

Vorhanden ist Office 2019 mit Word,Excel,Access und Outlook

mein derzeitiger Code Schaut so aus

Code: Alles auswählen
Sub Serienbrief_im_PDF_Format_speichern()
    ' set variables
    Dim iBrief As Integer, sBrief As String
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Dim Path As String
   
    ' catch any errors
    On Error GoTo ErrorHandling
   
    ' determine path
    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 & "\Serienbrief-" & Format(Now, "dd.mm.yyyy-hh.mm.ss") & "\"
    MkDir Path
   
    On Error GoTo ErrorHandling
       
    ' hide application for better performance
    MsgBox "Serienbriefe werden exportiert. Dieser Vorganag kann einige Minuten dauern - Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation
    Application.Visible = False
 
    ' create bulkletter and export as pdf
    With ActiveDocument.MailMerge
        .DataSource.ActiveRecord = 1
        Do
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = .ActiveRecord
                .LastRecord = .ActiveRecord
                sBrief = Path & .DataFields("ID").Value & ".pdf"
            End With
            .Execute Pause:=False
       
            If .DataSource.DataFields("ID").Value > "" Then
                ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatPDF
            End If
            ActiveDocument.Close False
       
            If .DataSource.ActiveRecord < .DataSource.RecordCount Then
                .DataSource.ActiveRecord = wdNextRecord
            Else
                Exit Do
            End If
        Loop
    End With
   
    ' error handling
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


ich versuche das ganze über Word VBA einzubauen

Ich hoffe Ihr könnt mir helfen.
Feuerwehrmann
 

Re: Serienbrief mit Macro PDF Erstellen und Per Mail Versend

Beitragvon Feuerwehrmann » 19. Jul 2019, 22:02

Sorry hab da einen unvollständigen Code eingefügt hier ist der richtige

Code: Alles auswählen
Sub SendReport()

'Der Mail-Teil wurde auf http://www.ms-office-forum.net/forum/sitemap/index.php?t-99591.html gefunden und angepasst



'Save Report
    Dim iBrief As Integer, sBrief As String
    Dim AppShell As Object
    Dim BrowseDir As Variant
    Dim Path As String
   
    ' catch any errors
    On Error GoTo ErrorHandling
   
    ' determine path
    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 & "\Serienbrief-" & Format(Now, "dd.mm.yyyy-hh.mm.ss") & "\"
    MkDir Path
   
    On Error GoTo ErrorHandling
       
    ' hide application for better performance
    MsgBox "Serienbriefe werden exportiert. Dieser Vorganag kann einige Minuten dauern - Microsoft Word wird während dieser Zeit ausgeblendet", vbOKOnly + vbInformation
    Application.Visible = False
 
    ' create bulkletter and export as pdf
    With ActiveDocument.MailMerge
        .DataSource.ActiveRecord = 1
        Do
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = .ActiveRecord
                .LastRecord = .ActiveRecord
                sBrief = Path & .DataFields("ID").Value & ".pdf"
            End With
            .Execute Pause:=False
       
            If .DataSource.DataFields("ID").Value > "" Then
                ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatPDF
            End If
            ActiveDocument.Close False
       
            If .DataSource.ActiveRecord < .DataSource.RecordCount Then
                .DataSource.ActiveRecord = wdNextRecord
            Else
                Exit Do
            End If
        Loop
    End With
   
    ' error handling
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
    'Set Variables
    Dim mail As Object
    Set mail = CreateObject("Outlook.Application").CreateItem(0)
    TS = Year(Date$) & Left(Date$, 2) & Mid(Date$, 4, 2) & "_" & Mid(Now, 12, 2) & "30"
    RepName = "C:\Reporting\Daily Status " & TS
    RepPDF = RepName & ".pdf"
   

    mail.Subject = "Daily Status " & TS
    mail.To = "DailyStatus"
    'mail.cc = "reporting@reporting.com"
    'mail.bcc = "reporting@reporting.com"
    mail.body = "Hallo Kollegen, " & Chr(13) & Chr(13) & _
        "anbei der aktuelle Report." & Chr(13) & Chr(13) & _
        "Mit freundlichen Grüßen / Kind regards" & Chr(13) & " " & Chr(13) & Chr(13)
   

    'mail.Display    'Mail anzeigen
    mail.Display  'Mail direkt senden


End Sub
Feuerwehrmann
Neuling
 
Beiträge: 1
Registriert: 19. Jul 2019, 21:58


Zurück zu Word Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 2 Gäste