AW: Suche Kalender zum sync. Outlookkalender
04.01.2017 22:05:13
Andy
Hallo Markus,
das hört sich interessant an.
Ich habe bzgl. der Outlook Abfrage noch ein bischen gegooglet:
-den eigenen Kalender auslesen, sollte vom Ansatz her mit der folgenden Methode funktionieren:
Option Explicit
Private Sub GetOutlookCalendarItems()
Dim objAppOL As New Outlook.Application
Dim objNS As Namespace
Dim objCalendar As MAPIFolder
Dim objItem As AppointmentItem
Set objNS = objAppOL.GetNamespace("MAPI")
'Set objCalendar = objNS.GetDefaultFolder(olFolderCalendar) '(Kalender des _
Standartbenutzers)
Set objCalendar = objNS.PickFolder '(Kalender per Menü auswählbar)
For Each objItem In objCalendar.Items
With objItem
If Len(.Categories) > 0 Then
Debug.Print .Start; .Subject; " -> " & .Categories
End If
End With
Next
Set objCalendar = Nothing
Set objNS = Nothing
End Sub
-für das Auslesen eines "freigegebenen Kalenders" (MS-Exchange) ist wahrscheinlich ein "Recipient" Objekt sowie die "GetSharedDefaultFolder" Methode notwendig. Am besten wäre es, wenn man den Kalender per Auswahlmenü auswählen könnte...
Sub CreateOtherUserAppointment()
Dim objApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim objAppt As Outlook.AppointmentItem
Dim strMsg As String
Dim strName As String
On Error Resume Next
' ### name of person whose Calendar you want to use ###
strName = "Freiwald, Walter" 'bessere wäre hier eine Pickfolder Methode
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objDummy = objApp.CreateItem(olMailItem)
Set objRecip = objDummy.Recipients.Add(strName)
objRecip.Resolve
If objRecip.Resolved Then
On Error Resume Next
Set objFolder = _
objNS.GetSharedDefaultFolder(objRecip, _
olFolderCalendar)
If Not objFolder Is Nothing Then
Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt
.Subject = "Test Appointment"
.Start = Date + 14
.AllDayEvent = True
.Save
End With
End If
End If
Else
MsgBox "Could not find " & Chr(34) & strName & Chr(34), , _
"User not found"
End If
Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing
Set objAppt = Nothing
End Sub
unter dem folgenden Link habe ich auch noch einen Kalender Wert gefunden für "Default Folder Names":
https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
olPublicFoldersAllPublicFolders - Wert 18 - All Public Folders folder in Exchange Public Folders store (Exchange only)
und vielleicht noch einen passenden Schnipsel für den Public Folder :
' GetFolder - Gets a Public folder based on a string path - e.g.
'If Folder name in English is
'Public Folders\All Public Folders\Europeen Workflow
'The just pass in "Europeen Workflow'
Public Function GetPublicFolder(strFolderPath)
Dim colFolders
Dim objFolder
Dim arrFolders
Dim i
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders = Split(strFolderPath, "\")
Set objFolder = Application.Session.GetDefaultFolder(18)
Set objFolder = objFolder.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetPublicFolder = objFolder
Set colFolders = Nothing
Set objApp = Nothing
Set objFolder = Nothing
End Function
Quellen:
http://www.outlookcode.com/codedetail.aspx?id=1164
http://www.outlookcode.com/d/code/getfolder.htm
Vielleicht kann meine Recherche etwas zur Lösung beitragen.
Gruß Andy