I have programmed a macro that should extract the content of received mails into an Excel sheet if the mail subject contains a specific word.
All in all its working, but the macro executes as soon as I receive a mail. That leads to a pop-up window in Outlook every time I receive a mail, but I only want it to pop up if I receive a mail with the specific subject.
I have to find another solution for the line:
If TypeName(item) = "MailItem" Then Set olMail = item
The entire code:
Private Sub olItems_ItemAdd(ByVal item As Object)
'Variablen dimensionieren
Dim olMail As Outlook.MailItem
Dim oxLApp As Object, oxLwb As Object, oxLws As Object
Set oxLApp = GetObject(, "Excel.Application")
Set oxLwb = oxLApp.Workbooks.Open _
("C:\Users\A2000\Desktop\Makros_NewScoping")
Set oxLws = oxLwb.Sheets("Slide 3")
'Prüfen ob Item eine Mail ist
If TypeName(item) = "MailItem" Then
Set olMail = item
If InStr(olMail.Subject, "APPROVAL REQUIRED") And _
olMail.SenderName = "Test, Name" Then
With oxLws
.Range("Q24") = olMail.VotingResponse
.Range("E41") = olMail.Body
End With
End If
There is no need to run any extra code if the mail arrived doesn't correspond to your conditions:
Private Sub olItems_ItemAdd(ByVal item As Object)
'Variablen dimensionieren
Dim olMail As Outlook.MailItem
Dim oxLApp As Object, oxLwb As Object, oxLws As Object
'Prüfen ob Item eine Mail ist
If TypeName(item) = "MailItem" Then
Set olMail = item
If InStr(olMail.Subject, "APPROVAL REQUIRED") And _
olMail.SenderName = "Test, Name" Then
Set oxLApp = GetObject(, "Excel.Application")
Set oxLwb = oxLApp.Workbooks.Open _
("C:\Users\A2000\Desktop\Makros_NewScoping")
Set oxLws = oxLwb.Sheets("Slide 3")
With oxLws
.Range("Q24") = olMail.VotingResponse
.Range("E41") = olMail.Body
End With
End If
Note, creating a new Excel instance each time a new item is added to the folder is not really a good idea. Moreover, the ItemAdd event is fired not only for incoming emails, but also for every email moved to the folder. So, when an item is moved to the folder you will get the code triggered.
That is why I'd suggest handling the NewMailEx event of the Application class. This event fires once for every received item that is processed by Microsoft Outlook. The item can be one of several different item types, for example, MailItem, MeetingItem, or SharingItem. The EntryIDsCollection string contains the Entry ID that corresponds to that item. Use the Entry ID represented by the EntryIDCollection string to call the NameSpace.GetItemFromID method and process the item.
You need to move the code that opens Excel to below the If statement where you check the server and the subject.
Related
I want to send the body of a Word document as an email from MS Word 2016.
I want the user to select recipients from the address book. I want them to only be put in the BCC field.
How do I monitor the to/from/CC/BCC fields for changes, and then move those changes to BCC?
The documentation indicates the use of Inspectors, but nothing specific about accessing the contents of these fields.
I have two approaches:
open a new Outlook mail item, load the contents of the Word file to it, and then try to monitor the fields that way.
send directly from Word using the Quick Access Toolbar option "Send to Mail Recipient".
I don't know if that is an option based on what I was reading and if those fields are accessible via VBA.
Code example of what I have so far:
Sub SendDocumentInMail()
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'Outlook wasn't running, start it from code
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Create a new mailitem
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
'Set the recipient for the new email
.To = "recipient#mail.com"
'Set the recipient for a copy
.CC = "recipient2#mail.com"
'Set the subject
.Subject = "New subject"
'The content of the document is used as the body for the email
.Body = ActiveDocument.Content
.Send
End With
If bStarted Then
'If we started Outlook from code, then close it
oOutlookApp.Quit
End If
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub
It seems you are interested in the SelectNamesDialog object which displays the Select Names dialog box for the user to select entries from one or more address lists, and returns the selected entries in the collection object specified by the property SelectNamesDialog.Recipients.
The dialog box displayed by SelectNamesDialog.Display is similar to the Select Names dialog box in the Outlook user interface. It observes the size and position settings of the built-in Select Names dialog box. However, its default state does not show Message Recipients above the To, Cc, and Bcc edit boxes.
The following code sample shows how to create a mail item, allow the user to select recipients from the Exchange Global Address List in the Select Names dialog box, and if the user has selected recipients that can be completely resolved, then send the mail item.
Sub SelectRecipients()
Dim oMsg As MailItem
Set oMsg = Application.CreateItem(olMailItem)
Dim oDialog As SelectNamesDialog
Set oDialog = Application.Session.GetSelectNamesDialog
With oDialog
.InitialAddressList = _
Application.Session.GetGlobalAddressList
.Recipients = oMsg.Recipients
If .Display Then
'Recipients Resolved
oMsg.Subject = "Hello"
oMsg.Send
End If
End With
End Sub
My task is to send an email containing a report and send another email containing another report to the same email thread by way of replying/forwarding to the sent email (excluding some recipients).
Option Explicit
Sub TestReply()
Dim objApp As Application
Dim objNewMail As Outlook.MailItem
Dim objReply As Outlook.MailItem
Set objApp = Outlook.Application
Set objNewMail = objApp.CreateItem(0)
' Outgoing email
With objNewMail
.Subject = "Test sending email"
.To = "abc#abc.com"
.HTMLBody = "This is the outgoing email."
.Send
End With
' Reply email
Set objReply = objNewMail.ReplyAll
With objReply
.HTMLBody = "This is the reply emal."
.Display
End With
Set objApp = Nothing
Set objNewMail = Nothing
Set objReply = Nothing
End Sub
I can't find a way to send the follow up email (either by reply or forward).
When I try the above code, it says error the item is moved/deleted. I guess it is becaused when the email is sent, the objNewMail odject is also terminated.
I tried adding RE: or FW: to the subject of the original email but then the two emails will not be in the same thread but independent emails.
An additional problem is that I have two email accounts in Outlook: my own email and team email and the reports are to be sent from the team email.
You can determine if an item added to the sent folder matches objNewMail.
In ThisOutlookSession
Option Explicit
Private WithEvents sentFolderItems As Items
Private Sub Application_Startup()
'Set sentFolderItems = Session.GetDefaultFolder(olFolderSentMail).Items
' Reference any folder by walking the folder tree
' assuming the team folder is in the navigation pane
Set sentFolderItems = Session.folders("team mailbox name").folders("Sent").Items
End Sub
Private Sub sentFolderItems_ItemAdd(ByVal Item As Object)
Dim myReplyAll As MailItem
If Item.Class = olMail Then
'do not use InStr unless you change some part of words in original subject
' or another reply will be generated
If Item.Subject = "Test sending email" Then
Set myReplyAll = Item.ReplyAll
With myReplyAll
.HTMLBody = "This is the reply email."
.Display
End With
End If
End If
End Sub
Sub TestReply()
Dim objNewMail As MailItem
'Set objNewMail = CreateItem(olMailItem)
' Add, not create, in non-default folder
Set objNewMail = Session.folders("team mailbox name").folders("Inbox").Items.Add
' Outgoing email
With objNewMail
.Subject = "Test sending email"
.To = "abc#abc.com"
.HTMLBody = "This is the outgoing email."
.Send
End With
End Sub
Note: Application. and Outlook. are not needed when code is in Outlook.
Call Send on the original email (objNewMail) only after you construct the reply.
Right so currently your code is doing this:
Creating a mail, sending it.
Trying to reply to the mailitem object which is already sent.
What you need is an event Hook to catch the mail when it's received by yourself. (assuming this is how you're reply all and removing some recipients for report 2)
Here is how you accomplish this:
First Create a WithEvents as Items call AllMyItems, then a hook in the AllMyItems_ItemAdd, then initialize the event when Outlook Starts using Application_Startup (a built in event)
Be very careful to identify criteria for forwarding / actioning the incoming mail item, since this event code will scan every mail sent to your main inbox and evaluate it. IF you want to further reduce the risk of forwarding a mail item to the wrong person, consider using an outlook rule to sort it into a custom folder, and then setting that folder's location as the Set AllMyItems = line instead of default folder
Option Explicit
'for the Default DL inbox
Private WithEvents AllMyItems As Items
Private Sub Application_Startup()
Dim olapp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olapp = Outlook.Application
Set objNS = olapp.GetNamespace("MAPI")
'Set myolitems = objNS.GetDefaultFolder(olFolderInbox).Items
'all my items in the main box
Set AllMyItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set olapp = Nothing
Set objNS = Nothing
End Sub
Private Sub AllMyItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
If TypeName(Item) <> "Mailitem" Then
If TypeName(Item) = "ReportItem" Then GoTo 0 'undeliverables shows as a report item
If TypeName(Item) = "MeetingItem" Then GoTo 0
Dim oItem As MailItem
Dim myForward As MailItem
Set oItem = Item
'use the next line to check for a property of the incoming mail, that distinguishes it from other mail, since this event will run on every mail item
If InStr(1, oItem.Subject, "Your public folder is almost full", vbTextCompare) > 0 Then
Set myForward = oItem.Forward
myForward.Recipients.Add "derp#derpinacorp.com"
myForward.Importance = olImportanceHigh
'MsgBox "uno momento"
myForward.Send
Else
End If
Else
End If
0:
End Sub
At work we send emails from Shared Inboxes. The emails would go into the user's own Sent Items instead of that of the Shared Inbox.
I wrote some VBA code which sorted this issue. We are moving to Outlook 365 & the code is not working there.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeName(Item) = "MailItem" Then 'If Item is a MailItem
If Item.SentOnBehalfOfName <> "" Then 'And if Item is Sent on Behalf of an inbox
'Save the sent email in the Sent Items folder for the inbox in question
Item.SaveSentMessageFolder GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items")
End If
End If
End Sub
I tried
msgbox GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items").Name
It gives the name of the folder but the Sent Item does not go there.
I created a "Test" folder & saved to the folder ignoring Item.SentOnBehalfOfName & this works if the "Test" folder is in my own inbox but not if it is in a Shared Inbox.
I tried changing the code to use Set & to include Application as per below.
Set Item.SaveSentMessageFolder = Application.GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items")
You can set a folder from a single store, there is no way to set a folder from another store/account. If you want to get items saved to another store, you must save them first and then move them programmatically to another folder/store.
Also, I'd suggest setting the MailItem.SaveSentMessageFolder property before an item is submitted:
Sub SetSentFolder()
Dim myItem As Outlook.MailITem
Dim myResponse As Outlook.MailITem
Dim mpfInbox As Outlook.Folder
Dim mpf As Outlook.Folder
Set mpfInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set mpf = mpfInbox.Folders.Add("SaveMyPersonalItems")
Set myItem = Application.ActiveInspector.CurrentItem
Set myResponse = myItem.Reply
myResponse.Display
myResponse.To = "Eugene Astafiev"
Set myResponse.SaveSentMessageFolder = mpf
myResponse.Send
End Sub
In the ThisOutlookSession module add the following variable declaration:
Private WithEvents Items As Outlook.Items
If you don't already have an Application_Startup event procedure create it by selecting Application in the left dropdown over the code area & Startup in the right dropdown over the code area.
The code to add to this procedure:
Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
Then in the left dropdown over the code area you need to select Items & in the right dropdown over the code area select ItemSend.
Below is what this procedure should look like:
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeName(Item) = "MailItem" Then 'If Item is a MailItem
If Item.SentOnBehalfOfName <> Session.Accounts.Item(1).CurrentUser Then 'And if Item is Sent on Behalf of the users own inbox
'Move the email into the Sent Items folder for the inbox in question
Item.Move GetNamespace("MAPI").Folders(Item.SentOnBehalfOfName).Folders("Sent Items")
End If
End If
End Sub
I want to set an auto-category for the incoming email in Outlook 2010 but my code does not work.
I restarted Outlook many times.
Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Set objItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim strSenderEmailAddress As String
Dim objContacts As Outlook.Items
Dim objContact As Object
Dim objFoundContact As Outlook.ContactItem
Dim strFilter As String
Dim strContactCategory As String
Dim i As Long
If TypeOf Item Is MailItem Then
Set objMail = Item
strSenderEmailAddress = objMail.SenderEmailAddress
Set objContacts =
Outlook.Application.Session.GetDefaultFolder(olFolderContacts).Items
For Each objContact In objContacts
If TypeOf objContact Is ContactItem Then
For i = 1 To 3
strFilter = "[Email" & i & "Address] = " &
strSenderEmailAddress
Set objFoundContact = objContacts.Find(strFilter)
'Check if the sender exists in your contacts folder
If Not (objFoundContact Is Nothing) Then
strContactCategory = objFoundContact.Categories
'If the corresponding contact has no category
'Assign the "Known" category to the email
If strContactCategory = "" Then
objMail.Categories = "Known"
'If the contact has, directly use its category
Else
objMail.Categories = strContactCategory
End If
Exit For
End If
Next i
'If the sender doesn't exist in the Contacts folder
'Assign the "Unknown" category to the email
If objFoundContact Is Nothing Then
objMail.Categories = "Unknown"
End If
End If
Next objContact
End If
End Sub
I am not good in VBA. When new email arrives my mailbox, it is not auto-categorized, no color filling in Category field in Outlook, nothing happens.
I want to set auto-category for the incoming email in outlook 2010 but my code does not work.
First of all, you need to handle the NewMailEx event of the Application class which is fired when a new item is received in the Inbox.
The NewMailEx event fires when a new message arrives in the Inbox and before client rule processing occurs. You can use the Entry ID returned in the EntryIDCollection array to call the NameSpace.GetItemFromID method and process the item. Use this method with caution to minimize the impact on Outlook performance. However, depending on the setup on the client computer, after a new message arrives in the Inbox, processes like spam filtering and client rules that move the new message from the Inbox to another folder can occur asynchronously.
After getting the item received you may set a category.
P.S. The ItemAdd event may not be fired at all if you receive more than sixteen items simultaneously. This is a known issue in the Outlook object model.
I'm trying to convert an incoming appointment message to email and send.
Public Sub ConvertMeetingToEmail(ActiveFolder, Inbox As String)
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim Subfolder As Outlook.Folder
Dim Item As Object
Dim myMtg As Outlook.MeetingItem
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders(ActiveFolder)
Set Folders = myFolder.Folders
Set Subfolder = Folders.Item(Inbox)
For Each Item In Subfolder.Items
If Item.MessageClass = "IPM.Schedule.Meeting.Request" Then
'Convert Appointment to Email and Forward message
'Its Sudo-code and not working
objMsg.To = "example#emp.com"
objMsg.Subject = Item.Subject
objMsg.Body = Item.Body
objMsg.Send
End If
Next
End Sub
It is important to copy body text from Appointment as well as Subject and send to another email address.
I cannot forward this appointment. I have to convert it to email.
UPDATE
I added one line of code and it works:
Set myMtg = Item
objMsg.To = "example#emp.com"
objMsg.Subject = myMtg.Subject
objMsg.Body = myMtg.Body
objMsg.Send
If you want to send an existing meeting item as a regular email you need to set the MessageClass property to IPM.Notefirst. The MessageClass property links the item to the form on which it is based. When an item is selected, Outlook uses the message class to locate the form and expose its properties, such as Reply commands. Then you can cast the object to the MailItem class and call the Send method (of course, after specifying recipients).
At the opposite side, the Forward method of the MeetingItem class executes the Forward action for an item and returns the resulting copy as a MeetingItem object. So, basically a new MeetingItem object that represents the new meeting item is returned which can be sent.