'***************************************************************
' 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
|