also dann mal ein Beispiel:
Vorlagen hab ich in den Ordner
Code:
D:\00_TestExcel\TestDoc\Vorlagen
gepackt. Das kann im Makro in der Variablen sPfadIn geändert werden.
Output-Verzeichnis ist
Code:
D:\00_TestExcel\TestDoc\Ausgabe
Das kann im Makro in der Variablen sPfadOut geändert werden.
zu suchende Dateiendung ist als
definiert. Das kann im Makro in der Variablen sDateiendung geändert werden.
Die Vorlagen sind also als .doc-Dateien im Vorlagenverzeichnis hinterlegt.
In den Vorlagen sind 4 Textmarken für Firma, Niederlassung, Straße Nr. und PLZ Ort zu setzen. Dabei ist darauf zu achten, daß jede Textmarke nicht !!! einen Zeilenvorschub einschließt. Dann würde beim Ersetzen des Textes der Textmarke der Zeilenvorschub mit ersetzt werden und die nachfolgende Zeile nach oben rutschen.
Das gezielte Markieren erfolgt, indem man die Schreibmarke direkt hinter das zu markierende Wort setzt und dann die Markierung mit Shift+linke Pfeiltaste wie gewünscht erweitert. Dann Einfügen->Textmarke.
Als Textmarkennamen hab ich TM1, TM2, TM3, TM4 gewählt. Das kann auch geändert werden. Im Makro werdren die Namen in den Variablen sTM(1-4)Name gespeichert.
So. Nun leg ich im Verzeichnis Vorlagen die Makro-Datei Makro.doc an. Die wird bei der Dateisuche ausgefiltert, so dass sie nicht als Vorlage behandelt wird.
In Zeile 1 bis 4 kommt jeweils der Text der in der Textmarke der Vorlagen ersetzt werden soll. Die Zeilen sind dabei durch einen Zeilenvorschub getrennt (Eingabetaste).
Also z. B.
Firma Turbo
Section Automatio
Abcstr. 22
33330 Ortsangabe
Mit Alt+F11 wird der VB-Editor in Word geöffnet. Im Projektfenster wird unter Project(Makro.doc) ein Modul eingefügt (recht Maustaste auf Projekt->Einfügen->Modul
Im sich öffnenden Modul-Fenster den nachfolgenden Code per copy/Paste einfügen. GGf. die Inhalte der oben genannten Variablen den eigenen Gegebenheiten anpassen.
Unter Extras->Verweise muß Microsoft Scripting Runtime angehakt werden, damit das Dateisuchen funktioniert.
Mit Debuggen->Kompilieren von Projekt nochmal überprüfen ob alles ok ist. Dann mit Strg+S speichern und per Datei->Schliessen und zurück zu Word den VB-Editor schliessen.
Jetzt mit Ansicht->Makros->Makros anzeigen->Makros in: Makro.doc->Verz_Dateien_TMsErsetzen->Ausführen das Makro ausprobieren.
So, ich hoffe ich hab nichts wichtiges vergessen.
Gruß Matjes
Code:
Option Explicit
Sub Verz_Dateien_TMsErsetzen()
->fuer FSO muss im VB-Editor unter Extras->Verweise Microsoft Scripting Runtime angehakt sein
Dim sTM1Name As String, sTM1Text As String, sTM2Name As String, sTM2Text As String
Dim sTM3Name As String, sTM3Text As String, sTM4Name As String, sTM4Text As String
Dim sPfadIn As String, sDateiendung As String, SPfadOut As String
Dim f() As String, fCnt As Long, x As Long, pos As Long
Dim doc As Document
Dim ret As Integer
->Vorlagen-Pfad definieren
sPfadIn = D:\00_TestExcel\TestDoc\Vorlagen
->zu suchende Dateiendung definieren'
sDateiendung = .doc
->Ausgabe-Pfad definieren
SPfadOut = D:\00_TestExcel\TestDoc\Ausgabe
->Textmarken-Namen definieren, so wie sie in den Vorlagen angelegt sind
sTM1Name = TM1
sTM2Name = TM2
sTM3Name = TM3
sTM4Name = TM4
->Text aus Zeile 1 in diesem Dokument ohne CR
sTM1Text = ThisDocument.Paragraphs(1).Range.Text
pos = InStr(1, sTM1Text, vbCr)
If (pos > 0) Then sTM1Text = Left(sTM1Text, pos - 1)
->Text aus Zeile 2 in diesem Dokument ohne CR
sTM2Text = ThisDocument.Paragraphs(2).Range.Text
pos = InStr(1, sTM2Text, vbCr)
If (pos > 0) Then sTM2Text = Left(sTM2Text, pos - 1)
->Text aus Zeile 3 in diesem Dokument ohne CR
sTM3Text = ThisDocument.Paragraphs(3).Range.Text
pos = InStr(1, sTM3Text, vbCr)
If (pos > 0) Then sTM3Text = Left(sTM3Text, pos - 1)
->Text aus Zeile 4 in diesem Dokument ohne CR
sTM4Text = ThisDocument.Paragraphs(4).Range.Text
pos = InStr(1, sTM4Text, vbCr)
If (pos > 0) Then sTM4Text = Left(sTM4Text, pos - 1)
->Dateien in Verzechnis suchen
fCnt = 0
If Not FSO_Folder_List_Files(sPfadIn, sDateiendung, f(), fCnt) Then GoTo AUFRAEUMEN
If fCnt = 0 Then MsgBox Keine entsprechende Datei im Verzeichnis.: GoTo AUFRAEUMEN
->Für alle Dateien
For x = 1 To fCnt
->Datei öffnen
Set doc = Documents.Open(FileName:=sPfadIn & Application.PathSeparator & f(x))
->Alarm abschalten, damit ggf. eine Datei gleichen Namens im Zielverz.
->ohne Meldung überschrieben werden kann
Application.DisplayAlerts = wdAlertsNone
->Datei im ZielVerz. speichern
doc.SaveAs FileName:=SPfadOut & Application.PathSeparator & f(x)
->Alarm wieder anschalten
Application.DisplayAlerts = wdAlertsAll
->Text der Textmarke 1 ersetzen
On Error Resume Next
doc.Bookmarks(sTM1Name).Range.Text = sTM1Text
If Err.Number <> 0 Then
MsgBox (Textmarke-> & sTM1Name &-> in Datei & f(x) & nicht vorhanden.)
doc.Close Savechanges:=False
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->Text der Textmarke 2 ersetzen
On Error Resume Next
doc.Bookmarks(sTM2Name).Range.Text = sTM2Text
If Err.Number <> 0 Then
MsgBox (Textmarke-> & sTM2Name &-> in Datei & f(x) & nicht vorhanden.)
doc.Close Savechanges:=False
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->Text der Textmarke 3 ersetzen
On Error Resume Next
doc.Bookmarks(sTM3Name).Range.Text = sTM3Text
If Err.Number <> 0 Then
MsgBox (Textmarke-> & sTM3Name &-> in Datei & f(x) & nicht vorhanden.)
doc.Close Savechanges:=False
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->Text der Textmarke 4 ersetzen
On Error Resume Next
doc.Bookmarks(sTM4Name).Range.Text = sTM4Text
If Err.Number <> 0 Then
MsgBox (Textmarke-> & sTM4Name &-> in Datei & f(x) & nicht vorhanden.)
doc.Close Savechanges:=False
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->Datei schliessen mit Speichern
doc.Close Savechanges:=True
Next
AUFRAEUMEN:
Set doc = Nothing
End Sub
'**************************************************************************************************************
Private Function FSO_Folder_List_Files(sPfad As String, sDateiendung As String, f() As String, fCnt As Long) As Boolean
->fuer FSO muss im VB-Editor unter Extras->Verweise Microsoft Scripting Runtime angehakt sein
Dim oFso As FileSystemObject, oVerzeichnis As Folder, oFile As File
FSO_Folder_List_Files = False
->FileSystemObject für den Zugriff auf Verzeichnis-Struktur erzeugen
Set oFso = New Scripting.FileSystemObject
On Error Resume Next
->Verzeichnis lesen
Set oVerzeichnis = oFso.GetFolder(sPfad)
If oVerzeichnis Is Nothing Then MsgBox Pfad nicht vorhanden: & vbCrLf & sPfad: GoTo AUFRAEUMEN
On Error GoTo 0
->Alle Filenamen speichern
If oVerzeichnis.Files.Count > 0 Then
ReDim f(1 To oVerzeichnis.Files.Count)
fCnt = 0
For Each oFile In oVerzeichnis.Files
->Nur Dateien mit entsprechender Dateiendung bearbeiten
If (Right(oFile.Name, Len(sDateiendung)) = LCase(sDateiendung)) Then
->prüfen, ob es die eigene Datei ist. ja-> überspringen
If ThisDocument.FullName <> oFile.Path Then
->Arbeitsdateien nicht betrachten (fangen mit ~ an)
If Left(oFile.Name, 1) <> ~ Then
fCnt = fCnt + 1
f(fCnt) = oFile.Name
End If
End If
End If
Next
End If
FSO_Folder_List_Files = True
AUFRAEUMEN:
Set oFso = Nothing: Set oVerzeichnis = Nothing: Set oFile = Nothing
End Function
