14.08.2023, 15:01
Moin, 
wohl öfters eine Frage in den Foren. Wie kann ich PDF-Dateien auslesen. Im folgenden mit Word und dem Open Source Projekt "Xpdf" gemacht:
Bitte die ReadMeFirst.txt erst lesen. Dort stehen ein paar Stolperfallen.
Hier der Code aus Modul1 (mit Word):
Dann der Code aus Modul2 (mit Xpdf):
Nachfolgend noch die ZIP-Datei.
wohl öfters eine Frage in den Foren. Wie kann ich PDF-Dateien auslesen. Im folgenden mit Word und dem Open Source Projekt "Xpdf" gemacht:
Bitte die ReadMeFirst.txt erst lesen. Dort stehen ein paar Stolperfallen.
Hier der Code aus Modul1 (mit Word):
Code:
Option Explicit
' Wenn Word nicht offen ist wird diese Variable auf True
' gesetzt und Word am Ende wieder geschlossen
' War Word schon offen, beleibt es das auch
Dim blnTMP As Boolean
'################################################################################################
' Module : Modul1
' Procedure : Main_1
' Author : Case (Ralf Stolzenburg)
' Date : 13.08.2023
' Purpose : Aus PDF-Dateien etwas nach Excel auslesen - PDF-Dokumente danach umbenennen
' Purpose : Werte werden in Excel eingelesen - inklusive alter und neuer Dateiname
' Note : Funktioniert erst ab Office/Word/Excel 2013!!!!!!!!!!
' Purpose : Veröffentlicht auf CEF "https://www.clever-excel-forum.de/index.php" am 13.08.2023
' Purpose : In der Rubrik "Beispiele und Workshops" unter "mit VBA"
'################################################################################################
Public Sub Main_1()
' Dimensionieren der Variablen
Dim objDocument As Object
Dim strTrenn() As String
Dim strDatei As String
Dim strTMP1 As String
Dim strTMP As String
' Wenn benötigt nächste Zeilen auskommentieren
'Dim objFSO As Object
'Dim varDir As Object
Dim strDir As String
Dim objApp As Object
Dim lngCalc As Long
Dim lngTMP As Long
Dim lngRef As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
' Die Excelapplikation wird ruhig gestellt
With Application
' Keine Bildschirmaktualisiereung
.ScreenUpdating = False
' Falls es ein Ereignismakro gibt (z. B. Worksheet_Change) wir es NICHT aufgerufen
.EnableEvents = False
' Die eingstellte Formelkalkulation wird abgerufen
lngCalc = .Calculation
' Zellbezüge, Zeilen- und Spaltenköpfe, Z1S1- oder A1-Bezugsart wird abgerufen
lngRef = Application.ReferenceStyle
' Die Bezugsart wird auf A1 gestellt - und am Ende wieder auf den ausgelesenen
' Wert zurückgestellt
Application.ReferenceStyle = xlA1
' Die Formelkalkulation wird auf "Manuell" gestellt - und am Ende
' wieder auf den ausgelesenen Wert zurückgestellt
.Calculation = xlCalculationManual
' Fehler werden nicht angezeigt/beachtet
' https://learn.microsoft.com/de-de/office/vba/api/excel.application.displayalerts
' Hinweise in der obigen Webseite bitte genau durchlesen
.DisplayAlerts = False
End With
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
'Set objFSO = CreateObject("Scripting.FileSystemObject")
' Wenn Du einen Ordnerauswahldialog möchtest
'Set objShell = CreateObject("Shell.Application")
'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
'If Not varDir Is Nothing Then
'strDir = varDir.Self.Path
' Datei im gleichen Ordner wie Auswertungsdateien
strDir = ThisWorkbook.Path
'strDir = "C:\Temp\Los\" ' Fester Pfad
strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
' Die erste PDF-Datei im angegebenen Verzeichnis raussuchen
strDatei = Dir$(strDir & "*.pdf", vbDirectory)
' Schleife bis alle PDF-Dateien abgearbeitet sind (Kopfgesteuerte Schleife)
Do While strDatei <> ""
' Prüfen ob schon eine Datei mit mehr als 5 Unterstrichen (_) vorhanden ist
' Die ist dann schon ausgelesen und umbenannt
' Hast du solche Dateien im Ursprung, dann musst du
' ein anderes Kriterium für die Prüfung suchen
If Not Len(strDatei) - Len(Replace(strDatei, "_", "")) > 5 Then
' Word- Pdf-Dokument öffnen - ab Word 2013!!!!!
Set objDocument = objApp.Documents.Open(strDir & strDatei)
' Text an Leerzeichen trennen/aufsplitten
strTrenn = Split(objDocument.Range, " ")
' Schleife über das Array von Anfang bis Ende
For lngTMP = LBound(strTrenn) To UBound(strTrenn)
' Wenn das Wort Rechnung gefunden wird...
If strTrenn(lngTMP) Like "*Rechn*" Then
' ... schreibe den nächsten Wert in Variable strTMP
strTMP = Trim(strTrenn(lngTMP + 1))
' Oder wenn das Wort Kunde gefunden wird...
ElseIf strTrenn(lngTMP) Like "*Kund*" Then
' ... schreibe den nächsten Wert in Variable strTMP1
strTMP1 = Trim(strTrenn(lngTMP + 1))
End If
Next lngTMP
' Word- Pdf-Dokument ohne speichern schliessen
objDocument.Close False
' Schreibe die Variable strTMP1 in Tabelle1 Zelle Ax
' Schreibe die Variable strTMP in Tabelle1 Zelle Bx
' Schreibe die Variable strDatei (alter Dateiname) in Tabelle1 Zelle Cx
' Schreibe den neuen Dateinamen in Tabelle1 Zelle Dx
With Tabelle1
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strTMP1
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strTMP
.Range("C" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strDatei
.Range("D" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strTMP & _
"_" & strTMP1 & Format(Now, "_dd_mm_yyyy_hh_mm_ss") & ".pdf"
' Datei umbenennen mit Datum und Zeit am Ende
' Für Datum und Zeit siehe - <br/>[i]Dateiupload bitte im Forum! So geht es:<a href="thread-326.html"> Klick mich!</a>[/i]<br/>
Name strDir & strDatei As strDir & _
.Range("D" & .Rows.Count).End(xlUp).Value
End With
' Array und Variablen leeren
Erase strTrenn
strTMP1 = ""
strTMP = ""
' Die nächste Datei nehmen und Objektvariable auf Nothing setzen
strDatei = Dir$()
Set objDocument = Nothing
' Wenn eine Datei mit mehr als 5 Unterstrichen vorhanden ist nimm die nächste
Else
strDatei = Dir$()
End If
Loop
Else
MsgBox "Applikation nicht installiert!"
End If
'End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen leeren
' Falls du das "FileSystemObject" genommen hast
'Set objShell = Nothing
'Set objFSO = Nothing
'Set varDir = Nothing
Set objDocument = Nothing
Set objApp = Nothing
' Die Applikation aufwecken - siehe oben!!!!
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
Application.ReferenceStyle = lngRef
.DisplayAlerts = True
.CutCopyMode = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End Sub
'################################################################################################
' Module : Modul1
' Procedure : OffApp
' Author : Case (Ralf Stolzenburg)
' Date : 13.08.2023
' Purpose : Start Applikation...
' Purpose : Veröffentlicht auf CEF "https://www.clever-excel-forum.de/index.php" am 13.08.2023
' Purpose : In der Rubrik "Beispiele und Workshops" unter "mit VBA"
'################################################################################################
Private Function OffApp(ByVal strApp As String, Optional blnVisible As Boolean = True) 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")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End FunctionDann der Code aus Modul2 (mit Xpdf):
Code:
Option Explicit
'################################################################################################
' Module : Modul2
' Procedure : Main_2
' Author : Case (Ralf Stolzenburg)
' Date : 13.08.2023
' Purpose : Aus PDF-Dateien etwas nach Excel auslesen
' Purpose : Werte werden in Excel eingelesen - inklusive Dateiname
' Note : Mit dem Open Source Projekt Xpdf
' Purpose : Veröffentlicht auf CEF "https://www.clever-excel-forum.de/index.php" am 13.08.2023
' Purpose : In der Rubrik "Beispiele und Workshops" unter "mit VBA"
'################################################################################################
Public Sub Main_2()
' Dimensionieren der Variablen
Dim strDatei As String
Dim varArr As Variant
Dim strTMP1 As String
Dim strTMP As String
' Wenn benötigt nächste Zeile auskommentieren
'Dim objFSO As Object
'Dim varDir As Object
Dim strDir As String
Dim lngCalc As Long
Dim lngTMP As Long
Dim lngRef As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
On Error GoTo Fin
' Die Excelapplikation wird ruhig gestellt
With Application
' Keine Bildschirmaktualisiereung
.ScreenUpdating = False
' Falls es ein Ereignismakro gibt (z. B. Worksheet_Change) wir es NICHT aufgerufen
.EnableEvents = False
' Die eingstellte Formelkalkulation wird abgerufen
lngCalc = .Calculation
' Zellbezüge, Zeilen- und Spaltenköpfe, Z1S1- oder A1-Bezugsart wird abgerufen
lngRef = Application.ReferenceStyle
' Die Bezugsart wird auf A1 gestellt - und am Ende wieder auf den ausgelesenen
' Wert zurückgestellt
Application.ReferenceStyle = xlA1
' Die Formelkalkulation wird auf "Manuell" gestellt - und am Ende
' wieder auf den ausgelesenen Wert zurückgestellt
.Calculation = xlCalculationManual
' Fehler werden nicht angezeigt/beachtet
' https://learn.microsoft.com/de-de/office/vba/api/excel.application.displayalerts
' Hinweise in der obigen Webseite bitte genau durchlesen
.DisplayAlerts = False
End With
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
'Set objFSO = CreateObject("Scripting.FileSystemObject")
' Wenn Du einen Ordnerauswahldialog möchtest
'Set objShell = CreateObject("Shell.Application")
'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
'If Not varDir Is Nothing Then
'strDir = varDir.Self.Path
' Datei im gleichen Ordner wie Auswertungsdateien
strDir = ThisWorkbook.Path
'strDir = "C:\Temp\Los\" ' Fester Pfad
strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
' Die erste PDF-Datei im angegebenen Verzeichnis raussuchen
strDatei = Dir$(strDir & "*.pdf", vbDirectory)
' Schleife bis alle PDF-Dateien abgearbeitet sind (Kopfgesteuerte Schleife)
Do While strDatei <> ""
' Prüfen ob schon eine Datei mit mehr als 5 Unterstrichen (_) vorhanden ist
' Die ist dann schon ausgelesen und umbenannt
' Hast du solche Dateien im Ursprung, dann musst du
' ein anderes Kriterium für die Prüfung suchen
If Not Len(strDatei) - Len(Replace(strDatei, "_", "")) > 5 Then
' Hier wird das Array varArr über Filter (nach Doppelpunkt)
' Split (die Ausgabe von Wscript.Shell über Exec und schliesslich
' StOut.ReadAll am Carriage Return - Linefeed Kombination) getrennt
'###############################################################################
' WENN das Array leer bleibt, BEACHTE die Hinweise in der ReadMeFirst.txt
' Hinweis "pdftotext.exe" nicht im richtigen Verzeichnis, oder LEERZEICHEN im
' Pfad- oder Dateiname - die müssen dann maskiert werden.
'###############################################################################
varArr = Filter(Split(CreateObject("Wscript.Shell").Exec("cmd /c " & _
ThisWorkbook.Path & Application.PathSeparator & "pdftotext.exe -raw " & _
strDir & strDatei & " -").StdOut.ReadAll, vbCrLf), ":")
' Schleife über das Array von Anfang bis Ende
For lngTMP = LBound(varArr) To UBound(varArr)
' Wenn das Wort Rechnung gefunden wird...
If varArr(lngTMP) Like "*Rechn*" Then
' ... schreibe den nächsten Wert nach Leerzeichen in Variable strTMP
strTMP = Mid(varArr(lngTMP), InStr(varArr(lngTMP), " ") + 1)
'Mid(Text, Instr(Text, "_") + 1)
' Oder wenn das Wort Kunde gefunden wird...
ElseIf varArr(lngTMP) Like "*Kund*" Then
' ... schreibe den nächsten Wert nach Leerzeichen in Variable strTMP1
strTMP1 = Mid(varArr(lngTMP), InStr(varArr(lngTMP), " ") + 1)
End If
Next lngTMP
' Schreibe die Variable strTMP1 in Tabelle2 Zelle Gx
' Schreibe die Variable strTMP in Tabelle2 Zelle Hx
' Schreibe die Variable strDatei in Tabelle2 Zelle Ix
With Tabelle2
.Range("G" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strTMP1
.Range("H" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strTMP
.Range("I" & .Rows.Count).End(xlUp).Offset(1, 0).Value = strDatei
End With
' Array und Variablen leeren
Erase varArr
strTMP1 = ""
strTMP = ""
' Die nächste Datei nehmen
strDatei = Dir$()
' Wenn eine Datei mit mehr als 5 Unterstrichen vorhanden ist nimm die nächste
Else
strDatei = Dir$()
End If
Loop
'End If
Fin:
' Objektvariablen leeren
' Falls du das "FileSystemObject" genommen hast
'Set objShell = Nothing
'Set objFSO = Nothing
'Set varDir = Nothing
' Die Applikation aufwecken - siehe oben!!!!
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
Application.ReferenceStyle = lngRef
.DisplayAlerts = True
.CutCopyMode = True
End With
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End SubNachfolgend noch die ZIP-Datei.
![[-]](https://www.clever-excel-forum.de/images/collapse.png)