获取选定的约会文件夹电子邮件地址

Question

我有两个日历，一个是我的，另一个是共享的。两者都在前景中打开，如下所示。

如何获取选定的约会日历的电子邮件地址？

我看到AppointmentItem 有GetOrganizer 来查找谁创建了约会，但我没有找到任何关于约会的日历用户的方法或属性...

所以我尝试Application.ActiveExplorer.CurrentFolder 获取所选文件夹，然后获取AdressEntry，但我无法获取文件夹的存储，因为它是共享日历（然后folder.store 返回 null）。

按照 Dmitry 的建议 there，我做到了：

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)

问题是我无法获得共享文件夹的.Store，如 MS 文档中所写的 here。

此属性返回一个 Store 对象除非文件夹是共享文件夹（由 NameSpace.GetSharedDefaultFolder 返回）。在这种情况下，一个用户已将默认文件夹的访问权限委托给另一个用户；对 Folder.Store 的调用将返回 Null。

Answer 1

我终于找到了办法，this topic 帮助了我。

下面的代码，解析共享文件夹storeID得到共享文件夹SMTP地址。

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

在没有内置快捷方式的情况下，可能会在很长一段时间内到达共享日历的文件夹树的顶部。

在我自己的日历上测试，而不是共享日历。

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