PDA

View Full Version : Send reminder emails based on date in column, after finding last email correspondance



AlanB
07-21-2019, 12:22 PM
Hi

I am looking to set up a VBA to send follow up emails from excel. I have a few parameters outside of the norm for the macro to do what I would exactly like.

I would like the macro to run down Column P and send a mail each time it finds a cell containing either todays date (date macro is run) or a date in the past.
If cells in column P are blank or a date in the future no email would be sent. (Dates are normally displayed in written form e.g. 25 July 2019 - not sure if that makes a difference?

If a suitable date is found then an email would be sent to the email address in the same row which would be in column i.

Before an email is actually sent I would like the VBA to search all folders in outlook for the last email correspondence (sent or received) from that address and send it as a reply all and therefore keeping all previous content from earlier emails. (All VBA examples I can find are based on finding most recent subject line)

In terms of the email itself I would the other information to be found from the information found in the same row as the email it is being sent to-


Cc email address - in column J - (often there will be no cc and this column blank)
The subject of the email in column Q
The greeting - Dear name - to be found in column R
The body of the email to be found in column S
Signature in column T
Attachment location in column U - if none found send anyway


I can find similar code to most of my requests but putting it together or making the adjustments is beyond me.

Many thanks if anyone can help
Alan

Kenneth Hobs
07-22-2019, 07:16 PM
I could do it all but the reply all concerns me. If you reply all, then you are looking for an email with address column I in the To, CC, or BCC fields. e.g. To: ALL EMPLOYEES. The email in Column I is there so: Dear Ken, I put one over on the boss. I called in sick leave yesterday but I got in my 18 holes of golf by 2 PM at Oak Tree. Paid to golf, I love this job!

One could be serious. e.g. To: ALL COMPANIES. Dear Ken, please send me another 100 pallets of Wiley Coyote bricks. The bricks sold by Road Runner company are too pricey!

If your goal is just a single To: field's email matching a single email in Column I, that might take some time but might be doable. I would have to research that. Folders and subfolders in Outlook are not the same as Win10's.

AlanB
07-23-2019, 01:01 AM
Hi Kenneth,

The goal is per your last paragraph - just a single To: field's email matching a single email in Column I.

My use of the phrase "reply all" was more about continuing the email thread.

Thanks
Alan

Kenneth Hobs
07-23-2019, 03:20 PM
Change the value for email and ws. You might also want to change .Send to .Display to test.


Option Explicit

Dim oOFs() As outlook.Folder


Sub SendReminder()
Dim email$, v, item, i, ws As Worksheet, r As Range, c As Range, cc As Range
'Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim OL As outlook.Application, oMI As outlook.MailItem

email = "ken@gmail.com"
Set ws = Worksheets("SendReminder")
Set r = ws.Range("I2", ws.Cells(ws.Rows.Count, "I").End(xlUp))

Set OL = CreateObject("Outlook.Application")
Erase oOFs()
RecurseOFolders GetFolderPath(email, OL)

For Each c In r
Set oMI = Nothing
Set cc = ws.Cells(c.Row, "P")
If cc > Date Or cc = "" Then GoTo NextC
For Each v In oOFs
If v.Items.Count = 0 Then GoTo NextV
For Each item In v.Items
If TypeName(item) <> "MailItem" Then GoTo NextItem
If item.SenderEmailAddress = c Then
If oMI Is Nothing Then Set oMI = item
If item.ReceivedTime > oMI.ReceivedTime Then Set oMI = item
End If
NextItem:
Next item
NextV:
Next v
NextC:
If Not oMI Is Nothing Then
With oMI.Reply
.Subject = ws.Cells(c.Row, "Q")
.Body = ws.Cells(c.Row, "S") & vbCrLf & vbCrLf & ws.Cells(c.Row, "T") & .Body
If ws.Cells(c.Row, "U") <> "" Then .Attachments.Add ws.Cells(c.Row, "U")
.Send
End With
End If
Next c
End Sub


Sub RecurseOFolders(CurrentFolder As outlook.MAPIFolder, _
Optional skipTrash As Boolean = True)
'Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim i As Long, oOSF As outlook.MAPIFolder, oOF As outlook.Folder
Dim ii As Long

For i = CurrentFolder.Folders.Count To 1 Step -1
Set oOF = CurrentFolder.Folders(i)
If IsArray(oOFs) Then
ii = UBound(oOFs) + 1
Else: ii = 0
End If
If skipTrash And oOF.Name = "Trash" Then
ii = ii - 1
Else
ReDim Preserve oOFs(ii)
Set oOFs(ii) = oOF
End If
Next i

For Each oOSF In CurrentFolder.Folders
If oOSF.Name <> "Deleted Items" Then RecurseOFolders oOSF
Next oOSF
End Sub


'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As outlook.Application) As outlook.Folder
Dim oFolder As outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer

On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
Set oFolder = oApp.Session.Folders.item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function

GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function

AlanB
07-24-2019, 02:26 AM
I am not sure what I am doing wrong but after starting the code it ran for a few minutes then an error message came up indicating that there was not enough memory to run it. I have never had an issue before so I wanted to check that I was doing everything correctly.
1. I updated your email to mine
2. On the test document I created I saved the worksheet as SendReminder to match the code
3. I went to Tools > References > Microsoft Outlook xx.0 Object Library > OK and ensured my version 16 was ticked

I am unsure what I am doing wrong?

When I debug after the error it highlights this row
If v.Items.Count = 0 Then GoTo NextV

Kenneth Hobs
07-24-2019, 07:39 AM
Sounds like you set it up right. I would change the .Send to .Display to test. Try setting it up to just test one.

I tested it in 365 and Outlook v14. v14 took a while to finish just the one test.

I did not check the case where the To: column I's email might not exist. I will look at that today.

I have attached my simple test file. Change the column I to an existing email that was received. Delete the v14 Outlook library reference and add yours. Make the email change. As it runs, you should see in VBE Immediate window the number of outlook folders - 1 that it will search.

Once it works, it might be more efficient to get all MailItem's data from each Outlook folder found and put it into a scratch sheet. A sort could then be used for each column I to find the right MailItem to Reply to.

AlanB
07-24-2019, 08:20 AM
I did a similar thing to you with my previous effort and set up a v basic test doc - only had 2 emails.

I have just tried using your attachment (ensuring I made all the changes) but had identical error (there is not enough free memory to run this program....) I am using an i5 7th gen machine with only not much open.
although the debug had it happening here - For i = CurrentFolder.Folders.Count To 1 Step -1

I didn't see this - As it runs, you should see in VBE Immediate window the number of outlook folders - 1 that it will search.

Thanks
Alan

Kenneth Hobs
07-24-2019, 08:50 AM
If no debug.print result, that tells me that there is an issue with the recurseofolders routine.

Change the email and run the test sub from a blank worksheet in my attachment's Module. It will put the folder names into column A.


Sub Test_RecurseOFolders()
Dim email$
'Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim oMF As Outlook.MAPIFolder, OL As Outlook.Application
Dim i, a

email = "ken@gmail.com"

Set OL = CreateObject("Outlook.Application")
Erase oOFs()

RecurseOFolders GetFolderPath(email, OL)
ReDim a(1 To UBound(oOFs) + 1)
For i = 1 To UBound(a)
a(i) = oOFs(i - 1)
Next i
Range("A2").Resize(UBound(a)) = WorksheetFunction.Transpose(a)
End Sub

Later today or tonight, I can post code to make sure that your parent folder is the email value's folder.

AlanB
07-25-2019, 01:42 AM
I am unable to run this code either. I get a Compile error: Sub or Function not defined against
Erase oOFs

?

Kenneth Hobs
07-25-2019, 05:10 AM
Run it from the test file's Module. It has the supporting routines and that public variable.

AlanB
07-25-2019, 06:26 AM
Apologies - Yep that has now worked with all the folder names in Column A. Just over 4000 :-( 7 years of working in events for the same company!

The purpose of the macro is to follow up with people who haven't come back to me so maybe limiting the search to just the sent items may make the process quicker if having 4k of folder to search through each time is going to slow down the process?

Kenneth Hobs
07-25-2019, 04:19 PM
If you can live with that, it will be much faster. You can try this for the RecurseOfolders line:

RecurseOFolders Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)

Or make it more simple and delete that line and for the first loop, use:

For Each v In Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)

You don't really need to recurse outlook folders since there would just be the Sent Items folder. It should work though. It is simple enough to not use RecurseOFolders(). I have not tested it so give it a shot.

AlanB
07-26-2019, 01:24 PM
It seems to vary if I can get my tests to work or not even though I am running the same code. (if it doesn't I get a memory error again)

I am unsure if I replaced the right - RecurseOfolders line: as there are a few in the code. Could you paste the entire code that I should use so i ensure I am doing it right.

It seemed to take 7 and half minutes to run one email. My first fail was when I tried to display 2.
Thanks

Kenneth Hobs
07-26-2019, 04:40 PM
Is this on an Exchange Server?

During a Run in the VBE, press ESC key to abort macro after a bit. Look at the Immediate Window. The To names are shown but not the email address. If you use SenderEmailAddress on Exchange, that is not helpful.

IF you can live with the .To names, we can go from there.

This is all you need in a Module:

Sub SendReminder()
Dim v, item, i, ws As Worksheet, r As Range, c As Range, cc As Range
'Tools > References > Microsoft Outlook xx.0 Object Library > OK
Dim OL As Outlook.Application, oMI As Outlook.MailItem, oFSentItems As Outlook.Folder

Set ws = Worksheets("SendReminder")
Set r = ws.Range("I2", ws.Cells(ws.Rows.Count, "I").End(xlUp))

Set OL = CreateObject("Outlook.Application")
Set oFSentItems = Outlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
If oFSentItems.Items.Count = 0 Then Exit Sub

For Each c In r
Set oMI = Nothing
Set cc = ws.Cells(c.Row, "P")
If cc > Date Or cc = "" Then GoTo NextC
For Each item In oFSentItems.Items
If TypeName(item) <> "MailItem" Then GoTo NextItem
Debug.Print item.To, item.Sender, item.ReceivedTime, item.Reply.SenderEmailAddress
If oMI Is Nothing Then Set oMI = item
If item.ReceivedTime > oMI.ReceivedTime Then Set oMI = item
NextItem:
Next item
NextC:
If Not oMI Is Nothing Then
With oMI.Reply
.Subject = ws.Cells(c.Row, "Q")
.Body = "Dear " & ws.Cells(c.Row, "R") & vbCrLf & vbCrLf & _
ws.Cells(c.Row, "S") & vbCrLf & vbCrLf & ws.Cells(c.Row, "T") & .Body
If ws.Cells(c.Row, "U") <> "" Then .Attachments.Add ws.Cells(c.Row, "U")
.Display
End With
End If
Next c
End Sub

AlanB
07-27-2019, 06:55 AM
Yes it is on an exchange server.

Again this code works but as soon as I enter 2 emails it ran for 30 mins or so and hadn't done anything for the second email. I think for this to be usable then it will need a new plan.
It seems to take so long to find the most recent mail when they would have been sent the last mail within the last week or 2 weeks?

AlanB
08-06-2019, 01:42 PM
Apologies - I have been away on holiday. Currently the code seems to only work on one email. As soon as two emails are added to my test document things begin to fail. Is there anything that can be done to get this useable.
Thanks