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