Outlook 2010 VBA - 添加发件人到联系人当我点击一个邮件

Question

有一点问题，我希望有人能帮助我。

（如Outlook 2010 VBA）

这是我当前的代码，我需要的是当我在邮件上的（只有邮件我点击，而不是在文件夹/同一个地方每封邮件）点击 有要检查邮件的发送者已经在我的联系人或 通讯录“所有用户”， ，如果它不是其中一个呢，打开的addContact窗口，并在他/她的信息填写

什么不起作用的是：

• 最重要的是，当我点击邮件时它不运行脚本
• 当前检查联系人是否已经存在不起作用 并且带有vbMsgBox（是或否和响应的东西）不是我想要的/需要的 如果联系人已经存在，则不需要发生任何事情。

我希望我给了足够的信息，并有人能帮助我在这里:)

Sub AddAddressesToContacts(objMail As Outlook.MailItem) 
Dim folContacts As Outlook.MAPIFolder 
Dim colItems As Outlook.Items 
Dim oContact As Outlook.ContactItem 
Dim oMail As Outlook.MailItem 
Dim obj As Object 
Dim oNS As Outlook.NameSpace 

''don't want or need a vbBox/ask box, this is a part of the current contactcheck 
''wich doesn't work and is totaly wrong :P 
Dim response As VbMsgBoxResult 

Dim bContinue As Boolean 
Dim sSenderName As String 

On Error Resume Next 

Set oNS = Application.GetNamespace("MAPI") 
Set folContacts = oNS.GetDefaultFolder(olFolderContacts) 
Set colItems = folContacts.Items 

''this selects the mail that is currently selected. 
''what i want is that the sender of the new incoming mail gets added to contacts 
''(ofcourse, if that contact doesn't exsist yet) 
''so the new incoming mail gotta be selected. 
For Each obj In Application.ActiveExplorer.Selection 

If obj.Class = olMail Then 
Set oContact = Nothing 

bContinue = True 
sSenderName = "" 

Set oMail = obj 

sSenderName = oMail.SentOnBehalfOfName 
If sSenderName = ";" Then 
sSenderName = oMail.SenderName 
End If 

Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'") 

''this part till the --- is wrong, i need someting to check if the contact (the sender) 
''already exsists. Any ideas? 
If Not (oContact Is Nothing) Then 
    response = vbAbort 
If response = vbAbort Then 
    bContinue = False 
End If 
End If 
''--------- 

If bContinue Then 
Set oContact = colItems.Add(olContactItem) 
With oContact 

.Email1Address = oMail.SenderEmailAddress 
.Email1DisplayName = sSenderName 
.Email1AddressType = oMail.SenderEmailType 
.FullName = oMail.SenderName 

'.Save 

oContact.Display 

End With 
End If 
End If 
Next 

Set folContacts = Nothing 
Set colItems = Nothing 
Set oContact = Nothing 
Set oMail = Nothing 
Set obj = Nothing 
Set oNS = Nothing 
End Sub 

哎，我还是有最后一个问题，

'sets the name of the contact 
    Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'") 

    'checks if the contact exsist, if it does exit the for loop 
    If Not oContact Is Nothing Then 
     Exit For 
    End If 
End If 

此检查，如果名称是已经在联系人， 我需要它，它会检查电子邮件是否在联系人或不， 你能帮我吗？

我有成才喜欢这一点

set oSendermail = ?the e-mailaddress? 

     If Not oSendermail Is Nothing Then 
      Exit For 
     End If 
End If 

Answer 1

溶液（包括测试程序）可以看看如下： （假设我们只考虑外部SMTP邮件调整路径到您的联系人文件夹并添加。一些错误检查！）

Option Explicit 

Private Declare Function GetTickCount Lib "kernel32.dll"() As Long 

Sub AutoContactMessageRule(newMail As Outlook.mailItem) 
    ' "script" routine to be called for each incoming Mail message 
    ' This subroutine has to be linked to this mail type using 
    ' Outlook's rule assistant 
    Dim EntryID As String 
    Dim StoreID As Variant 
    Dim mi As Outlook.mailItem 
    Dim contactFolder As Outlook.Folder 
    Dim contact As Outlook.ContactItem 

    On Error GoTo ErrorHandler 

    ' we have to access the new mail via an application reference 
    ' to avoid security warnings 
    EntryID = newMail.EntryID 
    StoreID = newMail.Parent.StoreID 

    Set mi = Application.Session.GetItemFromID(EntryID, StoreID) 

    With mi 
     If .SenderEmailType = "SMTP" Then 
      Set contactFolder = FindFolder("Kemper\_local\TestContacts") 

      Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34)) 
      If Not TypeName(contact) <> "Nothing" Then 
       Set contact = contactFolder.items.Add(olContactItem) 
       contact.Email1Address = .SenderEmailAddress 
       contact.Email1AddressType = .SenderEmailType 
       contact.FullName = .SenderName 
       contact.Save 
      End If 
     End If 
    End With 

    Exit Sub 

ErrorHandler: 
    MsgBox Err.Description, vbCritical, "Ooops!" 
    Err.Clear 
    On Error GoTo 0 
End Sub 


Private Function FindFolder(path As String) As Outlook.Folder 
' Locate MAPI Folder. 
' Separate sub-folder using '/' . Example: "My/2012/Letters" 
    Dim fd As Outlook.Folder 
    Dim subPath() As String 
    Dim I As Integer 
    Dim ns As NameSpace 
    Dim s As String 

    On Error GoTo ErrorHandler 

    s = Replace(path, "\", "/") 

    If InStr(s, "//") = 1 Then 
     s = Mid(s, 3) 
    End If 

    subPath = Split(s, "/", -1, 1) 
    Set ns = Application.GetNamespace("MAPI") 

    For I = 0 To UBound(subPath) 
     If I = 0 Then 
     Set fd = ns.Folders(subPath(0)) 
     Else 
     Set fd = fd.Folders(subPath(I)) 
     End If 
     If fd Is Nothing Then 
     Exit For 
     End If 
    Next 

    Set FindFolder = fd 
    Exit Function 

ErrorHandler: 
    Set FindFolder = Nothing 
End Function 


Public Sub TestAutoContactMessageRule() 
    ' Routine to test Mail Handlers AutoContactMessageRule()' 
    ' without incoming mail messages 
    ' select an existing mail before executing this routine 
    Dim objItem As Object 
    Dim objMail As Outlook.mailItem 
    Dim started As Long 

    For Each objItem In Application.ActiveExplorer.Selection 
     If TypeName(objItem) = "MailItem" Then 
      Set objMail = objItem 

      started = GetTickCount() 
      AutoContactMessageRule objMail 

      Debug.Print "elapsed " & (GetTickCount() - started)/1000# & "s" 
     End If 
    Next 
End Sub