I get emails from my old team/role about tech bridges during outages that I no longer attend. I would like to auto-decline them IF they are sent to a specific distribution list (that I'm still part of).
I don't know VBA at all but would this work (I modified another script I found and replaced SenderEmailAddress with Recipients). Don't want to run this until someone who actually knows that they are looking at confirms or denies that this will work (on the off chance it does something wild with me emails).
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim xEntryIDs
Dim xItem
Dim i As Integer
Dim xMeeting As MeetingItem, xMeetingDeclined As MeetingItem
Dim xAppointmentItem As AppointmentItem
On Error Resume Next
xEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(xEntryIDs)
Set xItem = Application.Session.GetItemFromID(xEntryIDs(i))
If xItem.Class = olMeetingRequest Then
Set xMeeting = xItem
xMeeting.ReminderSet = False
If VBA.LCase(xMeeting.Recipients) = VBA.LCase("support.bridge#company.com") Then
Set xAppointmentItem = xMeeting.GetAssociatedAppointment(True)
xAppointmentItem.ReminderSet = False
Set xMeetingDeclined = xAppointmentItem.Respond(olMeetingDeclined)
xMeetingDeclined.Body = "Declined"
xMeetingDeclined.Send
xMeeting.Delete
End If
End If
Next
End Sub
You can't compare the Recipients collection with a string in the following way:
If VBA.LCase(xMeeting.Recipients) = VBA.LCase("support.bridge#company.com") Then
The MeetingItem.Recipients property returns a Recipients collection that represents all the recipients for the Outlook item. Use Recipients(index), where index is the name or index number, to return a single Recipient object. The name can be a string representing the display name, the alias, or the full SMTP email address of the recipient.
The Recipient.DisplayType property returns a constant belonging to the OlDisplayType enumeration that describes the nature of the Recipient. It seems you are interested in the olDistList or olPrivateDistList values.
Also I've noticed the following line of code:
xEntryIDs = Split(EntryIDCollection, ",")
The NewMailEx behavior has been changed more than 10 years ago and now it is fired for each Outlook item separately. So, there is no need to split the string in the event handler, the parameter contains only a single entry ID value.
Related
Every day I get one or more spam emails of a very specific type to my xxxxx#gmail account.
They all have a garbled and unique FROM: email address.
The TO: and CC: fields are always of the form xxxxx[random chars]#aol.com. For example I got one today with
TO: xxxxx#aol.com
CC: xxxxxY7#aol.com
I would like to create a rule to automatically send these to spam and block. Two possible conditionals would be:
"with xxxxx AND #aol.com in recipient's address"
"with xxxxx*#aol.com in recipient's address" (with * as a wildcard).
#1 doesnt work because the "specific words" it requests are concatenated with OR, no option to use AND.
#2 doesn't work because as far as I can tell there is no way to use wildcards.
Any suggestions? I realize there probably is a straightforward VBA script solution but I haven't played with VBA in over a decade. Was hoping there might be another clever non-VBA work around. Thanks.
There is no workaround. You can handle incoming emails in Outlook VBA by 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. You can use the Entry ID from the EntryIDCollection parameter to call the NameSpace.GetItemFromID method and process the item.
In the NewMailEx event handler you can check the required properties such as Recipients and etc. and move the item wherever you need.
As stated, NewMailEx can be used to handle some filtering like this and I have a regex filter that I use as standard automatic rules don't allow that (or at least not currently - maybe a future upgrade). If you can use a regex to identify the e-mails you want to process then you could use this code:
In ThisOutlookSession
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Call RegExFilterRules(EntryIDCollection)
End Sub
In a module
Sub RegExFilterRules(ItemID As String)
With Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = .GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = .GetDefaultFolder(olFolderJunk)
Dim olItem As Outlook.MailItem: Set olItem = .GetItemFromID(ItemID, Inbox.StoreID)
End With
'On Error Resume Next
If Not olItem Is Nothing And olItem.Class = olMail Then
If IsPatternFound(olItem.subject, "^M\d+$") Then olItem.Move Junk 'olItem.Delete 'olItem.UnRead = False
If olItem.Sender = "cortana#microsoft.com" Then olItem.Delete
End If
Set olItem = Nothing
End Sub
Private Function IsPatternFound(Content As String, Pattern As String) As Boolean
' Requires Reference: Microsoft Scripting Runtime
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.RegExp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = Pattern
IsPatternFound = .Test(Content)
End With
End Function
I want to loop through a list of email addresses and check if they have OOF's turned on (these will be other people's email addresses). Then if possible retrieve the OOF text.
I tried the options of getting the OOF through VBA but with my own trial and error and googling I can see that most people (and myself) realize it's only possible to get your own OOF information.
Sub Check_OOF()
Dim oNS As Outlook.NameSpace
Dim oStores As Outlook.Stores
Dim oStr As Outlook.Store
Dim oPrp As Outlook.PropertyAccessor
Set oNS = Outlook.GetNamespace("MAPI")
Set oStores = oNS.Stores
For Each oStr In oStores
If oStr.ExchangeStoreType = olPrimaryExchangeMailbox Then
Set oPrp = oStr.PropertyAccessor
MsgBox oPrp.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x661D000B")
End If
Next
End Sub
Is this possible with Outlook-Redemption? I can only see the syntax to interact with your own automatic reply.
You will need to use EWS - GetMailTips operation.
Also you can use Redemption, see RDOMailTips object for more information.
Thanks for pointing me in the right direction Eugene, also Dmitry thanks again for redemption.
I installed redemption by downloading here and installing it via the command line (thanks for the clear instructions). I'm using the RDOMailTips object which allowed me to loop through mailbox's and retrieve OOF messages and other helpful information.
Below is an example I quickly wrote to show the basic premise of looping through emails and getting OOF's text and start/end date.
Sub Get_OOF()
Dim session As Redemption.RDOSession
Dim arr As Variant
Set session = CreateObject("Redemption.RDOSession")
session.Logon
session.SkipAutodiscoverLookupInAD = True
arr = Array("user1#email.com", "user2#email.com", "user3#email.com")
For i = LBound(arr) To UBound(arr)
Set AdrEntry = session.AddressBook.ResolveName(arr(i))
Set mailtips = AdrEntry.GetMailTips
Debug.Print mailtips.OutOfOfficeMessage
Debug.Print mailtips.OutOfOfficeEndTime
Debug.Print mailtips.OutOfOfficeStartTime
Next i
Set session = Nothing
Set AdrEntry = Nothing
Set mailtips = Nothing
End Sub
Four things to note
If the person doesn't have an out of office it will return an empty string
If the person hasn't set out of office dates it will return 01/01/4501 which I assume is an error code formatted as a date
You will need to split the string from mailtips.OutOfOfficeMessage as it has a lot of formatting fluff around the out of office text
I didn't need to put my credentials in the parameters of AdrEntry.GetMailTips for this to work. But as the documentation says this is optional for EWS.
I'd like to follow the status of an email as it passes through the phases and folders of its life cycle, through "Drafts", "Outbox", and "Sent".
Of related interest is the ability to access existing emails to gather property info, such as sent time.
I've started with the included block of code. The Do Loop fails the moment the email is sent, because the variable disconnects from the email.
This causes the runtime error
The item has been moved or deleted.
The error number (Err.Number) is different every time, and I wonder what the design purpose is.
How can I stay connected to sending emails as they move through Drafts, Outbox, and Sent?
I see many mentions of the variable disconnecting from the mailitem, but no solutions that rely on the object hierarchy and avoid late-binding to address the issue. I thought perhaps there would be a GUID or UUID that identifies the message, but as indicated in the documentation, all properties such as EntryID can change if the item is moved, and such properties should not be relied on.
With deeper examination, this makes sense because an email is just a record in a database table. And if you duplicate/delete records between tables, the info might be the same or similar, but the record number probably won't be.
Also, that hits other nails: the same email can be sent multiple times, and also can be copied/pasted into different folders, and even different accounts. Now what's unique or not?
Aside from staying "connected" to a email, what properties or techniques can be used to ID one?
If there's no "proper" way to identify a mailitem as described, about the only thing I can think of is to use an existing or custom field, like the "Tag" property of OCX controls, to insert a UUID. Some companies use this sort of technique by putting a call/order/support number in the subject line to make then easier to track.
Dim outlobj As Outlook.Application
Dim mailobj As Outlook.MailItem
Set outlobj = Outlook.Application
Set mailobj = outlobj.CreateItem(olMailItem)
With mailobj
.Recipients.Add "wonderwoman#hallofjustice.com"
.Subject = "Invisible Jet Scheduled Maintenance Reminder"
.Body = "Your invisible jet need to be polished."
.Attachments.Add zipFilename
.Display
.Send
End With
Do
'next line fails due to email moving through Drafts, Outbox, & Sent
'notably, the VBA runtime Err.Num is different each time
'how do i keep the variable connected to a moving target?
If mailobj.Sent = False Then
Sleep 100
Else
MsgBox "The email has been sent."
'other code
Exit Do
End If
Loop
Create a class and add MailItem as the event enabled property of that class. Handle the events such as Open/Write/Send/Save etc. to have custom control on the e-mail life-cycle. EntryID is the unique property for each mail item.
Be cautious of the fact that Entry Id is only generated after the first save of the item and changes implicitly when user manually moves the item between folders.
Following a is an example to get you started:
Add a class Class1 like this
Option Explicit
Public WithEvents mItem As MailItem
Public id As String
Private Sub mItem_Open(Cancel As Boolean)
MsgBox "Mail item will be displayed."
id = mItem.EntryID
End Sub
Add a module with following code:
Option Explicit
Sub test()
Dim cls As New Class1
Dim id As String
Dim outlobj As Outlook.Application
Dim mailobj As Outlook.MailItem
Set outlobj = Outlook.Application
Set mailobj = outlobj.CreateItem(olMailItem)
Set cls.mItem = mailobj
With mailobj
.Recipients.Add "xx#yy.zz"
.Subject = "Test"
.Body = "Test Content of the e-mail."
.Save
.Display
id = cls.id '/ Store ID for later use.
Debug.Print id
End With
'/ Search that e-mail and display its body contents
Call Retrieve(id)
End Sub
Sub Retrieve(sEntryId As String)
Dim mailobj As Outlook.MailItem
Dim ns As NameSpace
Set ns = GetNamespace("MAPI")
Set mailobj = ns.GetItemFromID(sEntryId)
MsgBox mailobj.Body
End Sub
Run the sub test
EDIT: New info: I just now realised that, while the return of Mailitem.Body is "", the actual value is "Application-defined or object-defined error" . I'm not entirely sure what that means, but I do know it shows up in multiple fields-- I included a screen shot below.
I am having an issue where certain properties will return the correct value, and others will not. I have an example email, where I have an email with subject "Subject", the message is "Body", the sender email address is "email#address.com", and the date sent is 12 June 2013.
When I run the following code:
Dim ComputerName As String
Dim ErrorState As String
For Each MailItem In InboxItems
ComputerName = MailItem.Subject
'ErrorState = MailItem.Body
ErrorState = MailBody(MailItem)
strDate = GetDate(MailItem.SentOn)
SenderEmail = MailItem.SenderEmailAddress
If strDate = DateToday And SenderEmail = "email#address.com" Then
Computers(a, 0) = ComputerName
Computers(a, 1) = ErrorState
a = a + 1
End If
Debug.Print MailItem.Subject
Debug.Print MailItem.Body
Next MailItem
What I get is ComputerName = "Subject", ErrorState = "", SenderEmail = "", and strDate = "2013/6/12" (which is the proper format in this case). Why would this return proper values for two of the Mailitem properties, but not for two of the others? This is a very strange problem, and I would appreciate any help you all might be able to give!
I will add more of the context for the code here:
Set objOutlook = CreateObject("Outlook.Application", "localhost")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set Inbox = GetFolder("email#address.org/inbox")
Set InboxItems = Inbox.Items
InboxItems.SetColumns ("SentOn")
GetFolder is a function to get the mailbox by folder path. I have to do this because I am not using the default inbox in outlook.
I also tried using the MailBody Function proposed below, in case the body were in an HTML or RTF format. Unfortunately, it proved that the body was normal, and MailItem.Body should have retrieved it, and it still is not working. MailItem.Body returns "", even though I know that the email has a body. The body is just the number 1, and that is what I should be getting.
Also, I should note that the sender of the email is the same as the recipient; in other words, the email was sent from one email address to itself. I don't know if this could make a difference, but I figured that I would put it out there just in case.
Multiple Item Types
First, there is no guarantee that all items in the Inbox.Items collection are of type MailItem. Inboxes also contain AppointmentItem, MeetingItem, and other *Item type objects. Not all of these item types have the same properties populated. To ensure you do not get a type mismatch error, declare your iterator variable as a generic Object and only assign it to a strongly-typed MailItem variable if it is of the correct type:
Dim oInbox As Outlook.Folder
Dim oItem As Object
Dim oMailItem As MailItem
Set oInbox = ActiveExplorer.Session.DefaultStore.GetRootFolder().Folders("Inbox")
For Each oItem In oInbox.Items
If TypeOf oItem Is MailItem Then
Set oMailItem = oItem
' Do stuff
Else
Debug.Print "Skipping " & TypeName(oItem)
End If
Next
Optional properties
Second, there is no gaurantee that all properties of an object will be populated. If a mail item was never sent, it will have no sender address, and certainly it is possible to have an email with no body. A good way to get familiar with which properties are available and what they contain is to use the Locals window (View > Locals Window in the VBA IDE). Here's a screen shot of the above code paused in the loop, with some of the properties of the oMailItem object expanded:
Body vs. HTMLBody
MailItem objects have three body properties: Body, HTMLBody, and RTFBody. Usually only one of them is populated. Which one depends on the format of the email. You can check the BodyFormat property to find which one is applicable to the current item. Using that, here's a generalized way to get the raw body of a MailItem, no matter what the format:
Public Function MailBody(ByVal MailItem As MailItem) As String
Select Case MailItem.BodyFormat
Case OlBodyFormat.olFormatPlain, OlBodyFormat.olFormatUnspecified
MailBody = MailItem.Body
Case OlBodyFormat.olFormatHTML
MailBody = MailItem.HTMLBody
Case OlBodyFormat.olFormatRichText
MailBody = MailItem.RTFBody
End Select
End Function
I need to build a tool that will allow the user to select an email from his Outlook so I can then save that email as a .msg file or alternately save just the attachment as a file.
I'm stumbling a little bit over what might be the easiest and the best way to allow searching/filtering of emails. I need to give the user a view that is at least slightly similar to Outlook (for example, folders should be the same order/hierarchy.
Does the Outlook Object Model have some kind of Explorer/Picker/Selection dialog I can call that will return a storeid and an entryid after the user selects an email? Or do I need to roll my own?
I should mention that I already know how to save the email or attachment so my question is only about handling selection and filtering of emails.
FYI, I'm programming this in MS Access 2007 with Outlook 2007. The target machines have either 2007 or 2010 versions of Access and Outlook.
Linking to the Outlook table is fine. The problem is that Outlook doesn't provide a unique ID to each message and if the message is moved from one folder to another, its ID changes. Clearly not designed by someone who understands databases.
A better approach may be to create an Outlook add-in that runs within Outlook, then performs the tasks you need to send the info to Access.
I rarely program with Access but I moved some code across from Outlook, hacked it around a bit and it seems to work. This is not a solution but it should show you how to access all the information you need.
I had one problem. Neither Set OutApp = CreateObject("Outlook.Application") nor Set OutApp = New Outlook.Application create a new instance of Outlook if one is already open. So Quit closes Outlook whether or not it was open before the macro started. I suggest you post a new question on this issue; I am sure someone knows how to tell if Outlook is already open and therefore not to quit it.
The folder structure in Outlook is slightly awkward because the top level folders are of type Folders while all sub-folders are of type MAPIFolder. Once you have got past that it is fairly straightforward.
The code below includes function GetListSortedChildren(ByRef Parent As MAPIFolder) As String. This function finds all the children of Parent and returns a string such as "5,2,7,1,3,6,4" which lists the indices for the children in ascending sequence by name. I would use something like this to populates a ListView by expanding nodes as the user required.
I have provided a subroutine CtrlDsplChld() which controls the output to the immediate windows of all the folders in sequence. I believe that should give you enough guidance to get started on accessing the folder hierarchy.
Subroutine DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long) includes code to find the first message with attachments. This will you tell you how to look through a folder for a particular message.
Finally, CtrlDsplChld() displayes selected properties of the message: Subject, To, HTMLBody and the display names of the attachments.
Hope this helps.
Option Compare Database
Option Explicit
Dim ItemWithMultipleAttachments As Outlook.MailItem
Sub CtrlDsplChld()
Dim ArrChld() As String
Dim ListChld As String
Dim InxAttach As Long
Dim InxChld As Long
Dim InxTopLLCrnt As Long
Dim OutApp As Outlook.Application
Dim TopLvlList As Folders
Set ItemWithMultipleAttachments = Nothing
Set OutApp = CreateObject("Outlook.Application")
'Set OutApp = New Outlook.Application
With OutApp
Set TopLvlList = .GetNamespace("MAPI").Folders
For InxTopLLCrnt = 1 To TopLvlList.Count
' Display top level children and their children
Call DsplChld(TopLvlList.Item(InxTopLLCrnt), 0)
Next
If Not ItemWithMultipleAttachments Is Nothing Then
With ItemWithMultipleAttachments
Debug.Print .Subject
Debug.Print .HTMLBody
Debug.Print .To
For InxAttach = 1 To .Attachments.Count
Debug.Print .Attachments(InxAttach).DisplayName
Next
End With
End If
.Quit
End With
Set OutApp = Nothing
End Sub
Sub DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long)
Dim ArrChld() As String
Dim InxChld As Long
Dim InxItemCrnt As Long
Dim ListChld As String
Debug.Print Space(Level * 2) & Parent.Name
If ItemWithMultipleAttachments Is Nothing Then
' Look down this folder for a mail item with an attachment
For InxItemCrnt = 1 To Parent.Items.Count
With Parent.Items(InxItemCrnt)
If .Class = olMail Then
If .Attachments.Count > 1 Then
Set ItemWithMultipleAttachments = Parent.Items(InxItemCrnt)
Exit For
End If
End If
End With
Next
End If
ListChld = GetListSortedChildren(Parent)
If ListChld <> "" Then
' Parent has children
ArrChld = Split(ListChld, ",")
For InxChld = LBound(ArrChld) To UBound(ArrChld)
Call DsplChld(Parent.Folders(ArrChld(InxChld)), Level + 1)
Next
End If
End Sub
Function GetListSortedChildren(ByRef Parent As MAPIFolder) As String
' The function returns "" if Parent has no children.
' If the folder has children, the functions returns "P,Q,R, ..." where
' P, Q, R and so on indices of the children of Parent in ascending
' order by name.
Dim ArrInxFolder() As Long
'Dim ArrFolder() As MAPIFolder
Dim InxChldCrnt As Long
Dim InxName As Long
Dim ListChld As String
If Parent.Folders.Count = 0 Then
' No children
GetListSortedChildren = ""
Else
'ReDim ArrName(1 To Parent.Folders.Count)
'For InxChldCrnt = 1 To Parent.Folders.Count
' ArrFolder(InxChldCrnt) = Parent.Folders(InxChldCrnt)
'Next
Call SimpleSortMAPIFolders(Parent, ArrInxFolder)
ListChld = CStr(ArrInxFolder(1))
For InxChldCrnt = 2 To Parent.Folders.Count
ListChld = ListChld & "," & CStr(ArrInxFolder(InxChldCrnt))
Next
GetListSortedChildren = ListChld
End If
End Function
Sub SimpleSortMAPIFolders(ArrFolder As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into ArrFolder sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
ReDim InxArray(1 To ArrFolder.Folders.Count) ' One entry per sub folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
If ArrFolder.Folders.Count = 1 Then
' One entry list already sorted
Exit Sub
End If
' Each repeat of the loop moves the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If ArrFolder.Folders(InxArray(InxIACrnt)).Name > _
ArrFolder.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub