Outlook 2010 VBA - 添加发件人到联系人当我点击一个邮件
问题描述:
有一点问题,我希望有人能帮助我。Outlook 2010 VBA - 添加发件人到联系人当我点击一个邮件
(如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
答
溶液(包括测试程序)可以看看如下: (假设我们只考虑外部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
定义发件人是否包含在你的地址簿中其中将所有传入邮件到您的邮箱规则,然后停止规则处理。然后,只有发件人不在您的地址簿中才会调用第二条规则。第二条规则应该调用一个VBA子例程,它在将邮件移动到收件箱之前自动将发件人添加到地址簿中。如何定义规则在这里解释:http://superuser.com/questions/174145/can-you-create-a-rule-in-outlook-to-move-all-emails-that-were-sent-to -any-distri – 2013-02-26 10:30:19
嘿,感谢您的快速反应,这是我从我的老板那里得到的一个任务,而且这个任务必须贯穿整个公司,它必须检查发件人是否存在,如果它没有打开addContact窗口,如果你点击一个邮件,而不是当你收到一封新邮件。我希望你能进一步帮助我:) – Ricje20 2013-02-26 10:32:40
好的。如果您的第一条规则具有发件人在地址簿中的前提条件,这意味着发件人存在。规则在用户点击邮件之前执行。你还有疑虑吗? – 2013-02-26 10:40:53