Dateien Speichern

Private Const Verzeichnis = "C:\Users\becke\Documents\23.kw"
Private Const Praefix = "GMPP, " 'Optional eine Zeichenfolge davor
Private Const Suffix = ". FH"
Private Const Schluessel = "Namen_auf_dem_Grabstein" 'Feldname des Felds, welches den Speichername enthält
'Private Const Schluessel = "Friedhofnummer"
Private Const Adresse = "Ort"
Sub JederDatensatzInEineEigenstaendigeDatei_2()
With ActiveDocument.MailMerge
If .MainDocumentType = wdNotAMergeDocument Then
MsgBox "Das aktive Dokument ist kein Seriendruckhauptdokument."
Exit Sub
End If
.DataSource.ActiveRecord = wdLastRecord
Anzahl = .DataSource.ActiveRecord
If Anzahl = 0 Then
MsgBox "Es wurden keine Datensätze gefunden."
Exit Sub
End If
flag = False
For Each x In .DataSource.DataFields
If x.Name = Schluessel Then
flag = True
Exit For
End If
Next
If flag = False Then
Q = Chr(34)
MsgBox "Das nominierte Feld " & Q & Schluessel & Q & _
" existiert nicht in der Datenquelle."
Exit Sub
End If
.Destination = wdSendToNewDocument
For i = 1 To Anzahl
.DataSource.ActiveRecord = i
dsname = Verzeichnis & "\" & Praefix & _
.DataSource.DataFields(Schluessel).Value & Suffix & ".docx"
.DataSource.FirstRecord = i
.DataSource.LastRecord = i
Selection.WholeStory
Selection.Fields.Update
.Execute
ActiveDocument.Range.Find.Execute
ActiveDocument.SaveAs FileName:=dsname, AddToRecentFiles:=False
ActiveDocument.Close
Next i
.DataSource.FirstRecord = 1 'be smart
End With
End Sub
Sub Seriendruckmängelprotokoll()
With ActiveDocument.MailMerge
If .MainDocumentType = wdNotAMergeDocument Then
MsgBox "Das aktive Dokument ist kein Seriendruckhauptdokument."
Exit Sub
End If
.DataSource.ActiveRecord = wdLastRecord
Anzahl = .DataSource.ActiveRecord
If Anzahl = 0 Then
MsgBox "Es wurden keine Datensätze gefunden."
Exit Sub
End If
flag = False
For Each x In .DataSource.DataFields
If x.Name = Schluessel Then
flag = True
Exit For
End If
Next
If flag = False Then
Q = Chr(34)
MsgBox "Das nominierte Feld " & Q & Schluessel & Q & _
" existiert nicht in der Datenquelle."
Exit Sub
End If
.Destination = wdSendToNewDocument
For i = 1 To Anzahl
.DataSource.ActiveRecord = i
dsname = Verzeichnis & "\" & Praefix & _
.DataSource.DataFields(Schluessel).Value & ".docx"
.DataSource.FirstRecord = i
.DataSource.LastRecord = i
Selection.WholeStory
Selection.Fields.Update
.Execute
ActiveDocument.Range.Find.Execute
ActiveDocument.SaveAs FileName:=dsname, AddToRecentFiles:=False
ActiveDocument.Close
Next i
.DataSource.FirstRecord = 1 'be smart
End With
End Sub