Inhalte von einer PDF suchen und den Text kopieren
25.09.2019 08:54:52
einer
Hallo zusammen,
ich möchte aus 100 PDFs etwas suchen und das Ergebnis in einer Excel Tabelle einfügen.
Momentan habe ich es so gelöst, allerdings nicht ganz optimal:
Sub PDFtoExcel()
Dim i As Integer, z As Long
Dim strCMDLine As String, strTXT As String
Dim FSO As Object, objSFold As Object, objWks As Object, WshShell As Object, tmp As Object
Dim colPFiles As New Collection, colTFiles As New Collection
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objSFold = FSO.GetFolder(ThisWorkbook.Path)
Set objWks = ThisWorkbook.Sheets(1) ' Ausgabe
strCMDLine = ThisWorkbook.Path & "\Tools\pdftotext.exe -raw -layout -nopgbrk "
Const strPrefix As String * 31 = "Name"
Const intSWLen = 20
For Each tmp In objSFold.Files ' alle Dateien einlesen
If Right(tmp.Path, 4) = ".pdf" Then colPFiles.Add tmp.Path ' nur *.pdf
Next tmp
For i = 1 To colPFiles.Count
WshShell.Run (strCMDLine & Chr(34) & colPFiles.Item(i) & Chr(34)), 0, True
' Kill colPFiles.Item(i) ' pdf-Files löschen
Next
For Each tmp In objSFold.Files ' wieder alles einlesen
If Right(tmp.Path, 4) = ".txt" Then colTFiles.Add tmp.Path ' nur *.txt
Next tmp
z = objWks.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' letzte belegte Zeile ( _
Spalte A)
For i = 1 To colTFiles.Count
strTXT = FSO.OpenTextFile(colTFiles.Item(i)).ReadAll
objWks.Cells(z, 3) = colPFiles.Item(i) ' Dateiname in Spalte B
objWks.Cells(z, 4) = 1
While InStr(1, strTXT, strPrefix, vbTextCompare) > 0
strTXT = Mid(strTXT, InStr(1, strTXT, strPrefix) + Len(strPrefix) - 1)
objWks.Cells(z, 2) = Left(strTXT, intSWLen) ' Wert eintragen
z = z + 1
Wend
Kill colTFiles.Item(i) ' txt-Files löschen
Next
End Sub
Gibt es eine Möglichkeit, dass ich die Zellen in der PDF als Objekt verwenden kann und nicht als txt Datei umwandeln muss und mit Zeichen arbeiten?
Freue mich auf Hilfe von euch, hoffe es hat schon jemand so etwas gelöst!
Viele Grüße