AW: serienbrief drucken
17.09.2004 21:45:34
andre
Hallo Michael,
Einen Verweis auf Microsoft Word... setzen
Sub SerienDruckUndTexteErsetzen()
' Makro am 20.05.2004 von SchauAn
' Stand 15.08.04 / 20:33 Uhr
' Variablen und Konstanten für Word
Dim wordObj As Word.Application
Dim DeinDateiName As String
' Variablen für Excel
Dim DatenQuelle As String
' Hier den Standard-Namen des Haupddokument eintragen
' wenn nicht vorhanden, Eintrag aus A1 in Blatt Admin
DeinDateiName = InputBox("Eingabe Hauptdokument: ", "Hauptdokument", _
ThisWorkbook.Sheets("Admin").[a1])
If DeinDateiName = "" Then DeinDateiName = ThisWorkbook.Sheets("Admin").[a1]
' Document öffnen
Set wordObj = CreateObject("Word.Application")
wordObj.Visible = False
On Error GoTo nixda
wordObj.Documents.Open DeinDateiName
With wordObj
' erst mal der Seriendruck
With .ActiveDocument.MailMerge
On Error GoTo errorhandler
.Destination = wdSendToNewDocument
On Error GoTo 0
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
' Speichern des Serienbriefes unter ...
' wordObj.ActiveDocument.SaveAs ("C:\test\serientest.doc")
On Error GoTo nixda
' Abfrage des Namens für das Serienbriefdokument
' wenn nicht vorhanden, Eintrag aus A2 in Blatt Admin
DeinDateiName = InputBox("Eingabe Serienbriefname", "Serienbriefname", ThisWorkbook.Sheets("Admin").[a2])
If DeinDateiName = "" Then DeinDateiName = ThisWorkbook.Sheets("Admin").[a2]
wordObj.ActiveDocument.SaveAs (DeinDateiName)
' Schließen aller offenen Documente ohne Speichern
On Error Resume Next
For i = 1 To 3
wordObj.ActiveDocument.Close False
Next
On Error GoTo 0
wordObj.Application.Quit 'hier sollte man noch eine Fehlerbehandlung einbauen
'damit bei einem Abbruch nicht das wordobj offen bleibt !
End With
' MsgBox "Fertig" & Chr(10) & "gespeichert unter: C:\test\serientest.doc"
MsgBox "Fertig" & Chr(10) & "gespeichert unter: " & DeinDateiName
Exit Sub
' Fehlerbehamndlung - Anlage des Serienhauptdokumentes
errorhandler:
If Err.Number = 5852 Then
With wordObj.ActiveDocument.MailMerge
.MainDocumentType = wdFormLetters
' das Verzeichnis und Quelldatei wird aus dem Blatt Admin [a1] geholt
DatenQuelle = InputBox("Eingabe Hauptdokument: ", "Hauptdokument", _
ThisWorkbook.Sheets("Admin").[a3])
If DatenQuelle = "" Then DatenQuelle = ThisWorkbook.Sheets("Admin").[a3]
' oder alternativ ohne Inputbox, dann die beiden anderen Zeilen auskommentieren
' DatenQuelle = ThisWorkbook.Sheets("Admin").[a3]
' Daten auf Blatt Test1, bei anderem Namen entsprechend ändern
' (Zeile mit SELECT * FROM `Test1 ...)
.OpenDataSource Name:=DatenQuelle, _
LinkToSource:=True, Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=" & _
DatenQuelle & ";Mode=Read;Extended Properties="";HDR=YES;IMEX=1;"";Jet OLEDB:Engine Type=35" _
, SQLStatement:="SELECT * FROM `Test1$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
' wenn nötig Langversion - Achtung, Begrenzung maximale Anzahl Zeichen für den Befehl
' wird durch Pfadlänge weiter eingeschränkt!
' .OpenDataSource Name:=DatenQuelle, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=" & DatenQuelle & _
";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database _
Password="""";Jet OLEDB:Engine Type=35" _
, SQLStatement:="SELECT * FROM `Test1$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
' vor HDR=YES war kein Semikolon, manuell nachgetragen, Auswirkung = ???
End With
Resume
End If
nixda:
If Err.Number = 5273 Then
MsgBox "Pfad -->" & DeinDateiName & " <-- nicht gefunden !" & Chr(10) & _
"Programm wird beendet!"
End If
If Err.Number = 5174 Then
MsgBox "Datei -->" & DeinDateiName & " <-- nicht gefunden !" & Chr(10) & _
"Programm wird beendet!"
End If
On Error Resume Next
wordObj.Application.Quit
End Sub