Question

这些论坛的新手，看起来很多知识渊博的人都在帮忙！我对VBA的前景和VBA都很陌生。

我将一些代码拼凑在一起，使用了我在很多研究后发现的例子，并根据我的需要进行了调整以完成我需要做的事情。现在它非常混乱，因为我只是在评论我不需要的东西，而只是添加要测试的东西。它工作并做我需要它做的一切，除了它错过了最后收到的电子邮件。我还没有清理过代码，因为我喜欢有什么东西可供参考。

此代码应该收到新电子邮件后

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

Ok niton感谢您的信息，我已经修改了相关代码并且它在下面，您的想法修复了我的一些问题，如果我注释掉“find_unread”...“AddContactsToAddressesAuto”100％的时间完美无缺地工作！现在我的问题仍然类似，随着下面的更改，最后收到的电子邮件留在收件箱中，所以它在“find_unread”中的东西我认为这是搞乱的事情，我只是想弄清楚是什么！

展望2000 vba更新

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

Answer 1

For Each在删除/移动项目时不能很好地跟踪并更改集合中的项目数。

使用这种类型的循环。

For i = folder.Items.Count To 1 Step -1 
    Set obj = folder.Items(i)
    obj.Move myDestFolder
Next

自动联系人添加/分拣/回复工作，但错过了上次收到的电子邮件

1 个答案: