[VBA] Fusszeile aus einer Word Datei auslesen

[jules]

Hallo zusammen,

ich möchte eine Word Datei öffnen - langfristig mehrere in einem Ordner -, dort die Fußzeile(n) auslesen und in Excel eintragen lassen.
Hier ein Beispiel Footer: siehe Anhang

Beispiel für die Excel:

	A	B	C	D
1	Dateiname	Zeile1	Zeile2	Zeile3
2	1.doc	Schwede GmbH, Altermarkt 10…	Geschäftsführer J…	Bankverbindung…

Verwendete Systemkomponenten: [Windows (32-bit) NT :.00] MS Excel 2016

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

kann jemand bis hier her helfen?

Im zweiten Schritt möchte ich gerne den Inhalt im Footer der Word (Zeile1) automatisch ändern. 

Danke und Gruss

[Case]

Hallo, :19:

Code:

Option Explicit
Const strPath As String = "C:\Temp\Word\"
Public Sub Main_1()
    Dim objWDApp As Object
    Dim strFileName As String
    Set objWDApp = CreateObject("Word.Application")
    objWDApp.WordBasic.DisableAutoMacros 1
    strFileName = Dir(strPath & "*.doc")
    While strFileName <> ""
        objWDApp.Documents.Open strPath & strFileName
        With objWDApp.ActiveDocument.Sections(1)
            Debug.Print .Headers(1).Range.Text
            Debug.Print .Footers(1).Range.Text
        End With
        objWDApp.ActiveDocument.Close False
        strFileName = Dir
    Wend
    objWDApp.Quit False
    Set objWDApp = Nothing
End Sub
Public Sub Main_2()
    Dim objFooter As Object
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim objRange As Object
    On Error GoTo Fin
    Set objWDApp = OffApp("Word")
    If Not objWDApp Is Nothing Then
        'Set objWDDoc = objWDApp.Documents.Open("C:\Temp\Dok1.doc")
        Set objWDDoc = objWDApp.Documents.Add
        Set objFooter = objWDDoc.Sections(1).Footers(1)
        With objFooter.Range
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objFooter.Range.Text = "Seite "
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.Fields.Add objRange, -1, "PAGE"
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.Text = " von "
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.Fields.Add objRange, -1, "NUMPAGES"
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.Text = vbTab
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.InsertDateTime DateTimeFormat:="dd.MM.yyyy"
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.Text = vbTab
            Set objRange = .Characters(Len(objFooter.Range.Text))
            objRange.Fields.Add objRange, -1, "AUTHOR"
        End With
    End If
Fin:
    Set objRange = Nothing
    Set objFooter = Nothing
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

"Main_1" öffnet jede Worddatei in "C:\Temp\Word\" und gibt dir im Direktfenster die Fußzeile aus.

"Main_2" schreibt in ein neues Dokument in die Fußzeile.

Mach was draus. :21:

[jules]

Hi Case,

danke erstmal.

- wie kann ich die 3 unterschiedlichen Zeilen im Footer einzelnd ansprechen?


Gruss

[Case]

Hallo, :19:

mit der Split-Funktion. :21:

[jules]

Mit Split funnktioniert es, allerdings bekomme ich dann nur eine Zeile bis zum break ?
Cells(i, 2).Value = Split(Outcome, vbCr)


Interessant wäre es noch, ob er vielleicht auch Subfolders mit auslesen kann bzw. die Dateien?
Const strPath As String = "C:\Temp\"

[Case]

Hallo, :19:

hier mal ein Grundgerüst, wie man auch Unterordner ausliest: :21:

Code:

Option Explicit
' Suchmuster gegebenenfalls anpassen
Const strEX As String = "*.xls*"
Public Sub Files_Read_1234()
    Dim lngCalc As Long
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien
    ' strDir = ThisWorkbook.Path & "\"
    ' Fester Ordner vorgegeben
    strDir = "C:\Temp\Test\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.getfolder(strDir)
    'dirInfo objDir, strEX, True ' Mit Unterordner
    dirInfo objDir, strEX ' Ohne Unterordner
Fin:
    With Application
        ' Bei Bedarf
        '.Goto (ThisWorkbook.Worksheets(1).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName Then
            If varTMP.Name <> ThisWorkbook.Name Then
                If Left(varTMP.Name, 1) <> "~" Then
                    ' Hier jetzt der Code um mit der Datei etwas zu machen
                    ' z. B. Öffnen, etwas auslesen oder was auch immer...
                    ' Im folgenden werden nur ein paar Informationen
                    ' im Direktfenster (VBE - STRG+G) ausgegeben
                    ' Diese Zeilen mit Debug.Print können natürlich
                    ' gelöscht bzw. auskommentiert werden
                    Debug.Print "Pfad: " & varTMP.Path
                    Debug.Print "Name: " & varTMP.Name
                    Debug.Print "Erstelldatum: " & varTMP.DateCreated
                    Debug.Print "Letzter Zugriff: " & varTMP.DateLastAccessed
                    Debug.Print "Letzte Änderung: " & varTMP.DateLastModified
                    Debug.Print "Größe in Byte: " & varTMP.Size
                    Debug.Print "Type: " & varTMP.Type
                    Debug.Print "Anzahl: " & varTMP.ParentFolder.Files.Count
                    Debug.Print vbCrLf
                End If
            End If
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

Man kann auch "Dir" rekursiv machen - ist aber aufwändig. :21:

[snb]

Man könnte auch VBA verwenden:
Dann reicht diese Code:

Code:

Sub M_snb()
  With GetObject("G:\OF\voettekst.docm")
    Cells(2, 2).Resize(, 3) = Split(.storyranges(9), vbCr)
    .Close 0
  End With
End Sub

Wenn subfolder benötigt sind:

Code:

Sub M_snb()
   sn=split(createobject("wscript.shell").exec("cmd /c Dir G:\OF\*.docx /b /s").stdout.readall,vbcrlf)

  for j=0 ro Ubound(sn)-1
    With GetObject(sn(j))
      Cells(rows.count, 2).offset(1).Resize(, 3) = Split(.storyranges(9), vbCr)
      .Close 0
    End With
  Next
End Sub