Получить адрес электронной почты выбранной папки назначения

Question

У меня есть два календаря, один мой, а другой общий . Оба открываются в перспективе, как показано ниже.

Как я могу получить адрес электронной почты выбранного календаря приставок?

Я видел AppointmentItem имеет GetOrganizer , чтобы найти, кто создал встречу, но я не нахожу какого-либо метода или свойства пользователя календаря в том случае, если встреча ...

Поэтому я попытался Application.ActiveExplorer.CurrentFolder получить выбранную папку, а затем получить AdressEntry, но я не могу получить хранилище папки, потому что это общий календарь (а затем folder.store возвращает ноль).

Следуя советам Дмитрия там , я сделал:

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.

Это свойство возвращает объект Store , за исключением случая, когда папка является общей папкой (возвращается NameSpace.GetSharedDefaultFolder). В этом случае один пользователь делегировал доступ к папке по умолчанию другому пользователю; вызов Folder.Store вернет Null .

Answer 1

Я наконец нашел способ сделать это, это топи c помогло мне.

Приведенный ниже код анализирует 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