Option Explicit
'*********************************************************
Sub Word_DocsZusammenfassen()
'***
'*** Arbeitsumgebung:
'*** beliebiges Verziechnis mit den Unterverzeichnissen
'*** 99_Makro - Ablageort dieses Makros
'*** 01_Input - Verzeichnis zur Aufnahme der zusammenzufassenden Dokumente
'*** 01_Input\Save - Verzeichnis zur Sicherung der zusammenzufassenden Dokumente
'*** 02_Output - Verzeichnis des zusammengefassten Dokumentes
'***
'*** Es ist zunächst ein Dokument aus dem Input-Verzeichnis als Zieldokument auszuwählen.
'*** Danach werden die restlichen Dokumente aus dem Input-Verzeichnis an diese Dokument
'*** angehängt, durch einen manuellen Abschnittswechsel getrennt.
'*** Das zusammengefaßte Dokument ist in 02Output unter dem Namen des Zieldokumentes zu finden.
'*** Alle Input-Files werden in 01Input\Save gesichert.
Dim s_doc_ziel As String, s_doc_tmp As String
Dim zdoc As Document, tdoc As Document
->Pfade
Dim s_PfadInput As String, s_PfadInputSave As String, s_PfadOutput As String
Application.ScreenUpdating = False
->Zieldatei bestimmen, sichern und ins Output-Verzeichnis verschieben
If Not Word_PfadeBestimmen(s_PfadInput, s_PfadInputSave, s_PfadOutput) Then GoTo AUFRAEUMEN
If Not ZieldateiBestimmen(s_PfadInput, s_doc_ziel) Then GoTo AUFRAEUMEN
If Not DateiSichern(s_PfadInput, s_PfadInputSave, s_doc_ziel) Then GoTo AUFRAEUMEN
If Not DateiInOutputKopieren(s_PfadInput, s_PfadOutput, s_doc_ziel) Then GoTo AUFRAEUMEN
If Not DateiLoeschen(s_PfadInput, s_doc_ziel) Then GoTo AUFRAEUMEN
->Zieldatei öffnen
If Not DateiOeffnen(s_PfadOutput, s_doc_ziel, zdoc) Then GoTo AUFRAEUMEN
->alle verbliebenen Dokumente im Input-Verzeichnis anfügen
Do
->Nächste anzuhängende Datei bestimmen und sichern
If Not NaechsteDateiBestimmen(s_PfadInput, s_doc_tmp) Then GoTo AUFRAEUMEN
If s_doc_tmp = Then Exit Do
If Not DateiSichern(s_PfadInput, s_PfadInputSave, s_doc_tmp) Then GoTo AUFRAEUMEN
->Abschnittswechsel in Zieldatei anhängen
zdoc.Activate
Selection.WholeStory
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertBreak Type:=wdSectionBreakNextPage
->Nächste anzuhängende Datei öffnen
If Not DateiOeffnen(s_PfadInput, s_doc_tmp, tdoc) Then GoTo AUFRAEUMEN
->Nächste anzuhängende Datei alles kopieren
Selection.WholeStory
Selection.Copy
->in Zieldatei anfügen
zdoc.Activate
Selection.Paste
->Nächste anzuhängende Datei schliessen ohne Speichern und im Input löschen
If Not DateiSchliessen(tdoc, True) Then GoTo AUFRAEUMEN
If Not DateiLoeschen(s_PfadInput, s_doc_tmp) Then GoTo AUFRAEUMEN
Loop
->Zieldatei schliessen mit Speichern
If Not DateiSchliessen(zdoc, True) Then GoTo AUFRAEUMEN
Application.ScreenUpdating = True
AUFRAEUMEN:
Set zdoc = Nothing: Set tdoc = Nothing
End Sub
'*******************************************************************************
Private Function NaechsteDateiBestimmen(s_PfadInput As String, _
s_doc As String) As Boolean
Dim f() As String, f_cnt As Long
NaechsteDateiBestimmen = False
s_doc =
Call DateienImVerzeichnisSuchen(s_PfadInput, *.doc, f(), f_cnt)
If f_cnt = 0 Then NaechsteDateiBestimmen = True: Exit Function
s_doc = DateiAuswaehlen(Auswahl Zieldatei, f(), f_cnt)
If s_doc = Then
MsgBox (Auswahl Zieldatei wurd abgebrochen)
Exit Function
End If
NaechsteDateiBestimmen = True
End Function
'*******************************************************************************
Private Function DateiSchliessen(doc As Document, b_Savechanges As Boolean) As Boolean
DateiSchliessen = False
On Error Resume Next
doc.Close Savechanges:=b_Savechanges
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox (File konnte nicht gegeschlossen werden. & vbLf & doc.Name)
Exit Function
End If
On Error GoTo 0
DateiSchliessen = True
End Function
'*******************************************************************************
Private Function DateiOeffnen(s_Pfad As String, _
s_doc As String, _
doc As Document) As Boolean
DateiOeffnen = False
On Error Resume Next
Set doc = Documents.Open(FileName:=s_Pfad & \ & s_doc)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox (File konnte nicht geöffnet werden. & vbLf & s_Pfad & \ & s_doc)
Exit Function
End If
On Error GoTo 0
DateiOeffnen = True
End Function
'*******************************************************************************
Private Function DateiLoeschen(s_Pfad As String, _
s_doc As String) As Boolean
DateiLoeschen = False
On Error Resume Next
Kill s_Pfad & \ & s_doc
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox (File konnte nicht gelöscht werden. & vbLf & s_Pfad & \ & s_doc)
Exit Function
End If
On Error GoTo 0
DateiLoeschen = True
End Function
'*******************************************************************************
Private Function DateiInOutputKopieren(s_Pfad As String, _
s_PfadSave As String, _
s_doc As String) As Boolean
Dim ret As Integer
DateiInOutputKopieren = False
->prüfen, ob Datei bereits vorhanden ist
If Dir(s_PfadSave & \ & s_doc, vbNormal) <> Then
->bereits vorhanden, Nachfrage auf überschreiben
ret = MsgBox( _
Datei-> & s_PfadSave & \ & s_doc &-> bereits vorhanden. & vbLf & vbLf & _
Soll die Datei überschrieben werden?, _
vbQuestion + vbDefaultButton2 + vbYesNo)
If ret = vbNo Then Exit Function
End If
If Not DateiSichern(s_Pfad, s_PfadSave, s_doc) Then Exit Function
DateiInOutputKopieren = True
End Function
'*******************************************************************************
Private Function DateiSichern(s_Pfad As String, _
s_PfadSave As String, _
s_doc As String) As Boolean
DateiSichern = False
On Error Resume Next
FileCopy _
s_Pfad & \ & s_doc, _
s_PfadSave & \ & s_doc
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox (File konnte nicht gesichert werden. & vbLf & s_Pfad & \ & s_doc)
Exit Function
End If
On Error GoTo 0
DateiSichern = True
End Function
'*******************************************************************************
Private Function ZieldateiBestimmen(s_PfadInput As String, _
s_doc_ziel As String) As Boolean
Dim f() As String, f_cnt As Long
ZieldateiBestimmen = False
s_doc_ziel =
Call DateienImVerzeichnisSuchen(s_PfadInput, *.doc, f(), f_cnt)
If f_cnt = 0 Then
MsgBox (Keine Documente im Input-Verzeichnis)
Exit Function
End If
s_doc_ziel = DateiAuswaehlen(Auswahl Zieldatei, f(), f_cnt)
If s_doc_ziel = Then
MsgBox (Auswahl Zieldatei wurd abgebrochen)
Exit Function
End If
ZieldateiBestimmen = True
End Function
'*******************************************************************************
Private Function DateienImVerzeichnisSuchen(s_Pfad As String, _
s_filename As String, _
f() As String, f_cnt As Long)
Dim i As Long
f_cnt = 0: ReDim f(1 To 1)
With Application.FileSearch
.NewSearch
.LookIn = s_Pfad
.SearchSubFolders = False
.FileName = s_filename
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
->Filenamen in Feld
f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
f(f_cnt) = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(s_Pfad) - 1)
Next i
End If
End With
End Function
'*******************************************************************************
Private Function Word_PfadeBestimmen(s_PfadInput As String, _
s_PfadInputSave As String, _
s_PfadOutput As String) As Boolean
Const c_TeilPfad_Makro = 99_Makro
Const c_TeilPfad_Input = 01_Input
Const c_TeilPfad_InputSave = 01_Input\Save
Const c_TeilPfad_Output = 02_Output
Dim s_Pfad As String, ret As Integer
Word_PfadeBestimmen = False
->Makro-Pafd bestimmen
s_Pfad = ThisDocument.Path
If Right(s_Pfad, Len(c_TeilPfad_Makro)) <> c_TeilPfad_Makro Then
MsgBox ( _
Makro erwartet Aufrufverzeichnis ...\ & c_TeilPfad_Makro & vbCrLf & _
Aufgerufen aus : & s_Pfad)
Exit Function
End If
s_Pfad = Left(s_Pfad, Len(s_Pfad) - Len(c_TeilPfad_Makro))
s_PfadInput = Word_PfadPruefen(s_Pfad, c_TeilPfad_Input, _
Input-Verzeichnis)
If s_PfadInput = Then Exit Function
s_PfadInputSave = Word_PfadPruefen(s_Pfad, c_TeilPfad_InputSave, _
Sicherungs-Verzeichnis für Input)
If s_PfadInputSave = Then Exit Function
s_PfadOutput = Word_PfadPruefen(s_Pfad, c_TeilPfad_Output, _
Output-Verzeichnis)
If s_PfadOutput = Then Exit Function
Word_PfadeBestimmen = True
End Function
'*******************************************************************************
Private Function Word_PfadPruefen(s_Pfad As String, s_TeilPfad As String, _
s_Bezeichnung_Ordner As String) As String
Dim s_Pfad_komplett As String, ret As Integer
Word_PfadPruefen =
s_Pfad_komplett = s_Pfad & s_TeilPfad
If Dir(s_Pfad_komplett, vbDirectory) = Then
ret = MsgBox( _
s_Bezeichnung_Ordner & nicht vorhanden: & s_Pfad_komplett & vbLf & _
Soll das Verzeichnis angelegt werden ?, _
vbQuestion + vbYesNo + vbDefaultButton2)
If ret = vbYes Then
On Error Resume Next
MkDir (s_Pfad_komplett)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox (Fehler beim Anlegen des Verzeichnis. & vbLf & s_Pfad_komplett)
Exit Function
End If
On Error GoTo 0
Else
Exit Function
End If
End If
Word_PfadPruefen = s_Pfad_komplett
End Function
'*******************************************************************************
Private Function DateiAuswaehlen(s_Dialog_titel As String, _
f() As String, f_cnt As Long) As String
Const c_BREITE_ZEILEANGABE = 3
Dim l_zaehler As Long, s_tmp As String, s_r As String
Dim l_AnzLeerzeichen As Long, l_AnzStellen As Long, x As Long
Dim s_Nr As String, l_Nr As Long, y As Long, s As String
->Meldung zusammenstellen
s_tmp = Bitte geben Sie den Index der auszuwählenden Datei an & vbLf & vbLf
l_zaehler = 0
For x = 1 To f_cnt
s_r = x
l_AnzLeerzeichen = c_BREITE_ZEILEANGABE - Len(s_r)
If l_AnzLeerzeichen < 0 Then l_AnzLeerzeichen = 0
l_AnzStellen = Len(s_r)
s_tmp = s_tmp & Format(x, String(l_AnzLeerzeichen, _) & _
String(Len(s_r), 0)) & vbTab & f(x) & vbLf
l_zaehler = l_zaehler + 1
Next
->Meldung ausgeben und Auswahl
Nochmal:
s_Nr = InputBox(s_tmp, s_Dialog_titel, )
If s_Nr <> Then
For y = 1 To Len(s_Nr)
s = Mid(s_Nr, y, 1)
Select Case s
Case 0 To 9->zulässig
Case Else
MsgBox (Bitte nur eine Zahl eingeben.)
GoTo Nochmal
End Select
Next
l_Nr = s_Nr
If l_Nr < 0 Or l_Nr > f_cnt Then
MsgBox (Index zu groß.)
GoTo Nochmal
End If
->ausgewahlte Datei
DateiAuswaehlen = f(l_Nr)
Else
DateiAuswaehlen =
End If
End Function
