Problem Serienbrief
18.07.2017 14:27:31
Peter
ich suche seit Tagen nach einer Lösung.
Aus dem Forumarchiv habe ich einen Code zur Erstellung eines Serienbriefes herunter-
geladen und für meine Bedürfnisse abgeändert.
Den Code füge ich u.a. bei.
Es läuft im Prinzip alles wunderbar, aber ich möchte die Datei speichern unter
Name.docm d. h. es soll die Datei, welche ein Makro enthält anschliessend so
funktionieren, dass das Makro gestartet werden kann.
So wie dies jetzt speichert erfolgt beim Öffnen die Meldung: Leider kann worddatei...
nicht geöffnet werden, da der Inhalt Probleme bereitet.
Das Problem ist, dass das Dokument nicht richtig gespeichert wird.
Option Explicit
Option Private Module 'damit kann man die Prozeduren nicht per Alt+F8 starten
'interne Word-Konstanten in Excel nachbilden
Const wdOpenFormatAuto As Integer = 0
Const wdFormLetters As Integer = 0
Const wdSendToNewDocument As Integer = 0
Const wdSendToPrinter As Integer = 1
Const wdDefaultFirstRecord As Integer = 1
Const wdDefaultLastRecord As Integer = -16
Const wdMergeSubTypeAccess As Integer = 1
Const wdFirstDataSourceRecord As Integer = -6
Const wdFormatPDF As Integer = 17
Const wdPrintAllDocument As Integer = 0
Const wdFormatXMLDocument As Integer = 12
Const wdToggle As Long = 9999998
Const wdFormatXMLDocumentMacroEnabled As Integer = 0
Const wdWindowStateMinimize As Integer = 0
Const wdWindowStateMaximize As Integer = 0
'hier geht es los!
Sub Serienbrief_erstellen()
Dim oWrd As Object, oDoc As Object
Dim wb As Workbook, ws As Worksheet
Dim strSheetName As String, xDocV As String, xSql As String
'Auswahldokument speichern
Dim Pfad, Datei
Pfad = "C:\Users\Peter\Desktop\Test_2017_07_17\"
Debug.Print Pfad
Datei = "NTest1Datum1.docm"
Debug.Print Datei
'Serienbrief speichern
Dim PfadS, DateiS
PfadS = "C:\Users\Peter\Desktop\Test_2017_07_17\"
Debug.Print PfadS
DateiS = "Serienbrief_2017_07_17"
Debug.Print DateiS
'für Vorlagedatei wieder schliessen
Dim AuswDok As String
Dim objdoc As Object
AuswDok = "Serienbrief_2017_07_17.docm"
Debug.Print AuswDok
On Error Resume Next
'prüfen, ob Word schon aktiv ist
Set oWrd = GetObject(, "Word.Application")
If oWrd Is Nothing Then
'wenn nicht, dann Word erst mal öffnen
Set oWrd = CreateObject("Word.Application")
End If
On Error GoTo 0
If oWrd Is Nothing Then
MsgBox "Auf diesem Rechner ist M$-Word nicht installiert!", vbSystemModal + 16, "Hinweis. _
Exit Sub
End If
'diese Arbeitsmappe
Set wb = ThisWorkbook
'2. Tabellenblatt
Set ws = wb.Worksheets("Tabelle1")
strSheetName = ws.Name
'Ort der Word-Vorlage Serienbrief auf dem Datenträger
'hier wird davon ausgegangen, das sich Word- & Exceldatei im gleichen Verzeichnis befinden
xDocV = wb.Path & "\" & "VorlageTest_.docm"
Debug.Print xDocV
'hierin befinden sich die {MergeField ...} und der sonstige Brieftext
Set oDoc = oWrd.Documents.Add(Template:=xDocV, NewTemplate:=False, DocumentType:=0)
oWrd.Visible = True
With oDoc
'neugeöffnete Datei in Serienbrief-Hauptdokument umwandeln
.MailMerge.MainDocumentType = wdFormLetters
'Datenfeld-Auswahl in SQL-Schreibweise
xSql = "SELECT * FROM [Tabelle1$]"
.MailMerge.OpenDataSource Name:=wb.FullName, _
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=" & wb.FullName & _
";Mode=Read;Extended Properties=""Excel 12.0 Macro;HDR=YES;IMEX=1;""", _
SQLStatement:=xSql, SQLStatement1:="", SubType:=wdMergeSubTypeAccess
'Hinweis
'ab Office 2007 sollte der hier angewendete Treiber benutzt werden
'bei *.xlsm als Datenquelle
'";Extended Properties=""Excel 12.0 Macro; HDR=YES; IMEX=1"""
'bei *.xlsx als Datenquelle
'";Extended Properties=""Excel 12.0 Xml; HDR=YES; IMEX=1"""
'alter Daten-Treiber - Bitte nur bei Zugriff auf *.xls-Dateien (bid Excel 2003) _
benutzen
'"Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=user;Data Source=" & wb. _
FullName & "Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB" _
', SQLStatement:="SELECT * FROM `2017$`", SQLStatement1:="", SubType:= _
'wdMergeSubTypeAccess
'Filter setzen
.MailMerge.DataSource.QueryString = _
"SELECT * FROM `Tabelle1$` WHERE `Name` > 0 And `Vorname` > 0 "
'Umschalten auf Datenansicht
.MailMerge.ViewMailMergeFieldCodes = wdToggle
End With
' With oWrd.Dialogs(84) 'wdDialogFileSaveAs
' .Name = Pfad & Datei
' .Show
' End With
'neue Datei speichern unter
oDoc.Application.WindowState = wdWindowStateMinimize
oDoc.SaveAs Pfad & Datei
oDoc.SaveAs2 Filename:="NTest1Datum1.docm", FileFormat:= _
wdFormatXMLDocumentMacroEnabled, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
oDoc.Application.WindowState = wdWindowStateMaximize
oDoc.Close
oWrd.Documents.Open ("C:\Users\Peter\Desktop\Test_2017_07_17\NTest1Datum1.docm")
Set oDoc = oWrd.Documents.Open("C:\Users\Peter\Desktop\Test_2017_07_17\NTest1Datum1.docm") ' _
Dokument öffnen
oWrd.Application.Run "oDoc!Projekt.NewMacros.Sendkey"
''speichern mit Abfrage
' oDoc.Application.WindowState = wdWindowStateMinimize
''' If MsgBox("Auswahldokument speichern ?", vbYesNo + vbQuestion, _
''' "Serienbrief-Erstellung speichern") = vbYes Then
''' oDoc.Application.WindowState = wdWindowStateMaximize
'''' oDoc.Application.Dialogs(wdDialogFileSaveAs).Show
''' oDoc.SaveAs Pfad & Datei
''' End If
' oDoc.Application.WindowState = wdWindowStateMaximize
' End With
'speichern ohne Abfrage
' oDoc.Application.WindowState = wdWindowStateMinimize
''' oDoc.Application.Dialogs(wdDialogFileSaveAs).Show
' oDoc.SaveAs Pfad & Datei
' oDoc.Application.WindowState = wdWindowStateMaximize
''''''hier Datumprüfung einfügen
'''''Dim dia As Date
''''' Dim dia2A As Range
''''' Dim dia2E As Range
'''''' dia = Date
'''''' dia = Range("C8")
'''''' Set dia2A = Range("C10") ' in A1 steht z.B. 01.10. 2008
'''''' Set dia2E = Range("C12")
''''' dia = Range("W18") 'nur zum test sonst W15
''''' Set dia2A = Range("W25") ' in A1 steht z.B. 01.10. 2008
''''' Set dia2E = Range("W29")
'''''' If dia >= dia2A Then
'''''' MsgBox "> grösser"
'''''' Else
'''''' MsgBox "= dia2A And dia 1 Then
''''''''''objdoc.Close Savechanges:=False
''''''''''Else
''''''''''Word.Application.Quit
'''''''''' End If
''''''''''End If
'''''''''Serienbrief speichern
'''''''' Dim wdApp As Object, wdDoc As Object
'''''''' Set wdApp = GetObject(, "Word.Application")
'''''''' Set wdDoc = wdApp.Documents(1)
'''''''' wdDoc.SaveAs PfadS & DateiS
''''''Excel in Vordergrund bringen
'''''AppActivate Application.Caption
''''''Beginn MsgBox - Druckauswahl
''''' Dim iRet As Integer
''''' Dim strPrompt As String
''''' Dim strTitle As String
''''' ' Promt
''''' strPrompt = "Ja - Button = alles Drucken" & vbLf & _
''''' "Nein - Button = Drucken-Voransicht" & vbLf & _
''''' "Abbrechen - Button = Serienbrief Selbstauswahl"
''''' ' Dialog's Title
''''' strTitle = "Druckauswahl"
''''' 'Display MessageBox
''''' iRet = MsgBox(strPrompt, vbYesNoCancel, strTitle)
''''' wdDoc.Application.WindowState = wdWindowStateMinimize
''''' If iRet = vbYes Then
'''''' MsgBox "alles Drucken"
''''' wdDoc.Application.WindowState = wdWindowStateMaximize
''''' wdDoc.PrintOut
''''' ElseIf iRet = vbNo Then
'''''' MsgBox "Drucken-Voransicht"
''''' wdDoc.Application.WindowState = wdWindowStateMaximize
''''' wdDoc.PrintPreview
''''' ElseIf iRet = vbCancel Then
''''' MsgBox "Serienbrief Selbstauswahl"
''''' wdDoc.Application.WindowState = wdWindowStateMaximize
'''''' Exit Sub
''''' End If
''''''ende msgbox - Druckauswahl
''''' Else
''''' MsgBox "Datum liegt ausserhalb"
'''''' Exit Sub
''''' oWrd.Activate
'''''' oDoc.Application.WindowState = wdWindowStateMaximize
''''' End If
'beide Objektvariablen für Word ins Nirvana schicken
Set oDoc = Nothing
Set oWrd = Nothing
' Set docSerienbrief = Nothing
Set objdoc = Nothing
' Set AuswDok = Nothing
'Achtung!!! Excel darf nicht geschlossen werden, da sonst die Daten in Word fehlen
'Excel-Datei und Excel schliessen
' Call Excel_beenden_mit_Prüfung
End Sub
Bei dieser Zeile: 'neue Datei speichern unter beginnt das Problem!
Wie kann die Datei gespeichert werden, damit das ganze richtig funktioniert?
Datei anbei:https://www.herber.de/bbs/user/114937.xlsm
Worddatei konnte nicht beigefügt werden da *.docm
Besten Dank für eure Hilfe.
Gruss
Peter