これらのフォーラムは初めてですが、多くの知識豊富な人々が助けてくれているようです! 私は Outlook 用の VBA と、VBA 全般を初めて使用します。
多くの調査の後に見つけた例を使用して、いくつかのコードをつなぎ合わせ、必要なことを実行するように調整しました。必要のないものをコメントアウトし、テストするものを追加しているだけなので、今は非常に面倒です。最後に受信した電子メールを見逃すことを除いて、動作し、必要なことはすべて実行します。参照用にそこにあったものを持っているのが好きなので、まだコードをクリーンアップしていません。
このコードは、新しい電子メールを受信したときに必要です
1) 未読メールをチェックして、電子メールに既に連絡先にアドレスが含まれているかどうかを確認します。そうでない場合は、連絡先を追加し、受信した電子メールを指定されたフォルダに移動します 2) 自動返信し、既読としてマークします
コードは (私が知る限り) 1 つの小さな詳細を除いて正しく機能しています。
一度に複数の電子メールを受信すると、最後に受信した電子メールを一貫して見逃します。私は読んで、読んで、読んで、なぜ最後のメールが見逃されたのか頭を悩ませることはできません. ここでの助け、提案、アイデア、または正しい方向へのポイントは大歓迎です!
私は 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
わかりました niton 情報に感謝します。関連するコードを修正しました。以下に示します。「find_unread」をコメントアウトすると、あなたのアイデアで問題の一部が修正されました... 今でも私の問題は似ていますが、以下の変更により、最後に受信した電子メールが受信トレイに残っているため、「find_unread」の何かが混乱していると思います。
Outlook 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