Question

我有以下宏，该宏在Excel中获取电子邮件地址列表，并在Outlook的“我的联系人”部分下创建/更新Outlook通讯组列表。

如何修改此代码，以使其在名为“ Shared Test”的共享邮箱中而不是仅在我的邮箱中创建/更新联系人？

Const DISTLISTNAME As String = "Test"
Const olDistributionListItem = 7
Const olFolderContacts = 10

Sub test() 'Worksheet_Change(ByVal Target As Range)

Dim outlook As Object ' Outlook.Application
Dim contacts As Object ' Outlook.Items
Dim myDistList As Object ' Outlook.DistListItem
Dim newDistList As Object ' Outlook.DistListItem
Dim objRcpnt As Object ' Outlook.Recipient
Dim arrData() As Variant
Dim rng As Excel.Range
Dim numRows As Long
Dim numCols As Long
Dim i As Long
Dim msg As String

msg = "Worksheet has been changed, would you like to update distribution list?"

  If MsgBox(msg, vbYesNo) = vbNo Then
    Exit Sub
  End If

  Set outlook = GetOutlookApp
  Set contacts = GetItems(GetNS(outlook))

  'On Error Resume Next
  Set myDistList = contacts.Item(DISTLISTNAME)
  On Error GoTo 0

  If Not myDistList Is Nothing Then
    ' delete it
    myDistList.Delete
  End If

    ' recreate it
    Set newDistList = outlook.CreateItem(olDistributionListItem)

    With newDistList
      .DLName = DISTLISTNAME
      .Body = DISTLISTNAME
    End With

    ' loop through worksheet and add each member to dist list
    numRows = Range("A1").CurrentRegion.Rows.Count - 1
    numCols = Range("A1").CurrentRegion.Columns.Count

    ReDim arrData(1 To numRows, 1 To numCols)

    ' take header out of range
    Set rng = Range("A1").CurrentRegion.Offset(1, 0).Resize(numRows, numCols)
    ' put range into array
    arrData = rng.Value

    ' assume 2 cols (name and emails only)
    For i = 1 To numRows
      'little variation on your theme ...
      Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 1) & "<" & arrData(i, 2) & ">")
      'end of variation
      objRcpnt.Resolve
      newDistList.AddMember objRcpnt
    Next i

    newDistList.Save
    'newDistList.Display

End Sub

Function GetOutlookApp() As Object
  'On Error Resume Next
  Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

'To My Contacts
Function GetItems(olNS As Object) As Object
Set GetItems = olNS.GetDefaultFolder(olFolderContacts).Items
End Function

Function GetNS(ByRef app As Object) As Object
  Set GetNS = app.GetNamespace("MAPI")
End Function

Answer 1

引用非默认文件夹的一种方法是使用.CreateRecipient。

您的代码中的功能似乎没有使它更有效。

Option Explicit

Const DISTLISTNAME As String = "Test"
Const olDistributionListItem = 7
Const olFolderContacts = 10

Sub test()

    Dim outlook As Object       ' Outlook.Application
    Dim olNs As Object          ' Outlook.Namespace

    Dim shareRecipient As Object            ' outlook.recipient
    Dim sharedMaiboxContacts As Object      ' outlook.Folder
    Dim sharedMaiboxContactsItems As Object ' outlook.items

    Dim myDistList As Object    ' Outlook.DistListItem
    Dim newDistList As Object   ' Outlook.DistListItem

    Dim objRcpnt As Object      ' outlook.recipient

    Set outlook = CreateObject("Outlook.Application")
    Set olNs = outlook.GetNamespace("MAPI")

    ' Enter mailbox name in "sharedMailboxName"
    ' Email address is not as useful. Even if invalid, cannot fail a resolve

    Set shareRecipient = olNs.CreateRecipient("sharedMailboxName")

    shareRecipient.Resolve

    If shareRecipient.Resolved Then

        Set sharedMaiboxContacts = olNs.GetSharedDefaultFolder(shareRecipient, olFolderContacts)
        sharedMaiboxContacts.Display
        Set sharedMaiboxContactsItems = sharedMaiboxContacts.Items

        ' This is a valid use of On Error Resume Next
        '  to bypass a known possible error
        '
        ' Before finalizing the code, test with this commented out
        '  where you think there should not be an error
        '  or you may bypass unknown errors, for example when the syntax is wrong.
        On Error Resume Next

        ' A possible known error occurs if the list does not exist.
        ' myDistList can remain "Nothing" instead of causing an error.
        Set myDistList = sharedMaiboxContactsItems.Item(DISTLISTNAME)

        ' Turn the bypass off. / Turn normal error handling on.
        ' Place it as soon as possible after On Error Resume Next
        On Error GoTo 0

        If Not myDistList Is Nothing Then
            ' delete it
            myDistList.Delete
        End If

        ' Add to non default folders
        Set newDistList = sharedMaiboxContactsItems.Add(olDistributionListItem)

        With newDistList
            .DLName = DISTLISTNAME
            .body = DISTLISTNAME
        End With

        Debug.Print olNs.CurrentUser

        ' Test with yourself
        Set objRcpnt = olNs.CreateRecipient(olNs.CurrentUser)

        objRcpnt.Resolve

        If objRcpnt.Resolved Then
            newDistList.AddMember objRcpnt
            newDistList.Display
        Else
            Debug.Print objRcpnt & " not resolved."
        End If

    Else

        Debug.Print shareRecipient & " not resolved."

    End If

End Sub

从Excel更新共享邮箱中的通讯组列表

1 个答案: