I am writing a macro that should remove attachments. From my debugging sessions, it appears as if it should work. The breakpoint is hit and it recognizes the message object:
I know this sounds a bit silly, but, oddly enough, it seems to work if I set a breakpoint, and open the expression/watch, but not otherwise.
I have been struggling with this for quite some time; I would appreciate any guidance.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim header As String
Dim objNewMail As Outlook.MailItem
Dim Item As Object
Dim count As Integer
Dim objInbox As Outlook.Folder
Set objInbox = Outlook.Session.GetDefaultFolder(olFolderInbox)
Dim entryIDs
entryIDs = Split(EntryIDCollection, ",")
Dim i As Integer
For i = 0 To UBound(entryIDs)
Set objNewMail = Application.Session.GetItemFromID(entryIDs(i))
If objNewMail.Attachments.count > 0 Then
header = GetHeader(objNewMail)
If DoesIPMatch(header) <> True Then
DeleteMessage (objNewMail)
ElseIf IsAttachmentPDF(objNewMail) <> True Then
For count = 1 To objNewMail.Attachments.count
objNewMail.Attachments.Remove (count)
Next
End If
End If
Next
End Sub
Try this, as a most likely culprit if you are removing items from a collection it should always be done in reverse order, otherwise you have to re-index your counter variable, and that makes for messy code:
It may also be necessary to Save the objNewMail item after you've modified it (e.g., by removing attachments)
For count = objNewMail.Attachments.count to 1 Step - 1
objNewMail.Attachments.Remove count
Next
objNewMail.Save '## Not sure if this is necessary
Alternatively:
With objNewMail.Attachments
While .Count > 0
.Remove 1
Wend
End With
objNewMail.Save
Related
I've read this: VBA Outlook 2010 received mail .Body is empty but it is old and the other question referenced in the answer(s) is not found when I click on it.
Here's my basic code.
Sub AutoReplyTrap(objInMail As MailItem)
Dim objOutMail As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim strID As String
Dim sSubject As String
Dim vItem As Variant
Dim vFirstName As Variant
Dim i As Long
Dim j As Integer
Dim strSignature As String
Dim strSigString As String
Dim strFirstName As String
Dim strFirstLetter As String
Dim strEMailAddress As String
Dim blnFirstName As Boolean
Dim blnEMail As Boolean
' change the bodyformat to plain text
objInMail.BodyFormat = Outlook.OlBodyFormat.olFormatPlain
objInMail.Display
blnFirstName = False
blnEMail = False
j = 0
' believe there is a timing issue that Body may not be fully loaded.
' so I'm going to pause and loop through 20 times to see if it gets loaded.
WaitForBody:
sText = objInMail.Body
If sText = "" Then
If j < 20 Then
j = j + 1
Sleep 1000
GoTo WaitForBody
End If
End If
If sText = "" Then
MsgBox ("No body in email!")
Exit Sub
End If
End Sub
I thought it was a timing issue, so I built the loop to test if I have the body, and if not, wait a second and try again up to 20 times.
I have objInMail.Display it works, but if I remove that line it will loop through the 20 attempts.
I could live with the display if I could then "un-display" it, but I wonder if the .close will close everything with the email and I'll lose the body again.
I'd prefer it to work without the objInMail.Display.
Ignoring the cause, this may provide a workaround without .Display.
Option Explicit
Private Sub test_GetInspector()
Dim currSel As Object
Set currSel = ActiveExplorer.Selection(1)
If currSel.Class = olMail Then
AutoReplyTrap_GetInspector currSel
End If
End Sub
Sub AutoReplyTrap_GetInspector(objInMail As mailItem)
' change the bodyformat to plain text
objInMail.BodyFormat = OlBodyFormat.olFormatPlain
' objInMail.GetInspector ' Previously "valid".
' My setup finally caught up and provided the clue.
' Directly replacing .Display with .GetInspector
' Compile error:
' Invalid use of property
' https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.getinspector
Dim objInspector As Inspector
Set objInspector = objInMail.GetInspector
' You should find this is necessary
'objInMail.Save
End Sub
Working with Outlook 2010 right now and have an update. The issue is caused by a bug in Outlook 2010/2013 that only gives a blank message body in VBA when:
(1) using IMAP protocol; and,
(2) automatically processing incoming emails.
This holds true even if you just set a Rule from the front end, such as automatically printing specific incoming emails (my task). This prints the email header, not the body.
A workaround that worked for me was to use POP3 protocol instead of IMAP with the same email server.
Can someone point out what I am missing here. Every time I run this it says that an object is required.
I apologize I feel like this is a very easy fix but I have been wrecking my brain for a while.
Basically what I am trying to accomplish is count how many emails are mark as high importance.
Again I feel like this is such a simple error but I am still learning this.
Sub CheckForImportance()
Dim myNs As Outlook.NameSpace
Dim infldr As Outlook.Folder
Dim impMail As Outlook.MailItem
Dim ttlcount As Integer
Set myNs = Application.GetNamespace("MAPI")
Set infldr = myNs.GetDefaultFolder(olFolderInbox)
Set impMail = infldr.Items
Set ttlcount = 0
If impMail.Importance = olImportanceHigh Then ttlImp = ttlImp + 1
MsgBox ("count:" & ttlImp)
End Sub
Outlook stores mail items, calendar items, tasks and so on in files it calls Stores. Sometimes people say mail items and so on are stored in PST files which is usually true. However, all PST files are stores but not all stores are PST files.
I remember when the default was for messages sent to any of your email addresses to be loaded to the same store. In that situation, Set infldr = myNs.GetDefaultFolder(olFolderInbox)was useful since the default Inbox was in that one store.
With Outlook 2016, and perhaps some other recent versions, the default is to have a separate store for each email address. Each of these stores is named for the email address, for example: “JohnDoe#hotmail.com” or “DoeJ#gmail.com”.
Copy this macro to an Outlook module and run it:
Sub DsplUsernameOfDefaultStore()
Dim NS As Outlook.NameSpace
Dim DefaultInboxFldr As MAPIFolder
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)
Debug.Print DefaultInboxFldr.Parent.Name
End Sub
On my system, this macro outputs “Outlook Data File”. This was the default store that came with Outlook but none of my emails are loaded to it.
You will need something like:
Set infldr = Session.Folders("Xxxx").Folders("Inbox")
where Xxxx is the name of the store containing the Inbox you wish to interrogate.
Below I have three alternative macros that count the number of high importance emails in an Inbox. Points of particular note:
Version 1 uses a For Each loop as I suggested in my comment. Version 2 uses a For IndexVariable loop. To my knowledge, neither type of For has an advantage over the other. I use whichever seems more convenient for the task at hand. Version 3 uses a filter. I have not found a use for the Outlook filter often enough to have become expert in its use so I normally use a For loop. olImportanceHigh is a constant with a value of 2. It appears you cannot use a constant within a Restrict string which is why it says [Importance] = 2.
I find Debug.Print much more convenient than MsgBox during development.
Come back with questions about my code as necessary.
Option Explicit
Sub CountHighImportanceEmails1()
Dim FldrInbox As Folder
Dim MailItemCrnt As MailItem
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
For Each MailItemCrnt In FldrInbox.Items
If MailItemCrnt.Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails2()
Dim FldrInbox As Folder
Dim InxMi As Long
Dim NumEmailsHighImport As Long
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
NumEmailsHighImport = 0
With FldrInbox
For InxMi = 1 To .Items.Count
If .Items(InxMi).Importance = olImportanceHigh Then
NumEmailsHighImport = NumEmailsHighImport + 1
End If
Next
End With
Debug.Print "Number of high importance emails=" & NumEmailsHighImport
End Sub
Sub CountHighImportanceEmails3()
Dim FldrInbox As Folder
Dim MailItemsHighImport As Items
Set FldrInbox = Session.Folders("Xxxx").Folders("Inbox")
Set MailItemsHighImport = FldrInbox.Items.Restrict("[Importance] = 2")
Debug.Print "Number of high importance emails=" & MailItemsHighImport.Count
End Sub
Example would be
Option Explicit
Public Sub Example()
Dim Inbox As Outlook.folder
Set Inbox = Application.Session.GetDefaultFolder( _
olFolderInbox)
Dim Filter As String
Filter = "[Importance] = 2"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Debug.Print Items.Count
MsgBox Items.Count & " High importance Items are in " & Inbox.Name
End Sub
I am trying to get details for users in a distribution list (containing ~200 people).
When I create a new email, add this DL as the only recipient and run the macro below, it returns ~15 first results, then "Outlook is trying to retrieve data from the Microsoft Exchange server" tray message appears and after some time I get "The operation failed" error.
If I continue the code execution the next ~15 values are returned and this issue reappears. Seams like there is some Exchange anti-spam limit.
Sub GetDetails(olMail As MailItem)
Dim i As Integer, j As Integer
For i = 1 To olMail.Recipients.Count ' count = 1
If olMail.Recipients.Item(i).AddressEntry.GetExchangeUser Is Nothing Then
For j = 1 To olMail.Recipients.Item(i).AddressEntry.Members.Count ' count ~= 200
Debug.Print olMail.Recipients.Item(i).AddressEntry.Members.Item(j).GetExchangeUser.FirstName
Next j
End If
Next i
End Sub
But if I expand the distribution list (using the '+' icon) and run slightly modified code, results for all users are returned with no issues (taking a few seconds only).
Sub GetDetails(olMail As MailItem)
Dim i As Integer
For i = 1 To olMail.Recipients.Count ' count ~= 200
If Not olMail.Recipients.Item(i).AddressEntry.GetExchangeUser Is Nothing Then
Debug.Print olMail.Recipients.Item(i).AddressEntry.GetExchangeUser.FirstName
End If
Next i
End Sub
Any ideas?
You need to release Outlook COM objects instantly in the code. This is particularly important if your add-in attempts to enumerate more than 256 Outlook items in a collection that is stored on a Microsoft Exchange Server. If you do not release these objects in a timely manner, you can reach the limit imposed by Exchange on the maximum number of items opened at any one time. When you are done, just set a variable to Nothing to release the reference to the object.
Updated (working) code based on Eugene's feedback:
Sub GetDetails(olMail As MailItem)
Dim oRecipients As Recipients
Dim oRecipient As Recipient
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim i As Integer, j As Integer, dRecCnt As Integer, dMemCnt As Integer
Set oRecipients = olMail.Recipients
dRecCnt = oRecipients.Count
For i = 1 To dRecCnt
Set oRecipient = oRecipients.Item(i)
If oRecipient.AddressEntry.GetExchangeUser Is Nothing Then
Set oMembers = oRecipient.AddressEntry.Members
dMemCnt = oMembers.Count
For j = 1 To dMemCnt
Set oMember = oMembers.Item(j)
Debug.Print c & ": " & oMember.GetExchangeUser.FirstName
Set oMember = Nothing
Next j
Set oMembers = Nothing
End If
Set oRecipient = Nothing
Next i
Set oRecipients = Nothing
End Sub
I have a listener in VBA on my outlook box to perform an action if a receive a mail from a specific email.
The problem is that if I get a error mail (non-delivery email) then my condition is run on a mail which doesn't have that property so my method crashes.
I don't know what the subject may be either.
Does anyone have an idea if I can test if the property exists or if there is another property I can check for to identify if my sender matches?
Many thanks in advance
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Outlook.MailItem
Dim i As Integer
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test")
' Loop all items in the Inbox\Test Folder
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set obj = mpfInbox.Items.Item(i)
If obj.SenderEmailAddress = "someone#example.com" Then
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
End If
Next
End Sub
Dim obj as a generic Object - there are objects other than MailItem in your Inbox, also to improve your loop try using Items.Restrict Method (Outlook)
Option Explicit
Sub SetFlagIcon()
Dim mpfInbox As Outlook.Folder
Dim obj As Object
Dim Items As Outlook.Items
Dim i As Long
Dim Filter As String
Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder _
(olFolderInbox).Folders("Temp")
Filter = "[SenderEmailAddress] = 'someone#example.com'"
Set Items = mpfInbox.Items.Restrict(Filter)
' Loop all items in the Inbox\Test Folder
For i = 1 To Items.Count
If Items(i).Class = olMail Then
Set obj = Items(i)
'Set the yellow flag icon
obj.FlagIcon = olYellowFlagIcon
obj.Save
End If
Next
End Sub
Items.Restrict Method Applies a filter to the Items collection, returning a new collection containing all of the items from the original that match the filter.
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