Einzelne Begriffe aus PDF in Excel per VBA auslesen

 

Lieferanten-Nr. Bearbeiter/in:    Telefon:      Fax:           E-mail:

12345           xxxx, xxxxxxxx	  01234-123456  01234-234567   xxxx@xxxxxxxx.de

vom: 24.03.15

BESTELLUNG   Nr. 683275

Versandanschrift:                  Firma XXXXXX


Hiermit bestellen wir:

Pos Artikel                             Menge              ME    Einzelpreis

01     X12345678                                      5 Stück      123,45

       Artikel blablabla

       Stand: 2010

       Liefertermin: 20.04.15

02     X23456789                                      5 Stück      123,45

       Artikel blablablablabla

       Stand: 2010

       Liefertermin: 11.05.15


Firma XXXXXX  Telefon: 01234-123456

XXXXXXstraße 1, D-XXXX XXXXXXXX

Bank 123 AG		           Bank 1234

1 123 456 (BLZ 123 456 78)         123 456 78 (BLZ 123 456 78)

SWIFT No. blablablabl              SWIFT No. blablablabl

IBAN DE12345678912345678912        IBAN DE12345678912345678912

Public Sub Termine_von_Excel_nach_Outlook_exportieren()
Dim OutApp As Object, apptOutApp As Object

'Termine aus Excel-Sheet lesen  
Range("C2").Select  
Do Until ActiveCell.Value = ""  
  Set OutApp = CreateObject("Outlook.Application")  
  Set apptOutApp = OutApp.CreateItem(1)
  With apptOutApp
    'Termine werden aus den Zellen gelesen  
    .Start = Format(ActiveCell.Value, "dd.mm.yyyy")  
    .Subject = ActiveCell.Offset(0, -2).Value
    'Zusätzlicher Text  
    .Body = ActiveCell.Offset(0, -1).Value & " Stück" & ", " & "Firma XXX"  
    'Ort  
    .Location = ActiveCell.Offset(0, -1).Value & " Stück" & ", " & "Firma XXX"  
    'Ganztägig  
    .AllDayEvent = True
    'Termin speichern  
    .Save
  End With

  'Nächste Zeile auswählen  
  ActiveCell.Offset(1, 0).Select
  Set apptOutApp = Nothing
  Set OutApp = Nothing
Loop
End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim varEntryIDs
Dim objItem
Dim i As Integer
Dim strCMDLine As String, strTempPath As String, strTargetPath As String
Dim att As Attachment
Dim fso As Object, objShell As Object, regex As Object
Dim colPFiles As New Collection, colTFiles As New Collection
        
strCMDLine = "C:\Users\Name\Documents\Test_Makro\pdftotext.exe"" -table -layout -nopgbrk "  
strTargetPath = "C:\Users\Name\Documents\Test_Makro\Ablage"  
    
Set fso = CreateObject("Scripting.FileSystemObject")  
Set objShell = CreateObject("WScript.Shell")  
Set regex = CreateObject("vbscript.regexp")  
regex.MultiLine = True
    
varEntryIDs = Split(EntryIDCollection, ",")  
For i = 0 To UBound(varEntryIDs)
    Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
    If objItem.Class = olMail Then
        For Each att In objItem.Attachments
            ' Wenn Attachment ein PDF ist dann ...  
        If LCase(fso.GetExtensionName(att.FileName)) = "pdf" Then  
            ' Temporäres Zielverzeichnis des Attachments festlegen  
            strTempPath = Environ("Temp") & "\" & att.FileName  
            ' Zielpfad und Dateiname für die Ziel-Datei festlegen  
            strTargetPath = strTargetPath & "\" & fso.GetBasename(att.FileName) & "_" & Format(Now(), "dd.mm.yyyy") & ".pdf"  
            ' Speichere das Attachment im TEMP-Verzeichnis  
            att.SaveAsFile strTempPath
            ' konvertiere das Attachment in txt  
            objShell.Run strCMDLine & """" & att & """", 0, True  
            ' txt-Datei einlesen  
            ?????????????????????????
            arrValues = GetMatchValues(FSO.OpenTextFile(???????????????.ReadAll)
        End If
        Next
    End If
Next
End Sub
' ------------------------------------------------------  
Public Function GetMatchValues(ByRef strText) As Variant
Dim objMatchesA As Object, objMatchesM As Object, objMatchesT As Object
Dim arrValues As Variant, i As Long
    
With CreateObject("VBScript.RegExp")  
    .Global = True
    .MultiLine = True
    .Pattern = "^\d\d\s+M{1}\d+.*\n\s+([^\r]+)"  'Artikel  
    Set objMatchesA = .Execute(strText)
    .Pattern = "\s+(\d+)\s+Stück"           'Menge  
    Set objMatchesM = .Execute(strText)
    .Pattern = "Liefertermin:\s+([\.\d]+)"  'Termin  
        Set objMatchesT = .Execute(strText)
End With

If objMatchesA.Count Then
    If objMatchesA.Count = objMatchesM.Count And objMatchesA.Count = objMatchesT.Count Then
        ReDim arrValues(0 To objMatchesA.Count - 1, 0 To 2)
            
        For i = 0 To UBound(arrValues)
            arrValues(i, 0) = Trim(objMatchesA(i).SubMatches(0))     'Artikel  
            arrValues(i, 1) = CLng(objMatchesM(i).SubMatches(0))     'Menge  
            arrValues(i, 2) = CDate(objMatchesT(i).SubMatches(0))    'Termin  
        Next
        GetMatchValues = arrValues
    End If
End If
End Function

...
strCMDLine = "C:\Users\Name\Documents\Test_Makro\pdftotext.exe -table -layout -nopgbrk "  
...
' konvertiere das Attachment in txt  
            objShell.Run strCMDLine & """" & att & """", 0, True  
            ' txt-Datei einlesen  
            For Each file In fso.GetFolder("C:\Users\Name\AppData\Local\Temp\").Files  
                If file.Name = Left(att.FileName, Len(att.FileName) - 4) & ".txt" Then colTFiles.Add file.Path  '  *.txt-Datei einlesen  
            Next
...