将 Outlook 联系人链接到 VBA 用户窗体中的下拉列表

Question

Excel 中 VBA 用户表单中的信息会自动传输到 Excel 工作表中，然后将其保存为 PDF 并发送到源代码中定义的电子邮件联系人。

由于相关的邮件收件人可能会有所不同，我想包含一个下拉列表，其中可以添加多个收件人。

我可以将用户的 Outlook 联系人链接到该下拉列表，而不是向该列表中添加数十个联系人吗？

'PDF EXPORT
ActiveSheet.ExportAsFixedFormat Filename:=varResult, Type:=xlTypePDF, OpenAfterPublish:=True, _
IncludeDocProperties:=True

Dim objOutlook As Object
Dim objMail As Object

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With objMail
    .To = "X@X.com"
    .Subject = "finished userform"
    .Body = "automatically sent mail. UserForm attached."
    .Attachments.Add varResult
    .Send        'automatically sends mail.
End With

UserForm.Hide
End Sub

Answer 1

请尝试下一个功能：

Private Function GetOutlookAddressB() As Variant
    Dim objOutlook As Outlook.Application, objAddressList As Outlook.AddressList
    Dim oItem As Outlook.AddressEntry, olNs As Outlook.NameSpace, i As Long, arrAddr
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set olNs = objOutlook.GetNamespace("MAPI")
    Set objAddressList = olNs.AddressLists("Contacts") '  if not returning contacts you can try
                                                       ' "Contacts (This computer only)", "Global Address List"
    ReDim arrAddr(objAddressList.AddressEntries.count - 1)
    For Each oItem In objAddressList.AddressEntries
        If oItem.Address <> "" Then
          arrAddr(i) = oItem.Name: i = i + 1
        End If
    Next
    GetOutlookAddressB = arrAddr
End Function

要为您的案例选择合适的通讯簿，请打开 Outlook，按通讯簿按钮 (Ctrl + Shift + B) 并查看您的安装使用的通讯簿名称。如果不是“联系人”，请更改为特定名称'

可以调用该函数以在“活动工作表的A1单元格上创建验证列表（您可以根据需要更改单元格）：

Private Sub createListValidation()
    Dim sh As Worksheet, valCell As Range, arrAddress
    Set sh = ActiveSheet
    Set valCell = sh.Range("A1") 'use here the cell you want
    arrAddress = GetOutlookAddressB
    With valCell.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, Formula1:=Join(arrAddress, ", ")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
  End With
End Sub

已编辑：

上述验证方式，使用自定义列表，有效，但对于大量地址，Excel 接受自定义列表，您可以看到验证有效，但保存并重新打开工作簿后可能会出现问题并且“不喜欢它”，不再。对于这种情况，请使用下一种方式。它将数组内容放在一个范围内（您可以使用隐藏表），然后使用Name 进行列表验证。这不是那么紧凑/优雅，但更安全：

Private Sub createListValidationNR() 'using a Named range
    Dim sh As Worksheet, valCell As Range, arrAddress
    Set sh = ActiveSheet
    Set valCell = sh.Range("A1")         'use here the cell you want validating
    arrAddress = GetOutlookAddressB  'receive the address book in a 1D array
    'use here a sheet and a convenient cell, where to drop the array content and Name the range:
    valCell.Validation.Delete                'delete validation to not create a problem breaking the
                                                   'existing validation, if any...
    On Error Resume Next: sh.Parent.Names("myAddressBook").Delete 'delete the Name, if exists
    On Error GoTo 0
    With sh.Range("B1").Resize(UBound(arrAddress) + 1, 1)
         .Value = Application.Transpose(arrAddress)  'drop the array content
         .Name = "myAddressBook"                       'create a named range
    End With
    With valCell.Validation
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                Operator:=xlBetween, Formula1:=sh.Parent.Names("myAddressBook")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
  End With
End Sub