Word Makro Kopfzeile mit Namen und Datum
Hallo
Ich habe ein Makro erstellt, dass in einem Ordner allen Word-Dokumenten eine Kopfzeile mit Datumsfeld und Namen hinzufügt.
Do sieht der Code aus:
Sub KopfFussZeile2()
'
' KopfFussZeile2 Makro
'
Const pathDocs = "D:\"
Const wdHeaderFooterEvenPages = 3
Const wdHeaderFooterFirstPage = 2
Const wdHeaderFooterPrimary = 1
Dim counter, strFailureDocs
counter = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set objWord = CreateObject("Word.Application")
'Wenn der Vorgang nicht sichtbar ausgeführt werden soll folgende Zeile auf 'False' setzen
objWord.Visible = True
objWord.DisplayAlerts = False
For Each file In fso.GetFolder(pathDocs).Files
If LCase(Right(file.Name, 4)) = "docx" Or LCase(Right(file.Name, 3)) = "doc" Or LCase(Right(file.Name, 3)) = "dot" Or LCase(Right(file.Name, 4)) = "dotx" Or LCase(Right(file.Name, 4)) = "dotm" Then
On Error Resume Next
'Öffne Dokument
Set doc = objWord.Documents.Open(file.Path)
If Err.Number = 0 Then
'Zähle bearbeitete Dokumente
counter = counter + 1
For Each Section In doc.Sections
'Setze den Inhalt der folgenden Fußzeilen gleich der Fußzeile der ersten Seite des Abschnitts
Section.Headers(wdHeaderFooterPrimary).Range.InsertDateTime DateTimeFormat:="dd.MM.yyyy", InsertAsField:=True, DateLanguage:=wdSwissGerman, CalendarType:=wdCalendarWestern
Section.Headers(wdHeaderFooterPrimary).Range.Text = vbTab & vbTab & "gewünschter Text "
Next
'Speichere und schließe Dokument
doc.Save
doc.Close True
Else
strFailureDocs = strFailureDocs & file.Path & vbNewLine
Err.Clear
End If
End If
Next
objWord.DisplayAlerts = False
objWord.Quit True
MsgBox counter & " Dokumente bearbeitet!"
If strFailureDocs <> "" Then
MsgBox "Folgende Dokumente wurden wegen eines Fehlers beim Öffnen nicht bearbeitet: " & vbNewLine & strFailureDocs, vbExclamation
End If
End Sub
Nun wird aber das Datum vom Namen überschrieben. Kann man dies irgenwie umgehen?
Besten Dank und Gruss
Hanspeter92
Ich habe ein Makro erstellt, dass in einem Ordner allen Word-Dokumenten eine Kopfzeile mit Datumsfeld und Namen hinzufügt.
Do sieht der Code aus:
Sub KopfFussZeile2()
'
' KopfFussZeile2 Makro
'
Const pathDocs = "D:\"
Const wdHeaderFooterEvenPages = 3
Const wdHeaderFooterFirstPage = 2
Const wdHeaderFooterPrimary = 1
Dim counter, strFailureDocs
counter = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set objWord = CreateObject("Word.Application")
'Wenn der Vorgang nicht sichtbar ausgeführt werden soll folgende Zeile auf 'False' setzen
objWord.Visible = True
objWord.DisplayAlerts = False
For Each file In fso.GetFolder(pathDocs).Files
If LCase(Right(file.Name, 4)) = "docx" Or LCase(Right(file.Name, 3)) = "doc" Or LCase(Right(file.Name, 3)) = "dot" Or LCase(Right(file.Name, 4)) = "dotx" Or LCase(Right(file.Name, 4)) = "dotm" Then
On Error Resume Next
'Öffne Dokument
Set doc = objWord.Documents.Open(file.Path)
If Err.Number = 0 Then
'Zähle bearbeitete Dokumente
counter = counter + 1
For Each Section In doc.Sections
'Setze den Inhalt der folgenden Fußzeilen gleich der Fußzeile der ersten Seite des Abschnitts
Section.Headers(wdHeaderFooterPrimary).Range.InsertDateTime DateTimeFormat:="dd.MM.yyyy", InsertAsField:=True, DateLanguage:=wdSwissGerman, CalendarType:=wdCalendarWestern
Section.Headers(wdHeaderFooterPrimary).Range.Text = vbTab & vbTab & "gewünschter Text "
Next
'Speichere und schließe Dokument
doc.Save
doc.Close True
Else
strFailureDocs = strFailureDocs & file.Path & vbNewLine
Err.Clear
End If
End If
Next
objWord.DisplayAlerts = False
objWord.Quit True
MsgBox counter & " Dokumente bearbeitet!"
If strFailureDocs <> "" Then
MsgBox "Folgende Dokumente wurden wegen eines Fehlers beim Öffnen nicht bearbeitet: " & vbNewLine & strFailureDocs, vbExclamation
End If
End Sub
Nun wird aber das Datum vom Namen überschrieben. Kann man dies irgenwie umgehen?
Besten Dank und Gruss
Hanspeter92
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 274223
Url: https://administrator.de/forum/word-makro-kopfzeile-mit-namen-und-datum-274223.html
Ausgedruckt am: 07.05.2025 um 20:05 Uhr
1 Kommentar

Dein Fehler liegt hier:
Damit überschreibst du den Header.
Damit nicht mehr:
Gruß jodel32
Section.Headers(wdHeaderFooterPrimary).Range.Text = vbTab & vbTab & "gewünschter Text "
Damit nicht mehr:
Section.Headers(wdHeaderFooterPrimary).Range.Text = Section.Headers(wdHeaderFooterPrimary).Range.Text & vbTab & vbTab & "gewünschter Text "