Serienbrief per VBA
15.08.2023 10:36:42
Chris
Hallo ralf_b,
Danke für deine Hinweise. 2x End sub ist natürlich nicht möglich...ist geändert., ebenso habe ich ExportAs.. eingfügt.
Ich bin nicht der große VBA-Experte. Aus meiner Sicht wird die Variabel arrNamen im Function-Teil gefüllt: Es sind die Seriendruckfelder für den Vor- und Nachnamen.
Vielleicht hast du noch konkrete Änderungs-/Ergänzungstipps in Sachen arrNamen.
Nochmals Danke
Chris
Hier das Makro:
Option Explicit
Public arrNamen() As String
Public PDFpath As String
'Verweise
'DAO 3.6
'Word 1x
Public Function leseDB() As Boolean
On Local Error GoTo leseDBERR
Dim bErgebnis As Boolean
Dim strDatenquelle As String
Dim myDB As Database, myREC As Recordset
Dim lngAnzahl As Long
Dim lngZahler As Long
PDFpath = Environ("userprofile") & "\Desktop\" 'anpassen
strDatenquelle = Environ("userprofile") & "\Desktop\Datenquelle.xlsx" 'anpassen
Dim strConnection As String
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & strDatenquelle & ";" _
& "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";" _
& "Jet OLEDB:Engine"
Set myDB = DAO.OpenDatabase(strDatenquelle)
'!!! SELECT anpasssen !!!
Set myREC = myDB.OpenRecordset("SELECT * FROM B1RDSL$", dbOpenSnapshot)
With myREC
.MoveLast
lngAnzahl = .RecordCount
ReDim arrNamen(2, lngAnzahl - 1)
.MoveFirst
For lngZahler = 0 To lngAnzahl - 1
arrNamen(0, lngZahler) = .Fields("Vorname").Value
arrNamen(1, lngZahler) = .Fields("Nachname").Value
arrNamen(2, lngZahler) = PDFpath & "TestSB" & UCase(.Fields("Nachname").Value) & ", " & .Fields("Vorname").Value & ".pdf"
.MoveNext
'evtl DoEvents
Next lngZahler
.Close
End With
Set myREC = Nothing
myDB.Close
bErgebnis = True
leseDBOUT:
leseDB = bErgebnis
Set myDB = Nothing
Exit Function
leseDBERR:
bErgebnis = False
Resume leseDBOUT
End Function
Public Sub ausDrucken()
On Local Error GoTo ausDruckenERR
Application.DisplayAlerts = False
Dim objWinword As Word.Application, WinDoc As Word.Document
Dim strDatenquelle As String
Dim strWordvorlage As String
Dim newDoc As Word.Document
Dim strBrief As String
Dim lngAbschntitt As Long
Dim lngZahler As Long
strDatenquelle = Environ("userprofile") & "\Desktop\Datenquelle.xlsx" 'anpassen
strWordvorlage = Environ("userprofile") & "\Desktop\Serienbrief.docx" 'Anpassen
PDFpath = Environ("userprofile") & "\Desktop\" 'anpassen
Set objWinword = New Word.Application
With objWinword
.Visible = False
Set WinDoc = .Documents.Open(strWordvorlage)
WinDoc.MailMerge.OpenDataSource Name:= _
strDatenquelle, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & strDatenquelle & ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=5;Jet OLEDB:Database" _
, SQLStatement:="SELECT * FROM `B1RDSL$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
With WinDoc.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
Set newDoc = objWinword.ActiveDocument
End With
For lngZahler = 0 To UBound(arrNamen, 2) 'newDoc.Sections.Count - 2
strBrief = arrNamen(2, lngZahler)
newDoc.PrintOut Outputfilename:=strBrief, Range:=wdPrintRangeOfPages, Item:= _
wdPrintDocumentWithMarkup, Copies:=1, Pages:="s" & lngZahler + 1, PageType:= _
wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=True, _
PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0
newDoc.ExportAsFixedFormat Outputfilename:=strBrief & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, Item:=wdExportDocumentContent, _
IncludeDocProps:=True
Next lngZahler
newDoc.Close SaveChanges:=False
WinDoc.Close SaveChanges:=False
objWinword.Quit
ausDruckenOUT:
Application.DisplayAlerts = True
Set newDoc = Nothing
Set WinDoc = Nothing
Set objWinword = Nothing
Exit Sub
ausDruckenERR:
'MsgBox err .....
Resume ausDruckenOUT
End Sub
