VBA-Beispiel 058
mail schreiben
mail schreiben

Excel ändert Kopf- und Fusszeilen aller Worddateien in einem Verzeichnis
Ändert Kopf- und Fusszeilen aller Worddateien in einem Verzeichnis (einschließlich aller Worddateien in den Unterordnern).

Achtung: die Änderungen der Worddateien werden ohne Rückfrage durchgeführt.

Die Pfadangabe steht in Zelle B2,
Eintrag für die Kopfzeile in Zelle B3,
Eintrag für die Fusszeile in Zelle B4.
Option Explicit
'erfordert Verweis auf
'Microsoft Word 11.0 Object Library

Sub Kopf_und_Fusszeilen_in_Word_aendern()
Dim objWord As Object, Kopfzeile As Object, Fusszeile As Object
Dim Pfad As String
Dim i As Integer

On Error GoTo Fehler

Pfad = Cells(2, 2)

If Dir(Pfad) = "" Then
  MsgBox "Pfad existiert nicht", , "Abbruch"
  Exit Sub
End If

Set objWord = CreateObject("Word.Application")
'objWord.Visible = True

With Application.FileSearch
.NewSearch
.LookIn = Pfad
.Filename = "*.doc"
.SearchSubFolders = True  
If .Execute(SortBy:=msoSortByFileName, sortorder:=msoSortOrderAscending) > 0 Then
    For i = 1 To .FoundFiles.Count
      objWord.Documents.Open .FoundFiles(i)  

      Set Kopfzeile = objWord.ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
      Kopfzeile.Text = Cells(3, 2)
      Set Fusszeile = objWord.ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
      Fusszeile.Text = Cells(4, 2)

      objWord.ActiveDocument.Save
      objWord.ActiveDocument.Close
    Next i
End If
End With

objWord.Application.Quit
Set objWord = Nothing
Set Kopfzeile = Nothing
Set Fusszeile = Nothing
MsgBox Application.FileSearch.FoundFiles.Count & " Word-Dateien bearbeitet", , "fertig"

Exit Sub

Fehler:

objWord.Application.Quit
Set objWord = Nothing
Set Kopfzeile = Nothing
Set Fusszeile = Nothing

    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"

End Sub
Download:   vba058.zip
relevante Links:

top