My macro saves PDF attachment from one sender/subject. How get it to handle multiple sender/subjects? - vba

I have a code that can automaticaly move a PDF from a received message to a folder of my choice, but what I really need is in fact to be able to move a file to a specific folder depending of the sender.
The code below works for only one sender, How do I add more senders and more folder locations?
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")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Marc, Test") And _
(Msg.Subject = "Heures") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Users\NAEC02\Test\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Before answering your question, some comments on your existing code.
You are running this code within Outlook. You do not need olApp. You only need a reference to the Outlook application if you are trying to access your emails from Excel or some other Office product.
I am surprised how often I see On Error GoTo ErrorHandler because I have never found a use from this statement.
If I am coding for myself, I want execution to stop on the statement causing the problem so I can understand what is happening without guessing from the error message. If execution stops on the statement causing the error, I can restart the code if I can immediately fix the error.
If I am developing for a client, I want, at worst, a user-friendly message. Err.Number & " - " & Err.Description is not my idea of a user-friendly message. It does not even tell me which email caused the problem. For a client, I would have something like:
Dim ErrDesc as String
Dim ErrNum as Long
: : :
On Error Resume Next
Statement that might give an error
ErrNum = Err.Num
ErrDesc = Err.Description
On Error GoTo 0
If ErrNum <> 0 Then
Code to handle errors that can occur with
this statement in a user-friendly manner.
End If
Today Dim Att As String is fine because you remember what Att is. Will you remember when you update this macro in six or twelve months? Will a colleague updating this macro know what Att is? I would call it AttName or perhaps AttDsplName.
You say the code saves PDF attachments but you do not check for this. To a VBA macro, logos, images, signatures and other files are also attachments. Also you assume the attachment you wish to save is Attachments(1). If there are several attachments, the logos, images and signatures could come first.
You have:
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
You do not set olDestFldr and you do not move the email to a different folder. Do you want to do this?
Now to your question. I have included the code for two methods of achieving your objective and I discuss another two methods. However, before showing you the code, I suspect I need to introduce you to Variants. Consider:
Dim A As Long
Dim B As String
Dim C As Double
Dim D As Variant
I have declared A to C as a long integer, a string and a double. These variables can never be anything else and must be used in accordance with the rules for their type. I can write A = A + 1 or A = A * 5. Providing the new value for A does not exceed the maximum value for a long integer, these statements are fine. But I cannot write A = "House" because "House" is not an integer. I can write B = "House" because "House" is a string. I can write B = "5" and then A = A + B because VBA will perform implicit conversions if it can. That is, VBA can convert string "5" to integer 5 and add it to A.
I can also write:
D = 5
D = D + A
D = "House"
D is a Variant which means it can hold any type of data. Here I assign 5 to D then add A so for these two statements, D is holding an integer. I then change my mind and assign a string to D. This is not very sensible code but it is valid code. D can hold much more than an integer and a string. In particular, it can hold an array. Consider:
ReDim D(0 To 2)
D(0) = "House"
D(1) = A + 5
D(2) = 3.7
Following the ReDim statement, it is as though D has been converted to an array and I use array syntax to access the elements of D. D(0) contains "House", D(1) contains 5 more than the current value of A and D(2) contains double 3.7.
I can achieve the same effect with:
D = Array("House", A + 5, 3.7)
I am sure you agree this is easier. Array is a function that can take a large number of parameters and returns a Variant array containing those parameters which I have assigned to D. I do not normally advise mixing types within a variant array since it is very easy to get yourself into a muddle. However, it is valid VBA and I have found it invaluable with particularly difficult problems. Normally, I would not use function Array, I would write:
D = VBA.Array("House", A + 5, 3.7)
With VBA.Array, the lower bound of the array is guaranteed to be zero. With Array, the lower bound depends on the Option Base statement. I have never seen anyone use the Option Base statement, but I do not like to risk having my code changed by someone adding this statement. Search for “VBA Option Base statement” to discover what this statement does.
The following code demonstrates my first method of achieving your objective:
Option Explicit
Sub Method1()
Dim DiscFldrCrnt As Variant
Dim DiscFldrs As Variant
Dim Inx As Long
Dim SenderNameCrnt As Variant
Dim SenderNames As Variant
Dim SubjectCrnt As Variant
Dim Subjects As Variant
SenderNames = VBA.Array("Doe, John", "Early, Jane", "Friday, Mary")
Subjects = VBA.Array("John's topic", "Jane's topic", "Mary's topic")
DiscFldrs = VBA.Array("DoeJohn", "EarlyJane", "FridayMary")
For Inx = 0 To UBound(SenderNames)
SenderNameCrnt = SenderNames(Inx)
SubjectCrnt = Subjects(Inx)
DiscFldrCrnt = DiscFldrs(Inx)
' Code to process SenderNameCrnt, SubjectCrnt and DiscFldrCrnt
Debug.Print SenderNameCrnt & " " & SubjectCrnt & " " & DiscFldrCrnt
Next
End Sub
If you copy this code to a module, you can run it and see what it does. If you work slowly through it, you should be able to understand what it is doing. Come back with questions if necessary but the more you can discover for yourself, the faster you will develop your own skills.
Note: the disc folders have names such as “DoeJohn”. I am assuming you would have something like "C:\Users\NAEC02\Test\" as a root folder and you would save the attachment to "C:\Users\NAEC02\Test\DoeJohn\".
I use this method when I have a small number of values I need to link. It relies on SenderNames(#), Subjects(#) and DiscFldrs(#) being associated. As the number of different combinations increase, it can be difficult to keep the three arrays in step. Method2 solves that problem.
Sub Method2()
Dim DiscFldrCrnt As Variant
Dim Inx As Long
Dim SenderNameCrnt As Variant
Dim SubjectCrnt As Variant
Dim TestValues As Variant
TestValues = Array("Doe, John", "John's topic", "John", _
"Early, Jane", "Jane's topic", "Jane", _
"Friday, Mary", "Mary's topic", "Mary")
For Inx = LBound(TestValues) To UBound(TestValues) Step 3
SenderNameCrnt = TestValues(Inx)
SubjectCrnt = TestValues(Inx + 1)
DiscFldrCrnt = TestValues(Inx + 2)
' Code to process SenderNameCrnt, SubjectCrnt and DiscFldrCrnt
Debug.Print SenderNameCrnt & " " & SubjectCrnt & " " & DiscFldrCrnt
Next
End Sub
Here I have placed all the values in a single array. If I want to add a new sender, I add another three elements to the end of the array which I find this easier to manage. For the code to process the three values, Method1 and Method2 are identical.
The principle disadvantage of Method2 compared with Method1 is that the total number of values is reduced. I like to see all my code so I do not like statements that exceed the width of the screen. This limits my lines to about 100 characters. I use the continuation character to spread the statement over several lines but there is a maximum of 24 continuation lines per statement. With Method1, I am spreading the values over three arrays and therefore three statements so I can have three times as many values. In practice this is not a real limit. Both Method1 and Method2 become too difficult to manage before the VBA limits are reached.
The real disadvantage of Method1 and Method2 is that every change requires the services of a programmer. If user maintenance is important, I use Method3 which reads a text file into arrays or Method4 which reads from an Excel worksheet. I have not included code for either Method3 or Method4 but can add one or both if you need this functionality. I find most users prefer a worksheet but those with a favourite text editor prefer a text file.
In the middle of both Method1 and Method2 I have:
' Code to process SenderNameCrnt, SubjectCrnt and DiscFldrCrnt
Debug.Print SenderNameCrnt & " " & SubjectCrnt & " " & DiscFldrCrnt
You need to replace these statements with a variation of your existing code. I have no easy method of testing the following code so it is untested but it should give you are start.
This is a new version of Items_ItemAdd designed to work with either of my methods.
Private Sub Items_ItemAdd(ByVal Item As Object)
Const DiscFldrRoot As String = "C:\Users\NAEC02\Test\"
' * There is no need to write Outlook.MailItem because (1) you are within Outlook
' and (2) there is no other type of MailItem. You only need to specify Outlook
' for folders since there are both Outlook and Scripting folders. Note:
' "Scripting" is the name of the library containing routines for disc folders.
' * Do not spread your Dim statements throughout your sub. There are languages
' where you can declare variables within code blocks but VBA is not one of those
' languages. With VBA, you can declare variables for an entire sub or function,
' for an entire module or for an entire workbook. If you spread your Dim
' statements out it just makes them hard to find and you are still declaring
' them at the module level.
Dim DiscFldrCrnt As Variant
Dim InxA As Long
Dim Msg As MailItem
Dim SenderNameCrnt As Variant
Dim SubjectCrnt As Variant
' You also need the arrays from whichever of Method1 or Method2 you have chosen
If TypeName(item) = "MailItem" Then
' Only interested in MailItems
Set Msg = Item
' Code from Method1 or Method2 with the code below in the middle
End If
End Sub
Insert the body of Method1 or Method2, whichever you chose, in the middle of the above code. Then insert the following code in the middle of that code.
With Msg
If .Attachments.Count = 0 Then
' Don't bother to check MailItem if there are no attachments
Else
If .Subject <> SubjectCrnt Then
' Wrong subject so ignore this MailItem
ElseIf .SenderName <> SenderNameCrnt Then
' Wrong sender name so ignore this MailItem
Else
' SenderName and Subject match so save any PDF attachments
For InxA = 1 to .Attachments.Count
If LCase(Right$(.Attachments(InxA).DisplayName, 4)) = ".pdf" Then
' Warning: SaveAsFile overwrites existing file with the same name
.Attachments(InxA).SaveAsFile DiscFldrRoot & DiscFldrCrnt & _
.Attachments(InxA).DisplayName
End If
End With
Next
End If
End With

Related

Returns dictionary (associated array) of sub-folders and the amount of email contained within each subfolder within main folder

I provided a solution to click on a folder and return how many items were contained within that folder.
Now, they've asked if that return can be kept, and broken down by sub-folders within the main folder clicked on.
Example:
INBOX has 3 sub-folders: Folder1, Folder2, Folder3
INBOX contains 3 emails of which one email comes from each sub-folder.
Thus:
INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 1
I created a loop that gets all subfolders contained within a main folder into an array.
My next thought was to convert that to a dictionary where I pre-set the items contained to 0. Then upon forming the dictionary using the loop I'm currently using to check if something is within the date range to also see what "folder" it belongs to and add one to the value I've pre-set to zero in the dictionary (associated array) as many times as there is a "match"
Below is what I've attempted:
Sub Countemailsperday()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim ODate As String
Dim ODate2 As String
Dim dict As Dictionary
Set dict = New Dictionary
Dim coll As New Collection
Dim oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
' Dim Dict As Scripting.Dictionary
ODate = InputBox("Start Date? (format YYYY-MM-DD")
ODate2 = InputBox("End Date? (format YYYY-MM-DD")
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = Application.ActiveExplorer.CurrentFolder
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim ssitem As MailItem
Dim dateStr As String
Dim numholder As Integer
Dim myItems As Outlook.Items
'Dim dict As Object
Dim msg As String
Dim oParentFolder As MAPIFolder
Dim i As Integer
Dim iElement As Integer
Dim sArray() As String
Dim ArrayLen As Integer
Dim Subtractor As Integer
Dim str As String
ReDim sArray(0) As String
Set oParentFolder = objFolder
Set myItems = objFolder.Items
'Set Dict = New Scripting.Dictionary
If oParentFolder.Folders.Count Then
For i = 1 To oParentFolder.Folders.Count
If Trim(oParentFolder.Folders(i).Name) <> "" Then
iElement = IIf(sArray(0) = "", 0, UBound(sArray) + 1)
ReDim Preserve sArray(iElement) As String
sArray(iElement) = oParentFolder.Folders(i).Name
End If
Next i
Else
sArray(0) = oParentFolder.Name
End If
ArrayLen = UBound(sArray) - LBound(sArray) + 1
'MsgBox "thingy thing"
'MsgBox "thing" & sArray(1) ' This is how to iterate through the Dictionary
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
' MsgBox DateValue(ODate)
For Subtractor = 0 To (ArrayLen - 1)
If oDict.Exists(sArray(Subtractor)) Then
oDict(sArray(Subtractor)).Add
With dict
For Subtractor = 0 To (ArrayLen - 1)
If ArrayLen = 1 Then
.Add Key = objFolder.Name, Item = 0
Else
If Subtractor = 0 Then
.Add Key = CStr(sArray(Subtractor)), Item = 0
Else
End If
str = CStr(sArray(Subtractor))
End If
Next Subtractor
End With
MsgBox str
If dict.Exists(str) Then
Debug.Print (dict(str))
Else
Debug.Print ("Not Found")
End If
MsgBox dict(str)
numholder = 0
'For Each
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
' MsgBox DateValue(dateStr)
If DateValue(dateStr) >= DateValue(ODate) And DateValue(dateStr) <= DateValue(ODate2) Then
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
numholder = numholder
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
numholder = numholder + 1
End If
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
If msg = "" Then
MsgBox "There are no emails during this time range"
End If
If msg <> "" Then
MsgBox "Number of emails during date range: " & numholder
MsgBox msg
End If
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
Function GetDate(dt As Date) As Date
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function
I want to accomplish the following:
INBOX Total: 3
Folder1 Total: 1
Folder2 Total: 1
Folder3 Total: 1
as well as to handle the case where the folder that's clicked on contains no subfolders.
I do not understand your code. You do things but do not explain how they contribute to your objective. There is date processing code which does not appear relevant. If one could write code and never need to look at it again, the lack of comments would be OK. But normally, after six, twelve or twenty months, a routine needs some attention. Perhaps there is an edge condition that is not handled correctly or perhaps the requirement has changed. Maintaining poorly documented code is a nightmare.
The code at the bottom of this answer is a simplified version of a routine I wrote some years ago. It does not do exactly what you appear to request and it does not use the technique you request. Perhaps my code will be acceptable. If not, I believe I have included enough explanations to allow you to amend my code to your requirements.
First an introduction to the techniques I have used. As peakpeak suggests, my code uses recursion. I have also used a collection instead of a dictionary. These techniques are not documented in the code because they are standard features of VBA and I do not document VBA within my code.
I do not use dictionaries. Collections provide all the functionality I have ever required. Dictionaries, as I understand it, have much in common with collections and have some functionality that collections lack. But more importantly for me, they lack some of the functionality of collections that I find essential.
You specify a collection so:
Dim Coll As New Collection
or
Dim Coll As Collection
Set Coll = New Collection
Coll.Add X will create a new entry at the end of Coll containing X. You can add new entries in the middle of existing entries and you can remove existing entries but I do not use this functionality in the code below.
In Coll.Add X, X can be almost anything. It can be a simple value such as a string, a long or a Boolean. It can be an array or an instance of a class. It cannot be an instance of a user type. You cannot amend an entry within a collection. Should you need to amend an entry, you must remove the existing entry and add the amended version in the same position.
Since an entry within a collection can be anything, you need to be careful. If variable I is a Long:
I = I + Coll(5)
will give a runtime error if Coll(5) is a string or anything else that cannot be added to a Long.
If you add an array to a Collection, the syntax for reading it is, perhaps, not immediately obvious. Consider:
Coll.Add VBA.Array(Fldr.Name, Level, NumEmails)
Suppose the above Add has created the third entry in Coll; that is Coll(3). Then:
Coll(3)(0) is FldrName
Coll(3)(1) is Level
Coll(3)(2) is NumEmails
Note that I use VBA.Array instead of Array because Array is affected by the Option Base statement. By using VBA.Array I know the lower bound will always be zero.
On reflection, perhaps this syntax is not so strange. If I declare Dim Arr(0 To 5) As Long, I write Arr(0) to access element 0 of Arr. My Coll(3) is an array so I write Coll(3)(0) to access element 0 of Coll(3).
Recursion is where a routine calls itself. This technique is ideal for processing tree-like structures. There are techniques that are faster and not such heavy users of memory but none of these other techniques are so simple to use.
Suppose the folder hierarchy to be processed is:
FolderA
FolderB
FolderC
FolderD
FolderE
FolderF
FolderG
My routine is NumEmailsByFolder and has parameters:
Reference to top level folder
Long Level
Reference to collection FldrDtls
Level is not mentioned in your requirement but without it you cannot tell that FolderF is within FolderA. I tend to think of the top level as level 0 but you can use any value you find convenient.
The external routine creates an empty collection, which my routine call FldrDtls, and then calls:
NumEmailsByFolder([FolderA], 0, [FldrDtls])
Where [X] indicates a reference to object X.
NumEmailsByFolder counts the number of emails in FolderA, adds an entry to FldrDtls with the name “FolderA”, level 0, and the email count. It then calls itself for FolderB, FolderF and FolderG with level 1. This makes for pretty simple code. The secret of recursion is the sequence in which the interpreter actions all the different calls:
Calls in sequence executed Entry added to FldrDtls
NumEmailsByFolder([FolderA], 0, [FldrDtls]) FolderA 0 Count
NumEmailsByFolder([FolderB], 1, [FldrDtls]) FolderB 1 Count
NumEmailsByFolder([FolderC], 2, [FldrDtls]) FolderC 2 Count
NumEmailsByFolder([FolderD], 2, [FldrDtls]) FolderD 2 Count
NumEmailsByFolder([FolderE], 2, [FldrDtls]) FolderE 3 Count
NumEmailsByFolder([FolderF], 1, [FldrDtls]) FolderF 1 Count
NumEmailsByFolder([FolderG], 1, [FldrDtls]) FolderG 1 Count
The entries in FldrDtls are in the sequence wanted with subfolders following their parent folders. I have only four levels in my example hierarchy but the same code will handle 10 or 100 levels with all the difficult stuff handled by the interpreter.
Most people seem to find recursion difficult to understand at first; certainly I did when I was taught it at university many years ago. Then suddenly you see the light and you no longer understand why you found it difficult. I compare it with learning to drive a car. At the end of the first lesson you know you will never be able to turn the wheel, press one or more pedals, move the gearstick, look in the mirror and use the indicator while trying to avoid other road users all at the same time. But a few lessons later, you can do all that and more.
My routine is:
Sub NumEmailsByFolder(ByRef FldrPrnt As Folder, ByVal Level As Long, _
ByRef FldrDtls As Collection)
' Adds an entry to FldrDtls for FldrPrnt.
' Calls itself for each immediate subfolder of FldrPrnt.
' Each entry in FldrDtls is an zero-based array containing:
' * (0) Folder name
' * (1) Level of folder within hierarchy. The level of the first (top)
' folder is as specified in the call. Each level down is one more.
' * (2) Number of emails in folder. Note: this value does not include
' any emails in any subfolders
' The external routine that calls this routine will set the parameters:
' * FldrPrnt can be a Store or a MAPIFolder at any level with the
' folder hierarchy.
' * Level might typically be set to zero or one but the initial value
' is unimportant to this routine.
' * FldrDtls would normally be an empty collection. This is not checked
' so FldrDtls may contain existing entries if this is convenient for
' the calling routine.
' On return to the external routine, the entries in FldrDtls might be:
' Inbox 0 10
' SubFldr1 1 5
' SubSubFldr1 2 3
' SubSubFldr2 2 4
' SubFldr2 1 9
Dim ErrNum As Long
Dim InxI As Long
Dim InxS As Long
Dim ItemsCrnt As Items
Dim SubFldrsCrnt As Folders
Dim NumMailItems As Long
With FldrPrnt
'Count MailItems, if any
Err.Clear
NumMailItems = 0
' In the past, I have had code crash when I attempted to access the
' Items of a folder but I have had no such error recently. This could
' be because I am now retired and my employer's Outlook installation
' had folders without items. Alternatively, it could be because
' Outlook 2016 is more robust than Outlook 2003. I use On Error to
' ensure any such error does not crash my routine.
On Error Resume Next
Set ItemsCrnt = FldrPrnt.Items
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Only attempt to count MailItems within FldrPrnt if attempting to
' access its Items does not give an error.
For InxI = 1 To ItemsCrnt.Count
If ItemsCrnt(InxI).Class = olMail Then
NumMailItems = NumMailItems + 1
End If
Next
End If
FldrDtls.Add VBA.Array(FldrPrnt.Name, Level, NumMailItems)
Set SubFldrsCrnt = FldrPrnt.Folders
' See above for explanation of On Error
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
' Only attempt to count MailItems within FldrPrnt if attempting to
' access its Folders does not give an error.
For InxS = 1 To SubFldrsCrnt.Count
Call NumEmailsByFolder(SubFldrsCrnt(InxS), Level + 1, FldrDtls)
Next
End If
End With
End Sub
I hope you agree that this code is simple considering what it can achieve. If I thought it was safe to remove the error handling code, the routine would be even smaller.
To demonstrate how to call this routine, add the following code:
Option Explicit
Sub TestNumEmailsByFolder()
Dim FldrDtls As Collection
Dim Fldr1 As Folder
Dim Fldr2 As Folder
Dim Fldr3 As Folder
Dim FldrCrnt As Folder
Dim FldrInx As Variant
Dim InxF As Long
Set Fldr1 = Session.Folders("johndoe#acme.com").Folders("Inbox").Folders("Test")
Set Fldr2 = Session.Folders("johndoe#acme.com").Folders("Inbox")
Set Fldr3 = Session.Folders("johndoe#acme.com")
For Each FldrInx In Array(Fldr1, Fldr2, Fldr3)
Set FldrCrnt = FldrInx
Set FldrDtls = New Collection
Call NumEmailsByFolder(FldrCrnt, 0, FldrDtls)
Debug.Print "Emails"
For InxF = 1 To FldrDtls.Count
Debug.Print PadL(FldrDtls(InxF)(2), 5) & _
Space(1 + FldrDtls(InxF)(1) * 2) & FldrDtls(InxF)(0)
Next
Next
End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
Amend the Set Fldr1, Set Fldr2 and Set Fldr3 statements to reference folders on your system. I have started with a folder at the bottom of the hierarchy then a folder in the middle and then a folder at the top. I suggest you pick a similar set of folders. Study the output to the Immediate Window and consider how the sequence of the list has been created.
Is this the routine you want?
It uses a Collection instead of a Dictionary? Does this matter? If my understanding of Dictionaries is correct, a Dictionary would be inappropriate.
You use an array and ReDim Preserve. A Collection is a good choice when you have no idea how many entries will be required. ReDim Preserve is an expensive command in terms of time and memory. The interpreter has to find a new block of memory big enough for the enlarged array. It has to copy values from the old array to the new and initialise the new elements. Finally, it has to release the old array for garbage collection. If I need the final result to be in an array then, with this type of problem, I normally build the list in a collection, size my array according to the size of the collection and then copy data from the collection to the array.
The count of emails against a folder does not include emails in its subfolders. This appears to be a requirement. You cannot amend an entry in a collection so, if this is a requirement, I would handle it as part of the conversion to an array.
Subfolders are not listed in alphabetic sequence. I have never investigated properly but I suspect subfolders are listed in the sequence created. If this is unsatisfactory, you will need a sort. There are several possible approaches. Given there will normally be a small number of subfolders per folder, I suspect the simplest approach will be the best. If you need something a lot more powerful, I have an implementation of Quick Sort that uses indices to avoid sorting the source list.

Saving attachments results in memory errors

I need to search through 9,000 emails and save the attachments with a certain timestamp (these are security camera feeds).
The code works on a small number of emails, but after about 20 the processing in Outlook appears to speed up significantly (attachments stop saving) and then Outlook hangs with a memory error.
My guess is the save step is not completed before the script moves to the next email in the target folder and therefore the backlog of saves becomes too large for Outlook.
' this function grabs the timestamp from the email body
' to use as the file rename on save in the following public sub
Private Function GetName(olItem As MailItem) As String
Const strFind As String = "Exact Submission Timestamp: "
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strDate As String
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(strFind)
oRng.Collapse 0
oRng.End = oRng.End + 23
strDate = oRng.Text
strDate = Replace(strDate, Chr(58), Chr(95))
GetName = strDate & ".jpg"
Exit Do
Loop
End With
End With
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Function
End Function
Public Sub SaveAttachmentsToDisk24(MItem As outlook.MailItem)
Dim oAttachment As outlook.Attachment
Dim sSaveFolder As String
Dim strFname As String
sSaveFolder = "C:\Users\xxxxx\"
For Each oAttachment In MItem.Attachments
If oAttachment.FileName Like "*.jpg" Then
strFname = GetName(MItem)
oAttachment.SaveAsFile sSaveFolder & strFname
Set oAttachment = Nothing
Set MItem = Nothing
End If
Next oAttachment
There are other possibilities but my belief is that the memory errors are the result of creating Word objects and then not closing them. Om3r asked for more information but you ignored his requests making it impossible to provide a definitive answer. However, I wanted to prove it was possible to extract attachments from a large number of emails without problems so I have made some guesses.
I understand why you need a routine that will scan your Inbox for the backlog of 8,000 camera feed emails. I do not understand why you want to use an event to monitor your Inbox as well. I cannot believe this is a time critical task. Why not just run the scan once or twice a day? However, the routine I have coded could be adapted to create a macro to be called by an event routine. My current code relies of global variables which you will have to change to local variables. I am not a fan of global variables but I did not want to create a folder reference for every call of the inner routine and the parameter list for a macro that might be called by an event routine is fixed.
To test the code I planned to create, I first generated 790 emails to myself that matched (I hope) your camera feed emails. I had planned to create more but I think my ISP has classified me as a spammer, or perhaps a flamer, and it would not let me send any more. The body of these emails looked like:
xxx Preamble xxx ‹cr›‹lf›|
Exact Submission Timestamp: 2019-02-22 15:00:00 ‹cr›‹lf›|
xxx Postamble xxx ‹cr›‹lf›|
Your code requires the string “Exact Submission Timestamp:” followed by a date which you use as a file name. I have assumed that date in in a format that VBA can recognise as a date and I have assumed the date is ended by a standard Windows newline (carriage return, line feed). The second assumption would be easy to change. I have a routine that will accept many more date formats than VBA’s CDate which I can provide if necessary.
Each email has a different date and time between November, 2018 and February, 2019.
I would never save 8,000 files in a single disc folder. Even with a few hundred files in a folder, it becomes difficult to find the one you want. My root folder is “C:\DataArea\Test” but you can easily change that. Given the timestamp in my example email, my routine would check for folder “C:\DataArea\Test\2019” then “C:\DataArea\Test\2019\02” and finally “C:\DataArea\Test\2019\02\22”. If a folder did not exist, it would be created. The attachment is then saved in the inner folder. My code could easily be adapted to save files at the month level or the hour level depending on how many of these files you get per month, day or hour.
My routine checks every email in Inbox for the string “Exact Submission Timestamp:” followed by a date. If it finds those, it checks for an attachment with an extension of JPG. If the email passes all these tests, the attachment is saved in the appropriate disc folder and the email is moved from Outlook folder “Inbox” to “CameraFeeds1”. The reasons for moving the email are: (1) it clears the Inbox and (2) you can rerun the routine as often as you wish without finding an already processed email. I named the destination folder “CameraFeeds1” because you wrote that you wanted to do some more work on these emails. I thought you could move the emails to folder “CameraFeeds2” once you had completed this further work.
I assumed processing 790 or 8,000 emails would take a long time. In my test, the duration was not as bad as I expected; 790 emails took about one and a half minutes. However, I created a user form to show progress. I cannot include the form in my answer so you will have to create your own. Mine looks like:
The appearance is not important. What is important is the name of the form and the four controls on the form:
Form name: frmSaveCameraFeeds
TextBox name: txtCountCrnt
TextBox name: txtCountMax
CommandButton name: cmdStart
CommandButton name: cmdStop
If you run the macro StartSaveCameraFeeds it will load this form. Click [Start] to start the save process. You can let the macro run until it has checked every email in the Inbox or you can click [Stop] at any time. The stop button is not as important as I feared. I thought the routine might take hours but that was not the case.
You don’t report where your 8,000 emails are. I have an Inbox per account plus the default Inbox which I only use for testing. I moved the 790 test emails to the default Inbox and used GetDefaultFolder to reference it. I assume you know how to reference another folder if necessary. Note I use Session instead of a name space. These two methods are supposed to be equivalent but I always use Session because it is simpler and because I once had a failure with a name space that I could not diagnose. I reference folder “CameraFeeds1” relative to the Inbox.
You will have to adjust my code at least partially. For the minimum changes, do the following:
Create a new module and copy this code into it:
Option Explicit
Public Const Marker As String = "Exact Submission Timestamp: "
Public Const RootSave As String = "C:\DataArea\Test"
Public FldrIn As Outlook.Folder
Public FldrOut As Outlook.Folder
Sub StartSaveCameraFeeds()
' Reference outlook folders then pass control to frmSaveCameraFeeds
Set FldrIn = Session.GetDefaultFolder(olFolderInbox)
Set FldrOut = FldrIn.Parent.Folders("CameraFeeds1")
Load frmSaveCameraFeeds
With frmSaveCameraFeeds
.Caption = "Saving jpg files from Camera feed emails"
.txtCountCrnt = 0
.txtCountMax = FldrIn.Items.Count
.Show vbModal
End With
' Form unloaded by cmdStop within form
Set FldrIn = Nothing
Set FldrOut = Nothing
End Sub
Public Sub SaveCameraFeed(ByRef ItemCrnt As MailItem)
' Checks a single mail item to be a "camera feed" email. If the mail item is
' a "camera feed" email, it saves the JPG file using the date within the
' email body as the file name. If the mail item is not a "camera feed"
' email, it does nothing.
' To be a camera feed mail item:
' * The text body must contain a string of the form: "xxxyyyy" & vbCr & vbLf
' where "xxx" matches the public constant Marker and "yyy" is recognised
' by VBA as a date
' * It must have an attachment with an extension of "JPG" or "jpg".
' If the mail item is a camera feed email:
' * In "yyy" any colons are replaced by understores.
' * The JPG attachment is saved with the name yyy & ".jpg"
Dim DateCrnt As Date
Dim DateStr As String
Dim DayCrnt As String
Dim InxA As Long
Dim MonthCrnt As String
Dim PathFileName As String
Dim PosEnd As Long
Dim PosStart As Long
Dim SomethingToSave As Boolean
Dim YearCrnt As String
SomethingToSave = False ' Assume no JPG to save until find otherwise
With ItemCrnt
PosStart = InStr(1, .Body, Marker)
If PosStart > 0 Then
PosStart = PosStart + Len(Marker)
PosEnd = InStr(PosStart, .Body, vbCr & vbLf)
DateStr = Mid$(.Body, PosStart, PosEnd - PosStart)
If IsDate(DateStr) Then
DateCrnt = DateStr
For InxA = 1 To .Attachments.Count
If LCase(Right$(.Attachments(InxA).Filename, 4)) = ".jpg" Then
SomethingToSave = True
Exit For
End If
Next
End If
End If
If SomethingToSave Then
DateStr = Replace(DateStr, ":", "_")
YearCrnt = Year(DateCrnt)
MonthCrnt = Month(DateCrnt)
DayCrnt = Day(DateCrnt)
Call CreateDiscFldrIfItDoesntExist(RootSave, YearCrnt, MonthCrnt, DayCrnt)
PathFileName = RootSave & "\" & YearCrnt & "\" & MonthCrnt & "\" & DayCrnt & _
"\" & Trim(DateStr) & ".jpg"
.Attachments(InxA).SaveAsFile PathFileName
.Move FldrOut
End If
End With
End Sub
Public Sub CreateDiscFldrIfItDoesntExist(ByVal Root As String, _
ParamArray SubFldrs() As Variant)
' If a specified disk folder (not an Outlook folder) does not exist, create it.
' Root A disk folder which must exist and for which the user
' must have write permission.
' SubFldrs A list of sub-folders required within folder Root.
' Example call: CreateDiscFldrsIfNecessary("C:\DataArea", "Aaa", "Bbb", "Ccc")
' Result: Folder "C:\DataArea\Aaa\Bbb\Ccc" will be created if it does not already exist.
' Note: MkDir("C:\DataArea\Aaa\Bbb\Ccc") fails unless folder "C:\DataArea\Aaa\Bbb" exists.
Dim Filename As String
Dim Fldrname As String
Dim InxSF As Long
Fldrname = Root
For InxSF = LBound(SubFldrs) To UBound(SubFldrs)
Fldrname = Fldrname & "\" & SubFldrs(InxSF)
If Not PathExists(Fldrname) Then
Call MkDir(Fldrname)
End If
Next
End Sub
Public Function PathExists(ByVal Pathname As String) As Boolean
' Returns True if path exists
' Coded by Tony Dallimore
' Based on code written by iDevlop: http://stackoverflow.com/a/28237845/973283
On Error Resume Next
PathExists = ((GetAttr(Pathname) And vbDirectory) = vbDirectory)
On Error GoTo 0
End Function
I must warn you that I have modules full of standard routines that I use all the time. I believe I have included all the standard routines used by the code I have written for you. If the code fails because a sub or function is missing, post a comment and I will apologise and add the missing macro to my code.
Near the top of the above code is Public Const RootSave As String = "C:\DataArea\Test". You will have to change this to reference your root folder.
The first statement of Sub StartSaveCameraFeeds() is Set FldrIn = Session.GetDefaultFolder(olFolderInbox). Amend this as necessary if the emails are not in the default Inbox.
In the body of Sub StartSaveCameraFeeds() you will find PosEnd = InStr(PosStart, .Body, vbCr & vbLf). If the date string is not ended by a standard Windows’ newline, amend this statement as necessary.
Create a user form. Add two TextBoxes and two CommandButtons. Name them as defined above. Copy the code below to the code area of the form:
Option Explicit
Private Sub cmdStart_Click()
' Call SaveCameraFeed for every MailItem in FldrIn
Dim CountMax As Long
Dim InxI As Long
Dim MailItemCrnt As MailItem
With FldrIn
CountMax = FldrIn.Items.Count
For InxI = CountMax To 1 Step -1
If .Items(InxI).Class = olMail Then
Set MailItemCrnt = .Items(InxI)
Call SaveCameraFeed(MailItemCrnt)
Set MailItemCrnt = Nothing
End If
txtCountCrnt = CountMax - InxI + 1
DoEvents
Next
End With
Unload Me
End Sub
Private Sub cmdStop_Click()
Unload Me
End Sub
The form code should not need amendment.
As I have already written, this code processed 790 camera feed emails in about one and a half minutes. I coded a further routine that checked that for every email the date matched the name of a jpg file. I could include this routine in my answer if you would like to perform the same check.

Search currently viewed email for a specific phrase, fetch a string to copy to clipboard

I get assignments in emails that come to a shared Outlook mailbox.
In a typical email there are multiple strings and variables regarding a client, including their name, date and ID with a hyphen that I also want to get rid of.
There are two types of IDs. Both consist of 8 numbers and a hyphen, e.g. 1234567-8 and 123456-78. Sometimes there is a character in front of the number so I believe storing data in string is a must. I want to make several copies of the macro for each type of data. I want it all in a simple string form as I want to copy it to clipboard and paste elsewhere and have no need to process it further.
The code below does all I want except it stores the data in variables instead of string and does not remove the hyphen.
Code courtesy of vbaexpress' gmayor.
Option Explicit
Sub GetCustomer()
Dim olItem As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim dCust As DataObject
Dim wdDoc As Object
Dim oRng As Object
Dim sCustomer As String
Dim bFound As Boolean
On Error GoTo lbl_Exit
Set olItem = ActiveExplorer.Selection.Item(1)
With olItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(findText:="Customer #:[ 0-9]{2,}", MatchWildcards:=True)
sCustomer = Trim(Split(oRng.Text, Chr(58))(1))
bFound = True
Set dCust = New DataObject
dCust.SetText sCustomer
dCust.PutInClipboard
MsgBox "Customer number '" & sCustomer & "' copied to clipboard"
Exit Do
Loop
End With
If Not bFound Then MsgBox "Customer number not found"
End With
lbl_Exit:
Set olItem = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set dCust = Nothing
Exit Sub
End Sub
I want to search the currently previewed email (if that is possible), without actually opening it in another separate window, for a phrase like
"Customer ID: 123456-78"
and reformat the last part by simply removing the hyphen and disregarding the first part
"Customer ID: "
(there is a giant space between the Customer ID and the number).
I also want to reformat the date from 11.22.2019 to 2019-22-11 and also copy it to clipboard.
Searches based on wildcards are limited to what wildcards can provide, which is better than nothing, but still not very much.
Outlook uses Word functions for this, so that the VBA documentation for Word applies. Applicable wildcards themselves are can be seen using the "Special" button in the "Find" dialog (F4 in Outlook), after "use wildcards" has been checked.
To my knowledge there is no concept of "optional" parts in wildcard searches, which means you need to try more than one wildcard pattern to cover your "sometimes there is a letter in front" case.
So the general approach, based this knowledge and on your sample code, would be
Pick the currently selected MailItem in the ActiveExplorer
For each predefined wildcard pattern
reset the search range to the whole email
execute wildcard search
as long as there are search hits
display result, let user pick or cancel the search
This way multiple patterns can be defined and you have a chance to continue to the next hit if the first hit is a false positive.
I found the pattern [0-9-]{8;9} plus MatchWholeWord to work reasonably well (blocks of digits and dashes, between 8 or 9 characters long), but real life data often has surprises. You will probably need to add more patterns. Watch out: for me, Outlook wants ; instead of ,. This might be dependent on the system locale, I'm not sure.
Also I'm not a fan of a "silent" On Error Resume. If there is an error, I prefer to see an error actual message. If there is a condition that can be checked in order to prevent an error, I prefer to check for this condition explicitly. This makes the code more robust and debugging easier. My Sub does not contain an On Error line for that reason.
In code, this would look like this:
Sub GetCustomer()
Dim olItem As Outlook.MailItem
Dim oRng As Object
Dim sCustomer As String
Dim patterns As Variant, pattern As Variant
Dim answer As VbMsgBoxResult
' bail out if the preconditions are not right
If ActiveExplorer.Selection.Count = 0 Then Exit Sub
If Not (TypeOf ActiveExplorer.Selection.item(1) Is MailItem) Then Exit Sub
Set olItem = ActiveExplorer.Selection.item(1)
Set oRng = olItem.GetInspector.WordEditor.Range
' add more wildcard patterns in descending order of likelyhood
patterns = Array("[0-9-]{8;9}", "[A-Z][0-9-]{8;9}")
For Each pattern In patterns
oRng.WholeStory
While oRng.Find.Execute(findText:=pattern, MatchWildcards:=True, MatchWholeWord:=True)
answer = MsgBox(oRng.Text, vbYesNoCancel + vbQuestion, "Customer Number")
If answer = vbYes Then
With New DataObject
.SetText oRng.Text
.PutInClipboard
End With
Exit For
ElseIf answer = vbCancel Then
Exit For
End If
Wend
Next pattern
End Sub
Setting variables to Nothing at the end of the function is superfluous.

Trying to extract information between two symbols from outlook subject

I am trying to pull text between two symbols:
S1 | STAR2449524 | XYZ Bank | 1 - Critical |Health Service Heartbeat Failure.
I need to extract | XYZ Bank |
Which is between 2'nd appearance of symbol and place it in my template where variable name is COMP1 |
Sub Reply_Test()
Dim origEmail As MailItem
Dim replyEmail As MailItem
Dim oRespond As Outlook.MailItem
Dim INC1 As String 'For Incident Number
Dim INo As Integer 'For Incident Number
Dim COMP1 As String 'For Company Name
Dim Com As Integer 'For Company Name
Dim ISSU1 As String ' For Issue
Dim Isu As Integer 'for Issue
Dim varSplit As Variant
'Dim msginfo As msg.Subject (Tried using not worked)
varSplit = Split("New incident |S1 | ICM1449524 | XYZ Bank | P1 - Critical |Health Service Heartbeat Failure.", "|")
'varSplit = Split(msginfo, "|") (Tried using not worked)
strSubject1 = varSplit(0)
strSubject2 = varSplit(1)
strSubject3 = varSplit(2)
strSubject4 = varSplit(3)
strSubject5 = varSplit(4)
Set origEmail = Application.ActiveWindow.Selection.Item(1)
Set replyEmail = Application.CreateItemFromTemplate("H:\Documents\test.oft")
replyEmail.To = origEmail.Reply.To
replyEmail.CC = "abc#xyz.com"
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.Subject = replyEmail.Subject & origEmail.Reply.Subject
replyEmail.Subject = " <P1> - " & strSubject2 & " " & "For" & " " & strSubject3
replyEmail.Display
End Sub
A an alternative to the macro suggested in my comment, you may find the one below more convenient. Add something like:
Debug.Print "=====Text====="
Debug.Print TidyTextForDspl(.Body)
Debug.Print "=====Html====="
Debug.Print TidyTextForDspl(.HTMLBody)
Debug.Print "=====End====="
to your existing macro.
Public Function TidyTextForDspl(ByVal Text As String) As String
' Tidy Text for dsplay by replacing white space with visible strings:
' Replace spaces by {s} or {n s}
' Replace line feed by {lf} or {n lf}
' Replace carriage return by {cr} or {n cr}
' Replace tab by {tb} or {n tb}
' Replace non-break space by {nbs} or {n nbs}
' Where n is a count if the character repeats
' 15Mar16 Coded
Dim InsStr As String
Dim InxWsChar As Long
Dim NumWsChar As Long
Dim PosWsChar As Long
Dim RetnVal As String
Dim WsCharCrnt As Variant
Dim WsCharValue As Variant
Dim WsCharDspl As Variant
WsCharValue = Array(" ", vbLf, vbCr, vbTab, Chr(160))
WsCharDspl = Array("s", "lf", "cr", "tb", "nbs")
RetnVal = Text
For InxWsChar = LBound(WsCharValue) To UBound(WsCharValue)
Do While True
PosWsChar = InStr(1, RetnVal, WsCharValue(InxWsChar))
If PosWsChar = 0 Then
Exit Do
End If
NumWsChar = 1
Do While Mid(RetnVal, PosWsChar + NumWsChar, 1) = WsCharValue(InxWsChar)
NumWsChar = NumWsChar + 1
Loop
If NumWsChar = 1 Then
InsStr = "{" & WsCharDspl(InxWsChar) & "}"
Else
InsStr = "{" & NumWsChar & WsCharDspl(InxWsChar) & "}"
End If
RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & InsStr & Mid(RetnVal, PosWsChar + NumWsChar)
Loop
Next
TidyTextForDspl = RetnVal
End Function
New section in response to question in comment
InStr is not the most useful function for your requirement. I recommend Split.
Split splits a string on a delimiter and returns the parts as an zero-based, one-dimensioned array.
The documentation says Split always returns a zero-based array and I have always found that to be true. However, there are functions that are affected by the Option Base statement so I always use the LBound function to be absolutely clear which element I am accessing.
This little macro uses Split to split your example string. I have used Trim to remove any leading or trailing spaces.
Option Explicit
Sub Test()
Dim Inx As Long
Dim Parts() As String
Parts = Split("S1 | ICM21449524 | XYZ Bank | P1 - Critical |Health Service Heartbeat Failure", "|")
For Inx = LBound(Parts) To UBound(Parts)
Debug.Print Inx & " [" & Trim(Parts(Inx)) & "]"
Next
End Sub
Second new section
You are not answering my question. Perhaps you do not understand its significance so I will give some demonstration code for the two most likely answers.
If you want a macro to process some emails, there are different ways of specifying which emails are to be processed.
One approach is for the user to select all the emails to be processed before starting the macro. If you click LeftMouse on an email, it is selected. If you then press and hold Shift while clicking Up or Down, you can select a block of contiguous emails. If you hold Ctrl while clicking LeftMouse on emails, you can select non-contiguous emails.
Select some emails and then run this macro:
Public Sub DemoExplorer()
Dim Exp As Outlook.Explorer
Dim ItemCrnt As MailItem
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemCrnt In Exp.Selection
With ItemCrnt
Debug.Print "--------------------------"
Debug.Print "From: " & .SenderName
Debug.Print "Subject: " & .Subject
Debug.Print "Received: " & Format(.ReceivedTime, "dMMMyy h:mm:ss")
End With
Next
End If
End Sub
The above macro is one of my standard demonstration macros. It outputs a number of properties of each of the selected emails to the immediate window. You are only interested in Subject but I decided to leave the others for reference.
Another approach is for the user to move the emails to be processed to a special folder with a name such as “ToProcess”. The macro is coded to look at folder “ToProcess” and to process the emails within it. After the emails have been processed, they can be moved on to another folder with a name such as “Processed”. This is not an approach I favour so I have no code to demonstrate it. Instead I explain how to amend the next macro to match this approach.
My most used approach is to search down Inbox for new emails with specific characteristics. The macro processes these emails and then moves them to a “Processed” folder. This approach saves the user the bother of searching for the emails to be processed and moving them twice.
The code below expects to find a folder “Processed2” within the default Inbox. Either create folder “Processed2” within the default Inbox and run my code unchanged or amend my code so FolderDest2 references a folder of your choice. This code processes any email with a pipe, “|”, in the Subject. You will need to expand my code so only the required emails are processed.
Public Sub DemoSearch()
Dim FolderDest2 As MAPIFolder
Dim FolderDest1 As MAPIFolder
Dim FolderSrc1 As MAPIFolder
Dim FolderSrc2 As MAPIFolder
Dim InxItemCrnt As Long
Dim InxPart As Long
Dim NS As Outlook.NameSpace
Dim SubjectPart() As String
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
' This is the easiest way to reference the default Inbox.
' However, you must be careful if, like me, you have multiple email addresses
' each with their own Inbox. The default Inbox may not be where you think it is.
Set FolderSrc1 = NS.GetDefaultFolder(olFolderInbox)
' This references the Inbox in a specific PST or OST file.
' "tonydallimore23#gmail.com" is the user name that Outlook gave the OST file in
' which it stores emails sent to this account when I created the account. The user
' name is the name Output displays to the user. The file name on disk is different.
Set FolderSrc2 = NS.Folders("tonydallimore23#gmail.com").Folders("Inbox")
' I do not know where you want to save processed emails. I have created
' FolderDest1 to show how to access a folder at the same level as Inbox
' but my code uses FolderDest2 which is a sub-folder of Inbox.
' This gets a reference to folder "Processed1" which is at the same level
' as the default Inbox.
' I have started at FolderSrc1 (Inbox) gone up one level to its parent
' (outlook data file) and doen to another child ("Processed1")
Set FolderDest1 = FolderSrc1.Parent.Folders("Processed1")
' This gets a reference to folder "Processed2" which is a sub-folder of
' the default Inbox.
Set FolderDest2 = FolderSrc1.Folders("Processed2")
' This examines the emails in reverse order.
' If I process email number 5 and then move it to another folder,
' the number of all subsequence emails is decreased by 1. If I looked at the
' emails in ascending sequence, email 6 would be ignored because it would have
' been renumbered wehn I looked for it. By looking at the emails in reverse
' sequence, I ensure email 6 has bee processed before the removal of email 5
' changes its number.
' I do not know how you identify the emails you want to process. I process
' any email with a pipe , "|", in the Subject
For InxItemCrnt = FolderSrc1.Items.Count To 1 Step -1
With FolderSrc1.Items.Item(InxItemCrnt)
If .Class = olMail Then
' I am only interested in mail items.
If .Subject <> "" Then
' ONlt attept split if there is a Subject
SubjectPart = Split(.Subject, "|")
If LBound(SubjectPart) <> UBound(SubjectPart) Then
' There is at least one pipe, "|", within the subject
Debug.Print "====="
Debug.Print " Sender " & .SenderEmailAddress
Debug.Print " Received " & Format(.ReceivedTime, "ddmmmyy hh:mm:ss")
Debug.Print " Subject: "
For InxPart = LBound(SubjectPart) To UBound(SubjectPart)
Debug.Print " " & Trim(SubjectPart(InxPart))
Next InxPart
.Move FolderDest2
End If ' LBound(SubjectPart) <> UBound(SubjectPart)
End If ' .Subject <> ""
End If ' .Class = olMail
End With ' FolderSrc1.Items.Item(InxItemCrnt)
Next InxItemCrnt
End Sub
If you prefer my second approach, you will need to amend the above code slightly. .Move FolderDest2, near the bottom, must be deleted. The statement near the top to specify the source folder will require amendment. I recommend you retain the code to identify emails to be processed in case the case accidentally move an inappropriate email to the source folder.
I hope running these two macros will fully explain the significance of my question. I wanted to only provide the code for the email selection method you preferred. I have now provided the code for the two major approach. Select whichever best meets your requirements as the basis for your macro.

Find and Select an Outlook Email from MS Access

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