Option
Explicit
Implements
clsMovePDF
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
Private
m_Pfad_PDF2TextExe
As
String
Private
m_bTempFolderCreated
As
Boolean
Private
m_sTempFolder
As
String
Private
m_Schlagworte()
Private
Sub
Class_Initialize()
m_Pfad_PDF2TextExe = Environ(
"userprofile"
) &
"\Documents"
&
"\xpdf-tools-win-4.02\bin32\pdftotext.exe"
m_Schlagworte = Array(
"Affaire nouvelle"
,
"Avenant"
,
"Annulation"
)
End
Sub
Public
Sub
clsMovePDF_SavePDFintoTempFolder(
ByVal
EntryIDCollection
As
String
)
Dim
itm
As
Outlook.MailItem
Dim
att
As
Outlook.Attachment
Set
itm = Application.GetNamespace(
"MAPI"
).GetItemFromID(EntryIDCollection)
With
itm
If
.Attachments.Count > 0
Then
For
Each
att
In
.Attachments
With
CreateObject(
"Scripting.FilesystemObject"
)
If
UCase(.GetExtensionName(att.FileName)) = mc_sPDF
Then
Call
att.SaveAsFile(m_sTempFolder & "\" & att.FileName)
End
If
End
With
Next
att
End
If
End
With
End
Sub
Function
clsMovePDF_createTempFolderName()
As
String
m_sTempFolder = Environ(
"temp"
) & Chr(92) & Format(Now,
"yyyy-MM-dd_"
) & Replace(Timer,
","
,
"-"
)
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()
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
Dim
sCommand
As
String
Dim
vResult
As
Variant
sCommand = sExecuteFile &
" -raw "
& sSOURCEPDF &
" "
& sTargetTXT
vResult = Shell(sCommand, vbHide)
Call
Sleep(mc_lngSleeptime)
clsMovePDF_fGetPDFText =
Not
IsNull(vResult)
End
Function
Sub
clsMovePDF_MoveReceivedMails(
ByVal
sEntryID
As
String
)
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
Dim
ff
As
Integer
: ff = FreeFile
Dim
s
As
String
Set
fso = CreateObject(
"Scripting.FileSystemObject"
)
For
Each
f
In
fso.GetFolder(m_sTempFolder).Files
sPfadDateiPDF = UCase(f.ShortPath)
sPfadDateiTXT = Replace(UCase(f.ShortPath),
".PDF"
,
".TXT"
)
Call
clsMovePDF_fGetPDFText(m_Pfad_PDF2TextExe, sPfadDateiPDF, sPfadDateiTXT)
Open sPfadDateiTXT
For
Binary Access Read
As
#ff
s = Space$(LOF(ff))
Get
ff, , s
Close #ff
Select
Case
True
Case
InStr(1, s, m_Schlagworte(0), vbTextCompare) > 0
Set
OutlookFolder = Application.GetNamespace(
"MAPI"
).GetDefaultFolder(olFolderInbox).Folders(mc_sFOLDER_A)
Case
InStr(1, s, m_Schlagworte(1), vbTextCompare) > 0
Set
OutlookFolder = Application.GetNamespace(
"MAPI"
).GetDefaultFolder(olFolderInbox).Folders(mc_sFOLDER_B)
Case
InStr(1, s, m_Schlagworte(2), vbTextCompare) > 0
Set
OutlookFolder = Application.GetNamespace(
"MAPI"
).GetDefaultFolder(olFolderInbox).Folders(mc_sFOLDER_C)
Case
Else
Set
OutlookFolder =
Nothing
End
Select
If
Not
OutlookFolder
Is
Nothing
Then
Set
itm = Application.GetNamespace(
"MAPI"
).GetItemFromID(sEntryID)
itm.Move OutlookFolder
End
If
Next
f
End
Sub