Get selected Appointment folder's email adress

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