outlook 宏 自动导入通讯录

Sub 导入联系人到某某某文件夹()

'1.需建立有某某某文件夹；导入前请清空该文件夹

    Dim c As Object
    Dim OutlookApp           As Object 'Outlook.Application
    Dim myNamespace, myFolder, myItem       As Object 'Outlook.Namespace
    Dim myNewFolder         As Object
    Dim MsgFile             As Object
    Dim path                As String
    Dim myMsgFile           As String
    Dim i                   As Integer
 
    Set OutlookApp = CreateObject("outlook.application")
    Set myNamespace = OutlookApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderContacts)
   
'获取某某某文件夹(联系人),并清空

    Set myNewFolder = myFolder.Folders("某某某")
 
    Set myItem = myNewFolder.Items
    i = myNewFolder.Items.Count
    Do While i > 0
        myItem(myNewFolder.Items.Count).Delete
        i = i - 1
    Loop
    
    path = "\\192.168.0.8\share\邮箱地址\邮件地址\"
    myMsgFile = Dir(path & "*.msg")
    
'遍历此目录下的所有msg文件
    Do While myMsgFile <> ""
        Set MsgFile = myNamespace.OpenSharedItem(path & myMsgFile)
        With MsgFile
            Set c = myNewFolder.Items.Add
            c.FirstName = .FirstName
            c.Email1Address = .Email1Address
            c.Save
        End With
        MsgFile.Close 1 'olDiscard=1，关闭时不保存更改
        myMsgFile = Dir
    Loop

    
    
'复制完关闭Outlook
'OutlookApp.Quit
'Set myMail = Nothing
'Set myNamespace = Nothing
'Set OutlookApp = Nothing
    
End Sub