VBA; Programmierung mit Outlook - Erinnerungen

Erinnerungen kopieren

Alle Erinnerungen aus dem angegebenen Ordner werden in einen beliebigen Ordner kopiert. Wird jetzt mit OLFix der Erinnerungsordner angepasst, können auch Erinnerungen aus einem öffentlichem Ordner verwendet werden. Diese Funktion ist in OLfolders bereits fest eingebaut.

shared Sub SetupCopyReminders()
Dim f As MAPIFolder
MsgBox "Wählen Sie einen Ordner aus, welcher die Kopie der Erinnerungen aufnimmt"
Set f = GetFolder("LocalRemindersFolder", True, False)
MsgBox "Wählen Sie einen Ordner aus dem Öffentlichen Ordnerbereich aus"
Set f = GetFolder("PublicReminderFolder", True, False)
End Sub

shared Sub CopyReminders()
Dim obj As Object
Dim search As New Collection
Dim outlookfolder As Outlook.MAPIFolder
Dim sess As New MAPI.Session
Dim store As MAPI.InfoStore
Dim remfolder As MAPI.folder
Dim litterbin As MAPI.folder
Dim folder As MAPI.folder
Dim localfolder As MAPI.folder
Dim searchkey As String
Dim id As String
sess.Logon
On Error Resume Next

' Get the reminder folder from the shared folder

Set outlookfolder = GetFolder("PublicReminderFolder", False, False)

Set store = sess.InfoStores.Item(outlookfolder.StoreID)
id = store.RootFolder.Fields(&HE090102) ' ID of Root folder
Set folder = sess.GetFolder(id) ' The root folder contains a property which points to reminders folder
id = folder.Fields.Item(&H36D50102).Value ' EntryID of Reminders Folder
Set remfolder = sess.GetFolder(id)

' Get the local folder

Set outlookfolder = GetFolder("LocalRemindersFolder", False, False)
Set localfolder = sess.GetFolder(outlookfolder.EntryID)

Debug.Print "copying to " & localfolder.Name

' Now lets copy all elements from reminders folder to local folder

' create in memory index
For Each obj In localfolder.Messages
search.Add obj.id, obj.Fields(&H300B0102).Value
Debug.Print "local:" & obj.Subject
Next obj


Dim m As MAPI.Message
Dim m1 As MAPI.Messages

msgs.Add
For Each obj In remfolder.Messages
Debug.Print "remote & " & obj.Subject
searchkey = obj.Fields(&H300B0102).Value
id = ""
On Error Resume Next
id = search.Item(searchkey)
On Error GoTo 0
If id <> "" Then
Set tar = localfolder.Messages.Item(id)
tar.Delete True
End If
Set tar = obj.CopyTo(localfolder.id)
tar.Update
Next obj
End Sub