Outlook中自动添加vcf附件为联系人

Sub AddContacts()
Dim mai As Object
   
   If TypeName(Application.ActiveWindow) = "Explorer" Then
       For Each mai In Application.ActiveExplorer.Selection
           If mai.Class = olMail Then processContact mai
       Next
   ElseIf TypeName(Application.ActiveWindow) = "Inspector" Then
       If mai.Class = olMail Then processContact Application.ActiveInspector.CurrentItem
   Else
       Exit Sub
   End If
End Sub

Sub processContact(mai As MailItem)
Dim att As Attachment
Dim obj As Object
Dim con As Object
Dim strFullName As String
Dim strID As String
Dim strFolderPath As String
Const intTempFolder As Integer = 2
   
   strFolderPath = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(intTempFolder)
   For Each att In mai.Attachments
       strID = ""
       If LCase(Right(att.FileName, 4)) = ".msg" Then
           att.SaveAsFile (strFolderPath & "\" & att.FileName)
           Set obj = Application.CreateItemFromTemplate(strFolderPath & "\" & att.FileName)
           With obj
               .Save
               strID = .EntryID
               If .Class = olDistributionList Then
                   strFullName = .DLName
               ElseIf Class = olContact Then
                   strFullName = .FullName
               End If
               .Close olDiscard
           End With
           Kill (strFolderPath & "\" & att.FileName)
       ElseIf LCase(Right(att.FileName, 4)) = ".vcf" Then
           att.SaveAsFile (strFolderPath & "\" & att.FileName)
           Set obj = Application.GetNamespace("MAPI").OpenSharedItem(strFolderPath & "\" & att.FileName)
           With obj
               strID = .EntryID
               strFullName = .FullName
               .Close olSave
           End With
           Kill (strFolderPath & "\" & att.FileName)
       End If
       If strID <> "" Then
           For Each con In Application.Session.GetDefaultFolder(olFolderContacts).Items
               If con.Class = olDistributionList Then
                   If con.DLName = strFullName And con.EntryID <> strID Then
                       Application.Session.GetItemFromID(strID).Delete
                       Exit For
                   End If
               ElseIf con.Class = olContact Then
                   If con.FullName = strFullName And con.EntryID <> strID Then
                       Application.Session.GetItemFromID(strID).Delete
                       Exit For
                   End If
               End If
           Next
       End If
   Next
End Sub