Hallo,
mit dem nachfolgenden Code werden bisher Emails bei Posteingang anhand eines Musters im Betreff selektiert und in einer Protokoll-Datei in Access protokolliert.
Dieser Ablauf funktioniert.
Jetzt möchte ich zusätzlich auch Emails, die gesendet werden beim Eintritt in den Ordner Gesendete Objekte mit dem gleichen Ablauf behandeln.
Dazu habe ich den Code an zwei Stellen (NEU) ergänzt, komme aber nicht mehr weiter.
Fragen dazu:
1. Ist der gewählte Ansatz richtig?
2. Falls nicht...wie muss ich korrigieren?
3. Wo muss ich noch eingreifen, damit der beschriebene Ablauf läuft? Bitte mit Code...
Vielen Dank für jede Hilfe
Harry
Option Explicit
Private WithEvents olItems As Outlook.Items, olItems2 As Outlook.Items
' !!!!!! Mails, die eingehen !!!!!! + !!!!!! NEU hinzugefügt: Mails, die gesendet werden !!!!!!
'Vorab in Outlook Macro-Benutzung in Outlook Trustcenter aktivieren
'wird im Video ID1337 direkt am Anfang erklärt
'Verweis auf Access legen...im Video ab 14:00...(statt Excel > Access)
Private Sub Application_Startup()
'Variablen dimensionieren
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim dB As DAO.Database
Dim rs2 As DAO.Recordset
'Variablen initialisieren
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items
Set olItems2 = olNS.GetDefaultFolder(olFolderSentMail).Items 'NEU hinzugefügt
'Test
Debug.Print "Application_Startup wird ausgeführt"
End Sub
Private Sub olItems_ItemAdd(ByVal item As Object)
On Error GoTo SubExit 'Bei Fehler
'Variablen dimensionieren
Dim olMail As Outlook.MailItem
Dim olAtt As Outlook.Attachment
'Dimensionierung Objekt MatchCollection, das die Treffer der Suche aufnimmt
Dim oMC As Object
Dim dB As DAO.Database
Dim rs2 As DAO.Recordset
Set dB = DBEngine.OpenDatabase("D:\Workbooks\Workbook Bewerbung Datenbank\Bewerbungen\Unternehmen.accdb")
'Prüfen, ob Item eine Mail ist
If TypeName(item) = "MailItem" Then
Set olMail = item
' 'Key-Blöcke dimensionieren
Dim Zahlen1 As Long
Dim Zahlen2 As Long
Dim Zahlen3 As Long
'Definition der Suche
Set oMC = RegExMatchCollection(olMail.Subject, "(\d+)/(\d+)/(\d+)")
Zahlen1 = oMC(0).SubMatches(0)
Zahlen2 = oMC(0).SubMatches(1)
Zahlen3 = oMC(0).SubMatches(2)
'Test
' Debug.Print Zahlen1
' Debug.Print Zahlen2
' Debug.Print Zahlen3
Set rs2 = dB.OpenRecordset("SELECT * FROM ProtokollT WHERE False", dbOpenDynaset)
'rs2 füllt die Protokolldatei.
'Ein leerer Datensatz wird geladen
With rs2
.AddNew
!EntryID = olMail.EntryID
!Body = olMail.Body
' !Body = INSERT olMail.Body ....wie kann ich den Text hier richtig einfügen??
!ProtokollTypID = 2
!AdressdatenID = Zahlen3
!ToRecipient = olMail.To
!FromSender = olMail.Sender
!Subject = olMail.Subject
!TeilnehmerID = Zahlen1
!DatumZeit = Now
.Update
.Close
End With
'End If
End If
SubExit: 'Bei Fehler
' Aufräumen
Set rs2 = Nothing
Set dB = Nothing
Exit Sub
End Sub
Option Explicit
Private pRegEx As Object
Public Property Get oRegEx() As Object
If (pRegEx Is Nothing) Then Set pRegEx = CreateObject("Vbscript.Regexp")
Set oRegEx = pRegEx
End Property
Public Function RegExTest(ByVal SourceText As String, _
ByVal SearchPattern As String, _
Optional ByVal bIgnoreCase As Boolean = True, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal bMultiLine As Boolean = True) As Boolean
With oRegEx
.Pattern = SearchPattern
.IgnoreCase = bIgnoreCase
.Global = bGlobal
.MultiLine = bMultiLine
RegExTest = .Test(SourceText)
End With
End Function
Public Function RegExReplace(ByVal SourceText As String, _
ByVal SearchPattern As String, _
ByVal ReplaceText As String, _
Optional ByVal bIgnoreCase As Boolean = True, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal bMultiLine As Boolean = True) As String
With oRegEx
.Pattern = SearchPattern
.IgnoreCase = bIgnoreCase
.Global = bGlobal
.MultiLine = bMultiLine
RegExReplace = .Replace(SourceText, ReplaceText)
End With
End Function
Public Function RegExMatchCollection(ByVal SourceText As String, _
ByVal SearchPattern As String, _
Optional ByVal bIgnoreCase As Boolean = True, _
Optional ByVal bGlobal As Boolean = True, _
Optional ByVal bMultiLine As Boolean = True) As Object
With oRegEx
.Pattern = SearchPattern
.IgnoreCase = bIgnoreCase
.Global = bGlobal
.MultiLine = bMultiLine
Set RegExMatchCollection = .Execute(SourceText)
End With
End Function