Liebe Leute, ich habe Word 2007 und mittlerweile Win10 und würde gerne einen Serienbrief einzeln als PDFs speichern (über VBA-Code)
Hab dazu den Standardcode aus dem Internet damals kopiert und verwendet. Leider funktioniert der aber nicht mehr, und ich weiß nicht warum (ich kenne mich auch nur mittelmäßig mit VBA-Codes aus).
Habt ihr eine Lösung für den Code oder einen anderen der funktioniert (mit Speicherortauswahl und Dateiname aus den Seriendruckfeldern)??
Vielen Dank!!!
----------------------------------------
Sub Serienbrief()
' 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
' Speicherort für die Serienbriefe auswählen
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") & "\" 'Ordner für PDF-Datein erstellen
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
' Einzelpdf erstellen und speichern
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
sBrief = Path & .DataFields("ID3").Value & ".pdf" 'Name der Datei
End With
.Execute Pause:=False
If .DataSource.DataFields("ID3").Value > "" Then 'Dateiname wird aus der ID3 gebildet
ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatPDF 'er speichert die Datein nicht und hier beendet er das Makro
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 Err.Number & " Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 5852 Then
MsgBox Err.Number & " Das Dokument ist kein Serienbrief"
ElseIf Err.Number = 4198 Then
MsgBox Err.Number & " Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical 'dieser Fehler taucht auf
ElseIf Err.Number = 91 Then
MsgBox Err.Number & " Exportieren von Serienbriefen abgebrochen", vbOKOnly + vbExclamation
ElseIf Err.Number > 0 Then
MsgBox Err.Number & " Unbekannter Fehler: " & Err.Number & " - Bitte Makro erneut ausführen.", vbOKOnly + vbCritical
Else
MsgBox "Serienbriefe erfolgreich exportiert", vbOKOnly + vbInformation
End If
End Sub
Hab dazu den Standardcode aus dem Internet damals kopiert und verwendet. Leider funktioniert der aber nicht mehr, und ich weiß nicht warum (ich kenne mich auch nur mittelmäßig mit VBA-Codes aus).
Habt ihr eine Lösung für den Code oder einen anderen der funktioniert (mit Speicherortauswahl und Dateiname aus den Seriendruckfeldern)??
Vielen Dank!!!
----------------------------------------
Sub Serienbrief()
' 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
' Speicherort für die Serienbriefe auswählen
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") & "\" 'Ordner für PDF-Datein erstellen
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
' Einzelpdf erstellen und speichern
With ActiveDocument.MailMerge
.DataSource.ActiveRecord = 1
Do
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = .ActiveRecord
.LastRecord = .ActiveRecord
sBrief = Path & .DataFields("ID3").Value & ".pdf" 'Name der Datei
End With
.Execute Pause:=False
If .DataSource.DataFields("ID3").Value > "" Then 'Dateiname wird aus der ID3 gebildet
ActiveDocument.SaveAs FileName:=sBrief, FileFormat:=wdFormatPDF 'er speichert die Datein nicht und hier beendet er das Makro
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 Err.Number & " Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical
ElseIf Err.Number = 5852 Then
MsgBox Err.Number & " Das Dokument ist kein Serienbrief"
ElseIf Err.Number = 4198 Then
MsgBox Err.Number & " Der ausgewählte Speicherort ist ungültig", vbOKOnly + vbCritical 'dieser Fehler taucht auf
ElseIf Err.Number = 91 Then
MsgBox Err.Number & " Exportieren von Serienbriefen abgebrochen", vbOKOnly + vbExclamation
ElseIf Err.Number > 0 Then
MsgBox Err.Number & " Unbekannter Fehler: " & Err.Number & " - Bitte Makro erneut ausführen.", vbOKOnly + vbCritical
Else
MsgBox "Serienbriefe erfolgreich exportiert", vbOKOnly + vbInformation
End If
End Sub