Get selected Appointment folder's email adress - vba

Question

I have two calendars, one is mine and the other is shared. Both are opened in outlook as below.
How can i get selected apointment calendar's email adress?
I saw AppointmentItem has GetOrganizer to find who created the appointment but I don't find any method or property about the user of the calendar in witch the appointment is...
So I tried Application.ActiveExplorer.CurrentFolder to get the selected folder and then get the AdressEntry but I can't get the folder's store because it's a shared calendar (and then folder.store returns null).
Following Dmitry's advices there, I did :
Dim appointment_item As Outlook.AppointmentItem
Dim PR_MAILBOX_OWNER_ENTRYID as String
Dim mapiFolder As Outlook.MAPIFolder
Dim folderStore As Outlook.Store
Dim mailOwnerEntryId As String
Dim entryAddress As Outlook.AddressEntry
Dim smtpAdress As String
PR_MAILBOX_OWNER_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x661B0102"
appointment_item = Application.ActiveExplorer.Selection.Item(1)
mapiFolder = appointment_item.Parent
folderStore = mapiFolder.Store
mailOwnerEntryId = folderStore.PropertyAccessor.GetProperty(PR_MAILBOX_OWNER_ENTRYID)
entryAddress = Application.Session.GetAddressEntryFromID(mailOwnerEntryId)
smtpAdress = entryAddress.GetExchangeUser.PrimarySmtpAddress
MsgBox(smtpAdress)
The issue is i can't get .Store of a shared folder as written here in the MS Documentation.
This property returns a Store object except in the case where the Folder is a shared folder (returned by NameSpace.GetSharedDefaultFolder). In this case, one user has delegated access to a default folder to another user; a call to Folder.Store will return Null.

Answer 1

I finally found a way to do it, this topic helped me.
The code below, parses the shared folder storeID to get the shared folder SMTP address.
Public Sub test()
Dim smtpAddress As String
Dim selectedItem As Outlook.Folder
smtpAddress = ""
TryGetSmtpAddress(Application.ActiveExplorer.Selection.Item(1).Parent, smtpAddress)
End Sub
Public Shared Function TryGetSmtpAddress(ByVal folder As MAPIFolder, ByRef smtpAddress As String) As Boolean
smtpAddress = "default"
Dim storeId = HexToBytes(folder.StoreID)
If BitConverter.ToUInt64(storeId, 4) <> &H1A10E50510BBA138UL OrElse BitConverter.ToUInt64(storeId, 12) <> &HC2562A2B0008BBA1UL Then
Return False
End If
Dim indexDn = Array.IndexOf(storeId, CByte(&H0), 60) + 1
Dim indexV3Block = Array.IndexOf(storeId, CByte(&H0), indexDn) + 1
If BitConverter.ToUInt32(storeId, indexV3Block) <> &HF43246E9UL Then
Return False
End If
Dim offsetSmtpAddress = BitConverter.ToUInt32(storeId, indexV3Block + 12)
smtpAddress = BytesToUnicode(storeId, indexV3Block + CInt(offsetSmtpAddress))
Return True
End Function
Private Shared Function HexToBytes(ByVal input As String) As Byte()
Dim bytesLength = input.Length / 2
Dim bytes = New Byte(bytesLength - 1) {}
For i = 0 To bytesLength - 1
bytes(i) = Convert.ToByte(input.Substring(i * 2, 2), 16)
Next
Return bytes
End Function
Private Shared Function BytesToUnicode(ByVal value As Byte(), ByVal startIndex As Integer) As String
Dim charsLength = (value.Length - startIndex) / 2
Dim chars = New Char(charsLength - 1) {}
For i = 0 To charsLength - 1
Dim c = CSharpImpl.__Assign(chars(i), BitConverter.ToChar(value, startIndex + i * 2))
If c = vbNullChar Then
Return New String(chars, 0, i)
End If
Next
Return New String(chars)
End Function
Private Class CSharpImpl
<Obsolete("Please refactor calling code to use normal Visual Basic assignment")>
Shared Function __Assign(Of T)(ByRef target As T, value As T) As T
target = value
Return value
End Function
End Class

Answer 2

It may be possible to get to the top of the folder tree of a shared calendar the long way, without built-in shortcuts.
Tested on my own calendar, not a shared calendar.
Option Explicit
Sub appointment_sourceFolder()
' VBA code
Dim obj_item As Object
Dim appointment_item As AppointmentItem
Dim parentOfAppointment As Variant
Dim parentParentFolder As Folder
Dim sourceFolder As Folder
Set obj_item = ActiveExplorer.Selection.Item(1)
If obj_item.Class <> olAppointment Then Exit Sub
Set appointment_item = obj_item
' Recurring appointment leads to
' the parent of the recurring appointment item then the calendar folder.
' Single appointment leads to
' the calendar folder then the mailbox name.
Set parentOfAppointment = appointment_item.Parent
Set parentParentFolder = parentOfAppointment.Parent
Debug.Print vbCr & " parentParentFolder: " & parentParentFolder.Name
Set sourceFolder = parentParentFolder
' Error bypass for a specific purpose
On Error Resume Next
' If parentParentFolder is the shared calendar,
' walking up one folder is the mailbox.
' If parentParentFolder is the mailbox,
' walking up one folder is an error that is bypassed,
' so no change in sourceFolder.
' Assumption:
' The shared calendar is directly under the mailbox
' otherwise add more Set sourceFolder = sourceFolder.Parent
Set sourceFolder = sourceFolder.Parent
' Return to normal error handling immediately
On Error GoTo 0
Debug.Print " sourceFolder should be smtp address: " & sourceFolder
'MsgBox " sourceFolder should be smtp address: " & sourceFolder
End Sub