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
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:
Hi Case,
danke erstmal.
- wie kann ich die 3 unterschiedlichen Zeilen im Footer einzelnd ansprechen?
Gruss
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\"
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:
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