Outlook 2010 VBA: Kategorie und Appointment setzen

[amn.ssy]

Hallo,

derzeit bastele ich gerade an einem Warnsystem, das alle Ordner (incl. Unterordner) der ein- und ausgehenden Mails durchläuft und nach Emails prüft die älter als x Tage sind.
Alle gefunden Mails werden der Kategorie "Archive" zugeordnet und zu letzt eine Erinnerung für die rechtzeitige Sicherung gesetzt.

Bisher habe ich folgenden Code gestrickt und bin ziemlich stolz auf das bisherige Ergebnis - auch wenn's an kleinen Stellen noch nicht ganz rund läuft:

Public Sub CountMails()

On Error Resume Next

Dim OlApp As Outlook.Application
Dim OlNameSpace As Object
Dim OlCategory As Object
Dim OlApt As Object

Dim OlFolderIn As Outlook.MAPIFolder
Dim OlFolderOut As Outlook.MAPIFolder
Dim OlSubFolder As Outlook.MAPIFolder


Dim sCategories As String
Dim oldMailsIn As Integer
Dim oldMailsOut As Integer

oldMailsIn = 0
oldMailsOut = 0

Set OlApp = CreateObject("Outlook.Application")
Set OlNameSpace = OlApp.GetNamespace("Mapi")
Set OlFolderIn = OlNameSpace.GetDefaultFolder(OlDefaultFolders.olFolderInbox)
Set OlFolderOut = OlNameSpace.GetDefaultFolder(OlDefaultFolders.olFolderSentMail)

If OlNameSpace.Categories.Count > 0 Then
    For Each OlCategory In OlNameSpace.Categories
        sCategories = sCategories & OlCategory.Name & vbCrLf
    Next
End If

If InStr(1, sCategories, "Archive") < 1 Then
    Set OlCategory = OlNameSpace.Categories.Add("Archive", OlCategoryColor.olCategoryColorDarkRed, _
                     OlCategoryShortcutKey.olCategoryShortcutKeyNone)
    Else
          
    For Each OlSubFolder In OlFolderIn.Folders
        For i = 1 To OlSubFolder.Items.Count()
            If OlSubFolder.Items(i).ReceivedTime() < (Now() - 300) Then
                With OlSubFolder.Items(i)
                    .Categories = "Archive"
                    .Save
                End With
                oldMailsIn = oldMailsIn + 1
            End If
         Next
    Next OlSubFolder
             
    For Each OlSubFolder In OlFolderOut.Folders
        For j = 1 To OlSubFolder.Items.Count()
            If OlSubFolder.Items(j).ReceivedTime() < (Now() - 360) Then
                With OlSubFolder.Items(j)
                    .Categories = "Archive"
                    .Save
                End With
                oldMailsOut = oldMailsOut + 1
            End If
         Next
    Next OlSubFolder
    
End If

MsgBox "You have " & vbCrLf & _
        oldMailsIn & " emails > 300 days in your Folders of Inbox and" & vbCrLf & _
        oldMailsOut & " emails > 360 days in your Folders of Sent" & vbCrLf & vbCrLf & _
        "All emails assigned to the (red) category 'Archive'" & vbCrLf & _
        "Please archive your importet emails within next 30 days!"
         
 Set OlApt = OlApp.CreateItem(olAppointmentItem)
   With OlApt
      .Body = "You have " & vbCrLf & _
                oldMailsIn & " emails > 300 days in your Folders of Inbox and" & vbCrLf & _
                oldMailsOut & " emails > 360 days in your Folders of Sent" & vbCrLf & vbCrLf & _
                "All emails assigned to the (red) category 'Archive'" & vbCrLf & _
                "Please archive your importet emails within next 30 days!"
                
      .Subject = "archive emails!"
      .Location = "your Outlook"
      .Start = "29.1.2014 08:00"
      .End = "29.1.2014 08:05"
      .Importance = 1
      .ReminderSet = True
      .ReminderMinutesBeforeStart = 0
      .BusyStatus = 0
      .Save
   End With
     
Set OlApp = Nothing
   
End Sub

Nicht ganz rund läuft an folgenden Stellen:

Wenn der Code zu ersten mal ausgeführt wird und die Kategorie "Archive" noch nicht vorhanden ist wird diese zwar erzeugt und auch die Erinnerung gesetzt, jedoch unterbleibt das Zählen und markieren.
Für ich den Code dann gleich nochmal aus (Kategorie "Archive" ist vorhanden) läuft alles wie gewünscht - warum?
In diesem Zusammenhang stelle ich mir auch die Frage ob sich im String "sCategories" den Begriff nicht einfacher finden lässt?
Im Prinzip interessiert mit weniger die Stelle des auftretens sonder vielmehr ob der Substring vorhanden ist (True\False).
Ein letzte Frage bezieht sich auf die Erinnerung:
Hier wäre es wünschenswert zum einen eine Serie von 5 Werktagen zu kreieren und das Startdatum dynamisch in die Zukunft zu setzen (Ausführung (also heute) + 1 Monat (soweit dieser Tag ein Werktag ist).

Ich freue mich über Ratschläge, Hinweise und alles was hilft das Makro final abzuschließen.

LG
opiWahn

Update: Bin gerade auf ein interessantes Verfahren stoßen das og. Makro zu einem Bestimmten Zeitpunkt automatisch zu starten:
ThisOutlookSession

Private Sub Application_Reminder(ByVal Item As Object)
If Item.Subject = "Check yor mails" Then
CountMails() <--- hier gehört ein call davor
End If
End Sub

Obwohl ich einen späteren Zeitpunkt gesetzt habe feuert das Teil nach dem speichern sofort ein Event und CountMails() scheint er so nicht zu akzeptieren :-(
...
Lag am Call - abfeuern tut er trotzdem sofort obwohl der Termin noch nicht fällig ist ****?

 

[Zvoni]

Zeile 33-36+62: du hast ne If-Then-Else-Klausel
Du prüfst, ob "Archive" nicht vorhanden.
Falls True (nicht vorhanden), erzeuge "Archive"
ansonsten (Else-Teil!) gehe in deine Schleife.

Wirf das Else raus und ziehe das End If aus Zeile 62 nach Zeile 36

In dem Fall lauft es so ab:
Prüfe ob "Archive" nicht vorhanden.
Falls True (Nicht vorhanden) erzeuge "Archive"

Egal ob "Archive" vorhanden oder nicht, dein Code macht dann in Zeile 38 auf jeden Fall weiter.

Was die Prüfung auf "Archive" vorhanden (True/False) in sCategories angeht: Ich wüsste jetzt auch keine andere Lösung als mit InStr zu prüfen.

 

[amn.ssy]

Hallo Zvoni,

erstmal vielen Dank, der Tipp war genau richtig und letztlich so simpel, daß es ja schon fast peinlich ist danach gefragt zu haben.
Wegen der Abfrage ob es die Kategorie "Archive" gibt bin ich auf folgende Lösung gestoßen:

If OlNameSpace.Categories.Item("Archive") Is Nothing Then
    Set OlCategory = OlNameSpace.Categories.Add("Archive", OlCategoryColor.olCategoryColorDarkRed, _
                     OlCategoryShortcutKey.olCategoryShortcutKeyNone)
End If

Die Sache mit der Erinnerung und den Werktagen konnte so gelöst werden:

'*** calculate date
    d = DateAdd("m", 1, Date)
    Select Case Weekday(d, 2)
        Case 7
            d = DateAdd("d", 2, d)
        Case 1
            d = DateAdd("d", 1, d)
    End Select
    appStart = d & " 08:00:00"
    appEnd = d & " 08:05:00"

appStart und appEnd stellen die Variablen für den Start- und Endzeitpunkt dar.
Hab zwar noch nicht rausgefunden wie ich daraus ein Serie mache (5 hintereinanderliegende Werktage) aber immerhin wird zumindest eine Erinnerung korrekt schon mal gesetzt.

LG
opiwahn

 

[Zvoni]

Kleiner Tip von mir zwecks Lesbarkeit:

Ersetz das "Case 1" und "Case 7" mit "Case vbSunday" und "Case vbSaturday"