Hente bundtekst fra en liste af worddokumenter

Skal dokumentnavn også lagres i Excel-arket?

Det ville være dejligt, men er ikke en forudsætning.

Rem Version 1 - henter sidefod fra Word-dokumenter i udvalgt mappe
Rem ==============================================================
Rem Overskrift i række 1 A: DocumentNavn B:SideFod
Rem ==============================================
Rem Referencen Microsoft Word 11.0 Object Library tilføjet (VBA-vindue/Tools/References)
Rem ======================================================
Dim filSti
Dim celleA1, samlRæk
Dim docFil
Sub samlingAfFiler()
Rem find første ledige række
    samlRæk = ActiveCell.SpecialCells(xlLastCell).Row
    If samlRæk >= 1 Then
        samlRæk = samlRæk + 1
    End If
   
Rem udpeg en fil fra den ønske mappe
    filSti = isolerSti(Application.GetOpenFilename)
       
    Application.ScreenUpdating = False
    traverserFilMappe filSti
   
    ActiveWorkbook.Sheets(1).Activate
    ActiveSheet.Columns.AutoFit
   
Rem Gem xls-mappen
    ActiveWorkbook.Save
   
    Application.ScreenUpdating = True
   
    MsgBox ("Gennemløb er udført")
End Sub
Private Function isolerSti(fuldSti)
    For p = Len(fuldSti) To 1 Step -1
        If Mid(fuldSti, p, 1) = "\" Then
            isolerSti = Left(fuldSti, p)
            Exit Function
        End If
    Next p
End Function
Private Sub traverserFilMappe(mappe)
Dim sideFod, filNavn
Dim fs, f, fil, fc
On Error GoTo fejl
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(mappe)
    Set fc = f.Files

Rem behandling af word-filer i mappe
    For Each fil In fc
        filNavn = fil.Name
        If Right(LCase(filNavn), 4) = ".doc" Then
            Set docFil = CreateObject("Word.Application")
            With docFil
                .Documents.Open Filename:=mappe + filNavn
                sideFod = hentSideFod
            End With
        End If
       
        docFil.Application.Quit
        Set docFil = Nothing

Rem Opdater i samling
        With ActiveWorkbook
            .Sheets(1).Activate
            With ActiveSheet
                .Cells(samlRæk, 1) = filNavn
                .Cells(samlRæk, 2) = sideFod
            End With
            samlRæk = samlRæk + 1
        End With
    Next
    Exit Sub

fejl:
    docFil.Application.Quit
    Set docFil = Nothing
    MsgBox ("Fejl erkendt - kontakt udvikler")
End Sub
Private Function hentSideFod()
Dim p
    With docFil.ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
        If .Range.Text <> vbCr Then
            hentSideFod = Left(.Range.Text, Len(.Range.Text) - 1)
Rem Test om sidenr - afskær dette
            p = InStr(hentSideFod, Chr(13))
            If p <= 3 Then
                hentSideFod = Mid(hentSideFod, p + 1)
            End If
        Else
            hentSideFod = """"
        End If
    End With
End Function

PS: Når Åbn-dialogboksen vises - udpeg blot eet af dokumenterne - for at sti kan "fanges" - alle dokumenter bliver behandlet.

Et par, måske irrelevante, kommentarer til Supertekst

1) ser godt ud og løser problemet.

2) du opretter Word-objektet for hver fil = koster lidt tid, ihvertfald på min sløve pc :-)

3) du tager ikke højde for at eventuel kode i de forskellige word-dokumenter, og evt. tilhørende skabeloner bliver afviklet.

Vedr. 3, så har jeg oftest følgende 2 linier med når det drejer sig om at create et wordobject for at åbne .doc-filer:
  <object>.AutomationSecurity = msoAutomationSecurityForceDisable
'(hvor: Const msoAutomationSecurityForceDisable = 3)
  <object>.WordBasic.disableautomacros


Ovenstående var ikke ment som kritik, så optag det venligst som lidt ekstra input, takker :-)

Enhver kommentar er velkommen...