'***************************************************************
' This OutlookSession
'***************************************************************
Option Explicit
'*** Eventlistener
Public WithEvents itmNeueEmails As Outlook.Items
Private cls As clsMovePDF
'*** Konstanten
Const mc_sMAILSENDER As String = "absender@local.de"
'


Private Sub Application_Startup()
    '*** nach Bedarf weitere Implements instanzieren
    Set cls = New clsMovePDFbyEvent
    '***
    Set itmNeueEmails = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items

End Sub

Private Sub itmNeueEmails_ItemAdd(ByVal Item As Object)
    If (TypeOf Item Is Outlook.MailItem) And (InStr(1, LCase(Item.SenderEmailAddress), mc_sMAILSENDER, vbTextCompare) >= 1) Then

        With cls
            .createTempFolderName
            Call .SavePDFintoTempFolder(Item.EntryID)
            Call .MoveReceivedMails(Item.EntryID)
            .DeleteTempFolder
        End With
        
    End If
End Sub

Klassenmodul:

'***************************************************************
' Klassenmodul: clsMovePDF
'***************************************************************

Option Explicit

Public Sub SavePDFintoTempFolder(ByVal EntryIDCollection As String)
End Sub

Function createTempFolderName() As String
End Function

Property Get TempFolderName() As String
End Property

Property Get TempFolderCreated() As Boolean
End Property

Property Let TempFolderCreated(b As Boolean)
End Property

Sub DeleteTempFolder()
End Sub

Private Function fGetPDFText(ByVal sExecuteFile As String, _
                        ByVal sSOURCEPDF As String, _
                        ByVal sTargetTXT As String) As Boolean
'// ------------------------------------------------------------------------------------
'// Methode:   | Erzeugen einer Textdatei aus einem PDF-Dokument
'// ------------------------------------------------------------------------------------
'// Parameter: | sExecuteFile - vollständiger Pfad der pdftotext.exe
'//            | sSourcePDF   - vollständiger Pfad des Quelldokumentes (PDF)
'//            | sTargetTXT   - vollständiger Pfad des Zieldokumentes (TXT)
'// ------------------------------------------------------------------------------------
'// Rückgabe:  | True bei Erfolg
'// ------------------------------------------------------------------------------------
'// Autor:     | ebs17
'// ------------------------------------------------------------------------------------
'// Hinweis:   | pdftotext.exe beziehbar über http://www.foolabs.com/xpdf/download.html
'//            | aktueller Download zum 18.01.2011:
'//            | ftp://ftp.foolabs.com/pub/xpdf/xpdf-3.02pl5-win32.zip
'// ------------------------------------------------------------------------------------

End Function

Sub MoveReceivedMails(ByVal sEntryID As String)
End Sub

Klassenmodul:

'***************************************************************
' Klassenmodul: clsMovePDFbyEvent
'***************************************************************
Option Explicit

Implements clsMovePDF

'*** Konstanten
Const mc_sPDF As String = "PDF"
Const mc_sMAILSENDER As String = "absender@local.de"
Const mc_sFOLDER_A As String = "Ordner A"
Const mc_sFOLDER_B As String = "Ordner B"
Const mc_sFOLDER_C As String = "Ordner C"
Const mc_lngSleeptime As Long = 1000

'*** Variablen
Private m_Pfad_PDF2TextExe As String
Private m_bTempFolderCreated As Boolean
Private m_sTempFolder As String
Private m_Schlagworte()

'***

Private Sub Class_Initialize()
    '*** Pfad zu pdftotext
    m_Pfad_PDF2TextExe = Environ("userprofile") & "\Documents" & "\xpdf-tools-win-4.02\bin32\pdftotext.exe"
    '*** Schlagwörter setzen
    m_Schlagworte = Array("Affaire nouvelle", "Avenant", "Annulation")
End Sub

Public Sub clsMovePDF_SavePDFintoTempFolder(ByVal EntryIDCollection As String)
    '*** wird vor evt_NewMail/vor Clientregeln ausgeführt
    Dim itm As Outlook.MailItem
    Dim att As Outlook.Attachment

    Set itm = Application.GetNamespace("MAPI").GetItemFromID(EntryIDCollection)
    With itm
        '*** Prüfen ob Dateianhänge vorhanden
        If .Attachments.Count > 0 Then
            '*** Wenn vorhanden, jeden einzelnen Anhang prüfen, ob PDF
            For Each att In .Attachments
                With CreateObject("Scripting.FilesystemObject")
                    If UCase(.GetExtensionName(att.FileName)) = mc_sPDF Then
                        '*** Wenn PDF dann im Dateisystem abspeichern...
                        '*** Dateianhang im erstellten Ordner temporär abspeichern
                        Call att.SaveAsFile(m_sTempFolder & "\" & att.FileName)
                    End If
                End With
            Next att
        End If
    End With

End Sub

Function clsMovePDF_createTempFolderName() As String
    '*** temp Verzeichnisname
    m_sTempFolder = Environ("temp") & Chr(92) & Format(Now, "yyyy-MM-dd_") & Replace(Timer, ",", "-") 'CHR(92) = "\"
    '*** Verz erstellen
    With CreateObject("Scripting.FileSystemObject")
        Call .CreateFolder(m_sTempFolder)
        m_bTempFolderCreated = .folderexists(m_sTempFolder)
    End With

    clsMovePDF_createTempFolderName = m_sTempFolder

End Function

Property Get clsMovePDF_TempFolderName() As String
    clsMovePDF_TempFolderName = m_sTempFolder
End Property

Property Get clsMovePDF_TempFolderCreated() As Boolean
    TempFolderCreated = m_bTempFolderCreated
End Property

Property Let clsMovePDF_TempFolderCreated(b As Boolean)
    m_bTempFolderCreated = b
End Property

Sub clsMovePDF_DeleteTempFolder()
    '*** Temporäre Dateien und Ordner wieder löschen
    On Error Resume Next
    Kill m_sTempFolder & "\*.*"
    RmDir m_sTempFolder
    m_bTempFolderCreated = False
    On Error GoTo 0
End Sub

Private Function clsMovePDF_fGetPDFText(ByVal sExecuteFile As String, _
                        ByVal sSOURCEPDF As String, _
                        ByVal sTargetTXT As String) As Boolean
'// ------------------------------------------------------------------------------------
'// Methode:   | Erzeugen einer Textdatei aus einem PDF-Dokument
'// ------------------------------------------------------------------------------------
'// Parameter: | sExecuteFile - vollständiger Pfad der pdftotext.exe
'//            | sSourcePDF   - vollständiger Pfad des Quelldokumentes (PDF)
'//            | sTargetTXT   - vollständiger Pfad des Zieldokumentes (TXT)
'// ------------------------------------------------------------------------------------
'// Rückgabe:  | True bei Erfolg
'// ------------------------------------------------------------------------------------
'// Autor:     | ebs17
'// ------------------------------------------------------------------------------------
'// Hinweis:   | pdftotext.exe beziehbar über http://www.foolabs.com/xpdf/download.html
'//            | aktueller Download zum 18.01.2011:
'//            | ftp://ftp.foolabs.com/pub/xpdf/xpdf-3.02pl5-win32.zip
'// ------------------------------------------------------------------------------------

   Dim sCommand As String
   Dim vResult As Variant
   sCommand = sExecuteFile & " -raw " & sSOURCEPDF & " " & sTargetTXT
   vResult = Shell(sCommand, vbHide)
   '*** Zeit geben um zu konvertieren
   Call Sleep(mc_lngSleeptime)
   clsMovePDF_fGetPDFText = Not IsNull(vResult)
End Function

Sub clsMovePDF_MoveReceivedMails(ByVal sEntryID As String)
    '*** Deklarationsteil umwandeln PDF -> TXT
    Dim itm As Outlook.MailItem
    Dim OutlookFolder As Outlook.Folder
    Dim fso As Object
    Dim f As Object
    Dim b As Boolean
    Dim sPfadDateiTXT As String, sPfadDateiPDF As String
    '*** Deklarationsteil TXT öffnen -> bei Fund verschieben
    Dim ff As Integer: ff = FreeFile
    Dim s As String

    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each f In fso.GetFolder(m_sTempFolder).Files

        '*** PDF in TXT umwandeln
        sPfadDateiPDF = UCase(f.ShortPath)
        sPfadDateiTXT = Replace(UCase(f.ShortPath), ".PDF", ".TXT")
        Call clsMovePDF_fGetPDFText(m_Pfad_PDF2TextExe, sPfadDateiPDF, sPfadDateiTXT)

        '*** TXT-Datei für die Suche öffnen bzw in Stringvariable einlesen
        Open sPfadDateiTXT For Binary Access Read As #ff
            s = Space$(LOF(ff))
            Get ff, , s
        Close #ff

        '*** Suche Schlagwort in TXT -> bei Fund -> set Ordner
        Select Case True
            '*** Suche "Affaire nouvelle"
            Case InStr(1, s, m_Schlagworte(0), vbTextCompare) > 0
            Set OutlookFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(mc_sFOLDER_A)
            '*** Suche "Avenant"
            Case InStr(1, s, m_Schlagworte(1), vbTextCompare) > 0
            Set OutlookFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(mc_sFOLDER_B)
            '*** Suche "Annulation"
            Case InStr(1, s, m_Schlagworte(2), vbTextCompare) > 0
            Set OutlookFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(mc_sFOLDER_C)
            '*** Kein Ergebnis
            Case Else
            Set OutlookFolder = Nothing
        End Select

        '*** Mail bei Fund verschieben
        If Not OutlookFolder Is Nothing Then
            Set itm = Application.GetNamespace("MAPI").GetItemFromID(sEntryID)
            itm.Move OutlookFolder
        End If
    Next f

End Sub