Outlook 2010 VBA-单击邮件时将发件人添加到联系人

有点小问题，希望有人能帮我

（Outlook 2010 VBA）

这是我当前的代码，我需要的是当我点击一封邮件时（只有我点击的邮件，而不是文件夹/同一位置的所有邮件） 它必须检查邮件的发件人是否已经在我的联系人或 通讯簿“所有用户”， 如果还没有，打开AddContact窗口，填写他/她的信息

还不起作用的是：

• 最重要的是，当我点击邮件时，它不会运行脚本
• 电流检查触点是否已经存在，是否不工作 并带有一个vbMsgBox（是或否以及响应内容），它不是我想要/需要的 如果接触已经存在，则无需发生任何事情

我希望我提供了足够的信息，有人可以在这里帮助我：）

嘿，我还有最后一个问题

'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

这将检查姓名是否已在contacts中， 我需要它检查电子邮件地址是否在contacts中， 你能帮我吗

我有这样的想法

set oSendermail = ?the e-mailaddress?

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

解决方案（包括测试程序）如下所示： （假设我们只考虑外部SMTP邮件。调整到您的联系人文件夹的路径，并添加更多的错误检查！）

选项显式
私有声明函数GetTickCount Lib“kernel32.dll”（）的长度为
子AutoContactMessageRule（作为Outlook.mailItem的新邮件）
为每个传入邮件调用的“脚本”例程
'此子例程必须使用
'Outlook的规则助手
像字符串一样暗的入口
Dim StoreID作为变体
将mi设置为Outlook.mailItem
将contactFolder设置为Outlook.Folder
将联系人设置为Outlook.ContactItem
关于错误转到错误处理程序
“我们必须通过应用程序引用访问新邮件
'以避免安全警告
EntryID=newMail.EntryID
StoreID=newMail.Parent.StoreID
Set mi=Application.Session.GetItemFromID（EntryID，StoreID）
与米
如果.SenderEmailType=“SMTP”，则
设置contactFolder=FindFolder（“Kemper\\u local\TestContacts”）
设置contact=contactFolder.items.Find（“[Email1Address]=”&Chr（34）和.SenderEmailAddress&Chr（34））
如果不是TypeName（联系）“Nothing”，则
设置contact=contactFolder.items.Add（olContactItem）
contact.Email1Address=.SenderEmailAddress
contact.Email1地址类型=.SenderEmailType
contact.FullName=.SenderName
联系，救命
如果结束
如果结束
以
出口接头
错误处理程序：
MsgBox错误描述，vbCritical，“Ooops！”
呃，明白了
错误转到0
端接头
私有函数FindFolder（路径为字符串）作为Outlook.Folder
'找到MAPI文件夹。
'使用“/”分隔子文件夹。示例：“My/2012/Letters”
将fd设置为Outlook.Folder
Dim subPath（）作为字符串
作为整数的Dim I
Dim ns作为名称空间
像线一样变暗
关于错误转到错误处理程序
s=替换（路径“\”，“/”）
如果仪表“/”=1，则
s=Mid（s，3）
如果结束
子路径=拆分（s，“/”，-1，1）
Set ns=Application.GetNamespace（“MAPI”）
对于I=0到UBound（子路径）
如果I=0，那么
设置fd=ns.文件夹（子路径（0））
其他的
设置fd=fd.Folders（子路径（I））
如果结束
如果fd不算什么，那么
退出
如果结束
下一个
设置FindFolder=fd
退出功能
错误处理程序：
Set FindFolder=Nothing
端函数
公共子测试ContactMessageRule（）
'测试邮件处理程序AutoContactMessageRule（）的例程'
'没有收到邮件消息
'在执行此例程之前选择现有邮件
作为对象的Dim objItem
将objMail设置为Outlook.mailItem
迪姆开始的时间一样长
对于Application.ActiveExplorer.Selection中的每个objItem
如果TypeName（objItem）=“MailItem”，则
设置objMail=objItem
started=GetTickCount（）
AutoContactMessageRule objMail
调试。打印“已用”和（GetTickCount（）-started）/1000#和“s”
如果结束
下一个
端接头

定义一个规则，如果发件人包含在您的通讯簿中，则将所有传入邮件移动到您的收件箱，然后停止规则处理。然后，第二条规则只针对地址簿中不存在的发件人调用。第二条规则应调用VBA子例程，该子例程在将邮件移动到收件箱之前自动将发件人添加到通讯簿。这里解释了如何定义规则：嘿，感谢你的快速反应，这是我从老板那里收到的一项任务，必须贯穿整个公司，它必须检查发件人是否存在，如果它没有打开addContact窗口，如果你点击邮件，而不是在你收到新邮件时。我希望你能进一步帮助我：）好的。如果第一条规则的前提条件是发件人在通讯簿中，这意味着发件人存在。这些规则在用户单击邮件之前执行。你还有其他顾虑吗？我明白了，你能举例说明我是如何做到的吗~谢谢谢谢谢谢：）我能从中得到一些技巧来解决这个问题。嘿，我还有最后一个问题，我把我的问题放在下面了。。我希望您能帮助我：）如我的解决方案中所述：感兴趣的是contactFolder.items.Find（“[Email1Address]=”&Chr（34）&.SenderEmailAddress&Chr（34））。您的方法的缺点是，您获得的联系人只有正确的SMTP邮件地址，但通常没有正确的全名。可以标记自动创建的联系人并手动编辑。

set oSendermail = ?the e-mailaddress?

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

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