把所有地址簿里的联系人增加到自动记录联系人里

Long_III

对于重装系统等，Outlook里原先的自动记录的联系人全没了，在之后的操作时又得输一遍Outlook才能记下来。
下面的代码将在通讯簿里循环一遍，新建一个邮件，把所有通讯簿里的联系人添加到收件人里。等代码运行完之后，自己可以断开网络，发送这封邮件，然后在发件箱里删除此邮件。

Sub add_address()    '把所有地址簿里的联系人增加到自动记录联系人里
    Dim myOL As New Outlook.Application
    Dim MyNS As NameSpace
    Dim MyContact
    Dim MyMail As Outlook.MailItem
    Dim f As Outlook.ContactItem    '这里的f即包括联系人对象也包括联系人组对象
    Dim MyTemp As Outlook.Recipients    '临时新建邮件的收件人的集合

    On Error Resume Next
    Set MyNS = myOL.GetNamespace("MAPI")
    Set MyContact = MyNS.GetDefaultFolder(olFolderContacts).Items    '取得联系人组里的所有对象
    Set MyMail = myOL.CreateItem(olMailItem)
    Set MyTemp = MyMail.Recipients    'Outlook里的增加组成员帮助里提示居然要增加recipients对象，没办法只好新建一个邮件

    For Each f In MyContact    '在联系人文件夹里循环
        MyTemp.Add f.Email1Address
    Next

    MyMail.Display

    Set MyContact = Nothing
    Set MyNS = Nothing
End Sub

对于有多个PST文件形成的多个通讯簿，建议通过导入导出的方法都放到默认的通讯簿下面。

Long_III

对其他PST文件的访问，可以直接用folders来实现，以下代码已测试
Sub get_address()    '用folders来访问非默认的PST文件里的联系人
    Dim myOL As New Outlook.Application
    Dim MyNS As NameSpace
    Dim Myfolders As Folders
    Dim MyContacts

    Dim ff    'As DistListItem

    Set MyNS = myOL.GetNamespace("MAPI")

    'Set Myfolders = MyNS.Folders("BDO-tax").Folders '默认的PST文件
    Set Myfolders = MyNS.Folders("BDO-accounting").Folders    '其他的PST文件

    For Each f In Myfolders 'PST文件里的所有文件夹
        Debug.Print f.Name
    Next

    Set MyContacts = Myfolders("联系人").Items

    'On Error Resume Next
    For Each ff In MyContacts
        m = m + 1
        If TypeName(ff) = "ContactItem" Then '联系人
            Debug.Print m, ff.Email1Address, ff.FullName
        ElseIf TypeName(ff) = "DistListItem" Then '联系人组
            Debug.Print m, ff.Subject
        End If
    Next

    Set MyContact = Nothing
    Set MyNS = Nothing
End Sub

Long_III

本回复已删除

[ 本帖最后由 Long_III 于 2008-11-26 15:42 编辑 ]