这些论坛的新手，看起来有很多知识渊博的人在帮助！我对 VBA 的前景和一般的 VBA 都很陌生。
我拼凑了一些代码，使用经过大量研究后找到的示例，并对其进行了定制以完成我需要它做的事情。现在非常混乱，因为我只是在注释掉我不需要的东西，并且只是在添加要测试的东西。它可以正常工作并完成我需要它做的所有事情，除了它错过了最后收到的电子邮件。我还没有清理代码，因为我喜欢周围有 WAS 以供参考。
此代码应在收到新电子邮件后
1) 检查未读邮件，查看邮件是否包含联系人中已有的地址，如果没有，则添加联系人，并将收到的邮件移动到指定文件夹 2) 自动回复并标记为已读
代码（据我所知）运行正常，除了一个小细节：
如果一次收到多于一封电子邮件，它会始终错过最后收到的电子邮件。我已经阅读，阅读，阅读，只是无法理解为什么错过了最后一封电子邮件。非常感谢这里的任何帮助、建议、想法或正确方向的观点！
我正在使用 Outlook 2000，我整理的相关代码如下
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set msg = item
'MsgBox ("New Join!")
' MsgBox msg.Subject
Call AddAddressesToContactsAuto
' Call find_unread '''''ADD THIS BACK
' MsgBox msg.Body
' test field
' Dim oout As Object
' Dim omsg As Object
' Set oout = CreateObject("Outlook.Application")
' Set omsg = oout.CreateItem(0)
' With omsg
' .To = msg.Subject
' .CC = ""
' .BCC = ""
' .Subject = Thanks
' .Body = (msg.Body & "Thank you for joining Club PFM! You will be receiving your first newsletter with your special Club PFM offer within the next 7 days!")
' .Display
' End With
' testing
' If omsg.Sent Then
' MsgBox (" Sent ")
' Else
' MsgBox (" Not Send ! ")
' End If
' Set oout = Nothing
' Set omsg = Nothing
' end test field
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Public Sub AddAddressesToContactsAuto()
Dim folContacts As Outlook.MAPIFolder
Dim folContacts2 As Outlook.MAPIFolder
Dim folContacts3 As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim colItems2 As Outlook.Items
Dim colItems3 As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oContact2 As Outlook.ContactItem
Dim oContact3 As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim folder As MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
Dim emailz As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set folContacts2 = oNS.GetDefaultFolder(olFolderContacts).Folders("Awaiting Invitation")
Set folContacts3 = oNS.GetDefaultFolder(olFolderContacts).Folders("Added To Mail List")
Set colItems = folContacts.Items
Set colItems2 = folContacts2.Items
Set colItems3 = folContacts3.Items
Set folder = oNS.GetDefaultFolder(olFolderInbox) '.Folders("Awaiting Invitation")
Set myDestFolder = oNS.GetDefaultFolder(olFolderInbox).Folders("Awaiting Invitation")
For Each obj In folder.Items
If (obj.Class = olMail) And (obj.UnRead) Then
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing
bContinue = True
sSenderName = ";"
Set oMail = obj
sSenderName = oMail.Body
emailz = oMail.Subject
If sSenderName = ";" Then
sSenderName = oMail.Body
emailz = oMail.Subject
End If
Set oContact = colItems.Find("[E-mail] = '" & emailz & "'")
Set oContact2 = colItems2.Find("[E-mail] = '" & emailz & "'")
Set oContact3 = colItems3.Find("[E-mail] = '" & emailz & "'")
'start checks
'default folder
If Not (oContact Is Nothing) Then
response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'awaiting invitation
If Not (oContact2 Is Nothing) Then
response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'added to mail list
If Not (oContact3 Is Nothing) Then
response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'end checks
If bContinue = True Then
oMail.Move myDestFolder 'ADDED THIS REMOVE IF YOU BREAK IT!!!
Set oContact = colItems2.Add(olContactItem)
With oContact
.Body = "Club PFM Member!"
.Email1Address = emailz
.BusinessAddress = emailz
.FullName = sSenderName
.Save
End With
'testing start
'testing end
End If
End If
emailz = ""
Next
Set folContacts = Nothing
Set folContacts2 = Nothing
Set folContacts3 = Nothing
Set colItems = Nothing
Set colItems2 = Nothing
Set colItems3 = Nothing
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
Call find_unread
End Sub
Sub find_unread()
On Error GoTo eh:
' I want to be able to catch up by reading all my unread messages
Dim ns As Outlook.NameSpace
Dim folder As MAPIFolder
Dim item As Object
Dim msg As MailItem
'for sending mail
Dim oout As Object
Dim omsg As Object
'end sending mail
Dim Thanks As String
' Open the inbox folder
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox).Folders("Awaiting Invitation")
' Loop through items in the inbox folder
For Each item In folder.Items
DoEvents
If (item.Class = olMail) And (item.UnRead) Then
' This message has not been read. Display it modally
Set msg = item
item.UnRead False
Thanks = ("Thanks for joining Club PFM!")
MsgBox ("7 Day notice sent to: " & msg.Subject)
'create auto response
Set oout = CreateObject("Outlook.Application")
Set omsg = oout.CreateItem(0)
With omsg
.To = msg.Subject
.CC = ""
.BCC = ""
.Subject = Thanks
.Body = (msg.Body + "Thank you for joining Club PFM! You will be receiving your first newsletter with your special Club PFM offer within the next 7 days!")
.Display
End With
'end response
'try calling other operations, see if they work!!
'does not work in this fashion, try putting entire code here, then call this on new mail event
'Call AddAddressesToContacts
'end calling operations
' uncomment the next line to have it only find one unread
' message at a time
'Exit For
End If
Next
' If you uncommented the line to read individual messages,
' comment the next line so you don't get a message box
' every single message!
MsgBox "All messages in Inbox are read", vbInformation, "All Read"
Exit Sub
eh:
MsgBox Err.Description, vbCritical, Err.Number
End Sub
好的，谢谢你的信息，我已经修改了相关代码，它在下面，你的想法已经解决了我的一些问题，如果我注释掉“find_unread”......“AddContactsToAddressesAuto”100% 的时间都完美无缺！现在我的问题仍然是相似的，通过下面的更改，最后收到的电子邮件留在了收件箱中，所以它在“find_unread”中的东西我认为这把事情搞砸了，我就是不知道是什么！
展望 2000 vba 更新
Public Sub AddAddressesToContactsAuto()
Dim folContacts As Outlook.MAPIFolder
Dim folContacts2 As Outlook.MAPIFolder
Dim folContacts3 As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim colItems2 As Outlook.Items
Dim colItems3 As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oContact2 As Outlook.ContactItem
Dim oContact3 As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim folder As MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
Dim emailz As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set folContacts2 = oNS.GetDefaultFolder(olFolderContacts).Folders("Awaiting Invitation")
Set folContacts3 = oNS.GetDefaultFolder(olFolderContacts).Folders("Added To Mail List")
Set colItems = folContacts.Items
Set colItems2 = folContacts2.Items
Set colItems3 = folContacts3.Items
Set folder = oNS.GetDefaultFolder(olFolderInbox) '.Folders("Awaiting Invitation")
Set myDestFolder = oNS.GetDefaultFolder(olFolderInbox).Folders("Awaiting Invitation")
'For Each obj In folder.Items
For I = folder.Items.Count To 1 Step -1
Set obj = folder.Items(I)
If (obj.Class = olMail) And (obj.UnRead) Then
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing
bContinue = True
sSenderName = ";"
Set oMail = obj
sSenderName = oMail.Body
emailz = oMail.Subject
If sSenderName = ";" Then
sSenderName = oMail.Body
emailz = oMail.Subject
End If
Set oContact = colItems.Find("[E-mail] = '" & emailz & "'")
Set oContact2 = colItems2.Find("[E-mail] = '" & emailz & "'")
Set oContact3 = colItems3.Find("[E-mail] = '" & emailz & "'")
'start checks
'default folder
If Not (oContact Is Nothing) Then
response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'awaiting invitation
If Not (oContact2 Is Nothing) Then
response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'added to mail list
If Not (oContact3 Is Nothing) Then
response = MsgBox(emailz & " Already exists in contacts! Add anyways?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
'end checks
If bContinue = True Then
obj.Move myDestFolder 'ADDED THIS REMOVE IF YOU BREAK IT!!!
Set oContact = colItems2.Add(olContactItem)
With oContact
.Body = "Club PFM Member!"
.Email1Address = emailz
.BusinessAddress = emailz
.FullName = sSenderName
.Save
End With
'testing start
'testing end
End If
End If
emailz = ""
Next
Set folContacts = Nothing
Set folContacts2 = Nothing
Set folContacts3 = Nothing
Set colItems = Nothing
Set colItems2 = Nothing
Set colItems3 = Nothing
Set oContact = Nothing
Set oContact2 = Nothing
Set oContact3 = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
Call find_unread
End Sub
Sub find_unread()
On Error GoTo eh:
' I want to be able to catch up by reading all my unread messages
Dim ns As Outlook.NameSpace
Dim folder As MAPIFolder
Dim item As Object
Dim msg As MailItem
'for sending mail
Dim oout As Object
Dim omsg As Object
Dim obj As Object
'end sending mail
Dim Thanks As String
' Open the inbox folder
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = ns.GetDefaultFolder(olFolderInbox).Folders("Awaiting Invitation")
' Loop through items in the inbox folder
'For Each item In folder.Items
For I = folder.Items.Count To 1 Step -1
Set obj = folder.Items(I)
DoEvents
If (obj.Class = olMail) And (obj.UnRead) Then
' This message has not been read. Display it modally
Set msg = obj
obj.UnRead False
Thanks = ("Thanks for joining Club PFM!")
MsgBox ("7 Day notice sent to: " & msg.Subject)
'create auto response
Set oout = CreateObject("Outlook.Application")
Set omsg = oout.CreateItem(0)
With omsg
.To = msg.Subject
.CC = ""
.BCC = ""
.Subject = Thanks
.Body = (msg.Body + "Thank you for joining Club PFM! You will be receiving your first newsletter with your special Club PFM offer within the next 7 days!")
.Display
End With
'end response
'try calling other operations, see if they work!!
'does not work in this fashion, try putting entire code here, then call this on new mail event
'Call AddAddressesToContacts
'end calling operations
' uncomment the next line to have it only find one unread
' message at a time
'Exit For
End If
Next
' If you uncommented the line to read individual messages,
' comment the next line so you don't get a message box
' every single message!
MsgBox "All messages in Inbox are read", vbInformation, "All Read"
Exit Sub
eh:
MsgBox Err.Description, vbCritical, Err.Number
End Sub