Mai 25, 2022, 12:39:52

Neuigkeiten:

Wenn ihr euch für eine gute Antwort bedanken möchtet, im entsprechenden Posting einfach den Knopf "sag Danke" drücken!


Email mit Muster selektieren/dokumentieren Posteingang + Gesendete Objekte

Begonnen von Umbauwfb, April 05, 2022, 09:34:23

⏪ vorheriges - nächstes ⏩

Umbauwfb

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