My code:
Public WithEvents myItem As Outlook.MailItem
Private Sub Application_ItemLoad(ByVal Item As Object)
If Item.Class = olMail Then
Set myItem = Item
End If
End Sub
Private Sub myItem_Open(Cancel As Boolean)
Dim oAccount As Outlook.Explorer
Dim oMail As MailItem
Dim Recip As Outlook.Recipient
Set oAccount = Application.ActiveExplorer
MsgBox (oAccount.CurrentFolder.Store)
If oAccount.CurrentFolder.Store = "account#outlook.com" Then
MsgBox ("CC needs to be added")
Set Recip = myItem.Recipients.Add("cc#cc.cc")
Recip.Type = olCC
Recip.Resolve
Else
MsgBox ("no need to add CC")
End If
End Sub
I would like to add something like myItem.SentOnBehalfOfName = "sent#behalf.com" into my code. Pasting it into my code does not work. I probably have to set something before.
I tried myItem.SentOnBehalfOfName = "sent#behalf.com" but it does not do anything. It does not show any errors.
This tricky SentOnBehalfOfName behaviour is described in previous posts.
Private Sub myItem_Open_SentonBehalf_Test()
Dim oExpl As Explorer
Dim myItem As mailitem
Set oExpl = ActiveExplorer
Set myItem = CreateItem(olMailItem)
' Do not display
If oExpl.CurrentFolder.store = "account#outlook.com" Then
Debug.Print "myItem.SentOnBehalfOfName:" & "x " & myItem.SentOnBehalfOfName & " x"
myItem.SentOnBehalfOfName = "sent#behalf.com"
Debug.Print "myItem.SentOnBehalfOfName:" & "x " & myItem.SentOnBehalfOfName & " x"
' be careful to put this after updating SentOnBehalfOfName
myItem.Display
' Manually display the From field to see the updated entry
Else
Debug.Print "Wrong path."
End If
ExitRoutine:
Set myItem = Nothing
Set oExpl = Nothing
End Sub
Related
I am trying to auto forward an email from a specific sender and with a specific subject to a list of new recipients.
When I create a Run a Script Rule, my script is not shown.
Add my script via VBA Editor
Rules > Manage Rules & Alerts > Run a script
Select Run a script action -> Can not Select my script (script not show)
Option Explicit
Public WithEvents objInbox As Outlook.Folder
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInbox.Items
End Sub
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objForward As Outlook.MailItem
Dim xStr1 As String
Dim xStr2 As String
If TypeOf Item Is MailItem Then
Set objMail = Item
If (objMail.SenderEmailAddress = "T#com") And (objMail.Subject = "ZZZZZ") Then
Set objForward = objMail.Forward
GoTo commonOutput
End If
End If
Exit Sub
commonOutput:
With objForward
.HTMLBody = xStr1 & xStr2 & Item.HTMLBody
.Display
End With
Release:
Set myFwd = Nothing
End Sub
VBA script which can be assigned to a rule should have the following signature:
Public Sub Test(item as object)
' your code
End Sub
Your existing code does almost the same without rules. It handles the ItemAdd event for the Inbox folder, so you just need to replace the Display method call with Send:
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objForward As Outlook.MailItem
Dim xStr1 As String
Dim xStr2 As String
If TypeOf Item Is MailItem Then
Set objMail = Item
If (objMail.SenderEmailAddress = "T#com") And (objMail.Subject = "ZZZZZ") Then
Set objForward = objMail.Forward
GoTo commonOutput
End If
End If
Exit Sub
commonOutput:
With objForward
.HTMLBody = xStr1 & xStr2 & Item.HTMLBody
.Send
End With
Release:
Set myFwd = Nothing
End Sub
I want when Outlook opens to:
Search sent items with today's date with a specific subject.
If none is found, then send the "Test" email.
If found, display messagebox that says "Email is found".
I have only been able to do #1.
Private Sub Application_Startup()
Dim MItem As MailItem
Set MItem = Application.CreateItem(olMailItem)
MItem.Subject = "Test Alert"
MItem.To = "email#abc.com"
MItem.DeferredDeliveryTime = DateAdd("n", 1, Now) 'n = minute, h=hour
MItem.Send
End Sub
Update:
This is what I've tried. It doesn't seem to be searching the Sent Items folder with the subject.
Public Function is_email_sent()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim olFldr As Outlook.Folder
Dim olItms As Outlook.Items
Dim objItem As Outlook.MailItem
On Error Resume Next
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(Outlook.olFolderSentMail)
For Each objItem In olFldr.Items
If objItem.Subject = "Test Alert" And _
objItem.SentOn = Date Then _
MsgBox "Yes. Email found"
Else
MsgBox "No. Email not found"
Exit For
End If
Next objItem
End Function
The main error is misuse of On Error Resume Next. Errors are bypassed, not fixed.
Public Sub is_email_sentFIX()
Dim olFldr As Folder
Dim olItms As Items
Dim objItem As Object
Dim bFound As Boolean
' Not useful here.
' Use for specific purpose to bypass **expected** errors.
'On Error Resume Next
Set olFldr = Session.GetDefaultFolder(olFolderSentMail)
Set olItms = olFldr.Items
olItms.sort "[SentOn]", True
For Each objItem In olItms
If objItem.Class = OlMail Then
Debug.Print objItem.Subject
If objItem.Subject = "Test Alert" Then
Debug.Print objItem.SentOn
Debug.Print Date
If objItem.SentOn > Date Then
MsgBox "Yes. Email found"
bFound = True
Exit For
End If
End If
End If
Next objItem
If bFound = False Then
MsgBox "No. Email not found"
End If
End Sub
If there are an excessive number of items in the Sent folder the "not found" outcome will be slow.
One possible option to the brute force way is to Restrict to the specific item, rather than using If statements.
this is some code ive used;
Sub sendmail10101() 'this is to send the email from contents in a cell
Dim obApp As Object
Dim NewMail As MailItem
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem)
'You can change the concrete info as per your needs
With NewMail
.Subject = Cells(21, 3).Value
.To = Cells(18, 3).Value
.Body = "Good day" & vbCrLf & "i hope you are keeping well " & vbCrLf & vbCrLf & "please can you assist with the below members infomation;" & vbCrLf & vbCrLf & vbCrLf & Cells(20, 3).Value
'.Attachments.Add ("C:\Attachments\Test File.docx")
.Importance = olImportanceHigh
.Display
End With
Set obApp = Nothing
Set NewMail = Nothing
End Sub
the next part is to search the mail box, which you can also use to search from the first initial cell;
Option Explicit
Public Sub Search_Outlook_Emails()
Dim outApp As Outlook.Application
Dim outNs As Outlook.Namespace
Dim outStartFolder As Outlook.MAPIFolder
Dim foundEmail As Outlook.MailItem
Set outApp = New Outlook.Application
Set outNs = outApp.GetNamespace("MAPI")
'Start at Inbox's parent folder
Set outStartFolder = outNs.GetDefaultFolder(Outlook.olFolderInbox).Parent
'Or start at folder selected by user
'Set outStartFolder = outNs.PickFolder
If Not outStartFolder Is Nothing Then
Set foundEmail = Find_Email_In_Folder(outStartFolder, ThisWorkbook.Sheets("Dashboard").TextBox1.Value)
If Not foundEmail Is Nothing Then
If MsgBox("Email subject: " & foundEmail.Subject & vbNewLine & vbNewLine & _
"Folder: " & foundEmail.Parent.FolderPath & vbNewLine & vbNewLine & _
"Open the email?", vbYesNo, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' found") = vbYes Then
foundEmail.Display
End If
Else
MsgBox "", vbOKOnly, "'" & ThisWorkbook.Sheets("Dashboard").TextBox1.Value & "' not found"
End If
End If
End Sub
Private Function Find_Email_In_Folder(outFolder As Outlook.MAPIFolder, findText As String) As Outlook.MailItem
Dim outItem As Object
Dim outMail As Outlook.MailItem
Dim outSubFolder As Outlook.MAPIFolder
Dim i As Long
Debug.Print outFolder.FolderPath
Set Find_Email_In_Folder = Nothing
'Search emails in this folder
i = 1
While i <= outFolder.Items.Count And Find_Email_In_Folder Is Nothing
Set outItem = outFolder.Items(i)
If outItem.Class = Outlook.OlObjectClass.olMail Then
'Does the findText occur in this email's body text?
Set outMail = outItem
If InStr(1, outMail.Body, findText, vbTextCompare) > 0 Then Set Find_Email_In_Folder = outMail
End If
i = i + 1
Wend
DoEvents
'If not found, search emails in subfolders
i = 1
While i <= outFolder.Folders.Count And Find_Email_In_Folder Is Nothing
Set outSubFolder = outFolder.Folders(i)
'Only check mail item folders
If outSubFolder.DefaultItemType = Outlook.olMailItem Then Set Find_Email_In_Folder = Find_Email_In_Folder(outSubFolder, findText)
i = i + 1
Wend
End Function
the previous code brings us a message box to say if its been found which can be removed but maybe use the message box and an IF statement
such as;
with activeworkbook
if msgbox.value = "yes" then
range("A1:A30") = "COMPLETED" 'ASSUMING THIS IS THE INTIAL TEST RANGE IT WILL CHANGE THE SUBJECT THUS STOPPING THE FIRST MACRO
end if
end with
or if no message box then use something such as IF found then so on...
hope this helps
I have the following code to do something on every email I receive via Outlook in the inbox with a specfic subject. It works but if multiple emails arrive at the same time (ie when Outlook re-queries the server my email address is based off of) it will only run the below code on the most recent one received. Any suggestions?
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
Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
If InStr(Msg.SentOnBehalfOfName, "name") <> 0 Then
'Do Something
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
You could run the code on the items in the folder.
Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
If InStr(Msg.SentOnBehalfOfName, "name") <> 0 Then
'Do Something
' Move Msg to a "Done" folder
' or mark it read or some way
' you can use to not reprocess an item
End If
End If
SkippedItems
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Sub SkippedItems
dim i as long
Dim skippedMsg As MailItem
dim inboxItems as items
dim inboxItemsCount as long
On Error GoTo ErrorHandlerSkippedItems
set inboxItems = session.GetDefaultFolder(olFolderInbox).Items
inboxItemsCount = inboxItems.count
if inboxItemsCount > 0 then
for i = inboxItemsCount to 1 step -1
If TypeName(inboxItems(i)) = "MailItem" Then
Set skippedMsg = inboxItems(i)
If InStr(skippedMsg.SentOnBehalfOfName, "name") <> 0 Then
'Do Something
' Move SkippedMsg to a "Done" folder
' or mark it read or some way
' you can use to not reprocess an item
set skippedMsg = nothing
End If
End If
Next
End If
ProgramExitSkippedItems:
set skippedMsg = nothing
set inboxItems = nothing
Exit Sub
ErrorHandlerSkippedItems:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExitSkippedItems
End Sub
got a little problem, I hope someone can help me.
(Outlook 2010 VBA)
this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place)
it has to check if the Sender of the mail is already in my contacts or in the
Addressbook 'All Users',
and if it's not a one of those yet, open the AddContact window and fill in his/her information
what doesn't work yet is:
most important of all, it doesn't run the script when i click on a mail
the current check if the contact already exsist doesn't work
and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need
if the contact already exsist then nothing has to happen.
I hope i gave enough information and someone can help me out here :)
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
hey, i still have a last question,
'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
this checks if the name is already in contacts,
i need it that it checks if the E-mailaddress is in contacts or not,
can you help me with that?
i had someting like this in mind
set oSendermail = ?the e-mailaddress?
If Not oSendermail Is Nothing Then
Exit For
End If
End If
A solution (including test routine) could look as follows:
(assuming that we only consider external SMTP mails. Adjust the path to your contact folder and add some more error checking!)
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
Responding to an email with the subject line "test", with this code...
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) = "MailItem" Then
Debug.Print Item.Subject
Debug.Print Item.Parent
End If
End Sub
...returns this.
Inbox
RE: test
I'm looking to get to "test", which is the email being responded to so it can be automatically .Move(d) to an archive folder.
This would be better in Outlook 2010, I think. For earlier versions, I believe you want this code which is quoted directly from http://www.outlookcode.com/codedetail.aspx?id=1714
Function FindParentMessage(msg As Outlook.MailItem) _
As Outlook.MailItem
Dim strFind As String
Dim strIndex As String
Dim fld As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim itm As Outlook.MailItem
On Error Resume Next
strIndex = Left(msg.ConversationIndex, _
Len(msg.ConversationIndex) - 10)
Set fld = Application.Session.GetDefaultFolder(olFolderInbox)
strFind = "[ConversationTopic] = " & _
Chr(34) & msg.ConversationTopic & Chr(34)
Set itms = fld.Items.Restrict(strFind)
Debug.Print itms.Count
For Each itm In itms
If itm.ConversationIndex = strIndex Then
Debug.Print itm.To
Set FindParentMessage = itm
Exit For
End If
Next
Set fld = Nothing
Set itms = Nothing
Set itm = Nothing
End Function
Item.ConversationTopic
is the property you're looking for.