Thema Datum  Von Nutzer Rating
Antwort
08.09.2020 00:18:26 iamye
Solved
08.09.2020 09:27:48 Gast26027
NotSolved
08.09.2020 11:51:54 iamye
NotSolved
09.09.2020 20:05:24 iamye
NotSolved
09.09.2020 20:19:03 Mase
NotSolved
10.09.2020 09:23:50 iamye
NotSolved
10.09.2020 10:34:42 Gast42731
NotSolved
13.09.2020 15:39:52 iamye
NotSolved
28.09.2020 20:06:14 Gast37069
NotSolved
28.09.2020 20:25:16 Gast72069
NotSolved
01.10.2020 22:47:16 iamye
NotSolved
02.10.2020 09:36:33 Mase
NotSolved
02.10.2020 13:02:09 iamye
NotSolved
02.10.2020 14:31:03 Mase
NotSolved
02.10.2020 16:02:02 iamye
NotSolved
02.10.2020 17:54:15 Mase
NotSolved
04.10.2020 13:26:40 iamye
NotSolved
04.10.2020 19:05:14 Mase
NotSolved
05.10.2020 01:03:43 iamye
NotSolved
05.10.2020 07:38:26 Mase
NotSolved
Rot Rot Falls sich hierher jemand verirren sollte (Sufu funktioniert ja jetz :)
08.10.2020 20:16:01 Mase
Solved

Ansicht des Beitrags:
Von:
Mase
Datum:
08.10.2020 20:16:01
Views:
675
Rating: Antwort:
 Nein
Thema:
Falls sich hierher jemand verirren sollte (Sufu funktioniert ja jetz :)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
'***************************************************************
' 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:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
'***************************************************************
' 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:
'// ------------------------------------------------------------------------------------
 
End Function
 
Sub MoveReceivedMails(ByVal sEntryID As String)
End Sub

Klassenmodul:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
'***************************************************************
' 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:
'// ------------------------------------------------------------------------------------
 
   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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
08.09.2020 00:18:26 iamye
Solved
08.09.2020 09:27:48 Gast26027
NotSolved
08.09.2020 11:51:54 iamye
NotSolved
09.09.2020 20:05:24 iamye
NotSolved
09.09.2020 20:19:03 Mase
NotSolved
10.09.2020 09:23:50 iamye
NotSolved
10.09.2020 10:34:42 Gast42731
NotSolved
13.09.2020 15:39:52 iamye
NotSolved
28.09.2020 20:06:14 Gast37069
NotSolved
28.09.2020 20:25:16 Gast72069
NotSolved
01.10.2020 22:47:16 iamye
NotSolved
02.10.2020 09:36:33 Mase
NotSolved
02.10.2020 13:02:09 iamye
NotSolved
02.10.2020 14:31:03 Mase
NotSolved
02.10.2020 16:02:02 iamye
NotSolved
02.10.2020 17:54:15 Mase
NotSolved
04.10.2020 13:26:40 iamye
NotSolved
04.10.2020 19:05:14 Mase
NotSolved
05.10.2020 01:03:43 iamye
NotSolved
05.10.2020 07:38:26 Mase
NotSolved
Rot Rot Falls sich hierher jemand verirren sollte (Sufu funktioniert ja jetz :)
08.10.2020 20:16:01 Mase
Solved