PDF-Dateien auslesen - dann umbenennen...

OptionExplicit
' 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
DimblnTMPAsBoolean
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.05.2019
' Purpose   : Aus PDF-Dateien etwas auslesen - Dokumente danach umbenennen
' Note      : Funktioniert erst ab Word 2013!!!!!!!!!!
'--------------------------------------------------------------------------
PublicSubMain()
' Dimensionieren der Variablen
DimobjDocumentAsObject
DimstrTrenn()AsString
DimstrDateiAsString
DimstrTMP1AsString
DimstrTMPAsString
DimobjFSOAsObject
DimobjDirAsObject
DimstrDirAsString
DimobjAppAsObject
DimlngCalcAsLong
DimlngTMPAsLong
DimlngRefAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt
WithApplication
.ScreenUpdating=False
.EnableEvents=False
lngCalc=.Calculation
lngRef=Application.ReferenceStyle
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
SetobjFSO=CreateObject("Scripting.FileSystemObject")
' Wenn Du einen Ordnerauswahldialog möchtest
'Set objShell = CreateObject("Shell.Application")
'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
'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)
SetobjApp=OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
IfNotobjAppIsNothingThen
strDatei=Dir$(strDir&"*.pdf",vbDirectory)
DoWhilestrDatei<>""
' Word- Pdf-Dokument öffnen - ab Word 2013!!!!!
SetobjDocument=objApp.Documents.Open_
(strDir&strDatei)
' Text an Leerzeichen trennen/aufsplitten
strTrenn=Split(objDocument.Range," ")
' Schleife über das Array von Anfang bis Ende
ForlngTMP=LBound(strTrenn)ToUBound(strTrenn)
' Wenn das Wort Rechnung gefunden wird...
IfstrTrenn(lngTMP)Like"*Rechn*"Then
' ... schreibe den nächsten Wert in Variable strTMP
strTMP=Trim(strTrenn(lngTMP+1))
' Oder wenn das Wort Kunde gefunden wird...
ElseIfstrTrenn(lngTMP)Like"*Kund*"Then
' ... schreibe den nächsten Wert in Variable strTMP1
strTMP1=Trim(strTrenn(lngTMP+1))
EndIf
NextlngTMP
' Word- Pdf-Dokument ohne speichern schlissen
objDocument.CloseFalse
' Datei umbenennen mit Datum und Zeit am Ende
NamestrDir&strDateiAsstrDir&strTMP&"_"&strTMP1&_
Format(Now,"_DD_MM_YYYY_hh_mm_ss")&".pdf"
' Array und Variablen leeren
ErasestrTrenn
strTMP1=""
strTMP=""
' Die nächste Datei nehmen
strDatei=Dir$()
SetobjDocument=Nothing
Loop
Else
MsgBox"Applikation nicht installiert!"
EndIf
Fin:
IfNotobjAppIsNothingThen
IfblnTMP=TrueThen
objApp.Quit
blnTMP=False
EndIf
EndIf
' Objektvariablen leeren
SetobjDocument=Nothing
SetobjApp=Nothing
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=lngCalc
Application.ReferenceStyle=lngRef
.DisplayAlerts=True
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.05.2019
' Purpose   : Start Applikation...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
DimobjAppAsObject
OnErrorResumeNext
SetobjApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjApp=CreateObject(strApp&".Application")
blnTMP=True
IfblnVisible=TrueThen
OnErrorResumeNext
objApp.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objApp
SetobjApp=Nothing
EndFunction