VBA Script - Print Date between first email in Category X and last email in Category Y

[AdamFuller]

Part of my workflow revolves around hitting certain deadlines. I'd love to have a dialogue pop up when my rules categorize the last piece of the process showing: the number of days between the first email received in "09) Purchase Agreement Received (F2)" and the most recent email received in "00) Final CD (F11)". I already have a rule in place to run the following script to Categorize the email and am not sure how to proceed in VBA to get the desired result. Thank in advance for any light you guys can help shed on this!

Sub FlagFCD(olItem As MailItem)
Dim olAtt As Attachment
If olItem.Attachments.Count > 0 Then
For Each olAtt In olItem.Attachments
If LCase(olAtt.FileName) Like "*.pdf" Then 'If attachment type is PDF
olItem.Categories = "00) Final CD (F11)" 'Categorize Emails with PDF Attachments as 00) Final CD (F11)
olItem.Close olSave
Exit For
End If
Next olAtt
End If
lbl_Exit:
Exit Sub
End Sub

 

[Diane Poremsky]

If that is the last - you'd need to get the subject (assuming the subject is the same) - or use purchase order # or some other unique value so you can find the first message, using the category and the unique keyword to find it. Get the sent date and calculate.

 

[AdamFuller]

Well, it took some grinding, but this is what I came up with. It relies on a manual Macro button. The only way to search this was once the categorized email manually transferred the correct clients folder. I'm sure the code is a mess, but I couldn't be happier with the results. Hope it helps some others out!

Sub LoanUpdate()

Dim Inbox As Outlook.MAPIFolder
Set Inbox = Application.ActiveExplorer.CurrentFolder

Dim AllCurrentEmails As Outlook.Items
Set AllCurrentEmails = Inbox.Items
AllCurrentEmails.Sort "[ReceivedTime]", False

On Error Resume Next

Set AllCurrentEmails = Inbox.Items.Restrict("[Categories] = '09) Purchase Agreement Received (F2)'")

Dim EmailOne As Object
Set EmailOne = AllCurrentEmails.GetFirst

Dim Start As String
Start = Format(EmailOne.ReceivedTime, "mm/dd/yyyy")

Set AllCurrentEmails = Inbox.Items.Restrict("[Categories] = '00) Final CD (F11)'")

Dim EmailTwo As Object
Set EmailTwo = AllCurrentEmails.GetLast

Dim Finish As String
Finish = Format(EmailTwo.ReceivedTime, "mm/dd/yyyy")

Dim TTC As String
TTC = (DateDiff("d", Start, Finish) + 1)

Dim TimeElapsed As String
TimeElapsed = (DateDiff("d", Start, Date) + 1)

If Start = "" And Finish = "" Then MsgBox "No Loan started yet", , "Loan Update"
If Start = "" And Finish <> "" Then MsgBox "No Purchase Agreement Flagged!", , "Loan Update"
If Start <> "" And Finish = "" Then MsgBox "PA Received: " & Start & " (" & TimeElapsed & " days ago)", , "Loan Update"
If Start <> "" And Finish <> "" Then MsgBox "PA Received: " & Start & " | " & "CTC Received: " & Finish & vbCrLf & vbCrLf & "Loan Closed in " & TTC & " days", , "Loan Update"

End Sub

Example outputs;

 

[Diane Poremsky]

I'm sure the code is a mess,

It doesn't look like a mess.

Typically, DIM statements are all put at the top but it's not unusual to add some right before they are used. That's as nit-picky as it can get.

Good job. ??

(hmmm no clapping smiles in the forum... will need to use the ones from windows)
(ETA: and windows emojis don't work in the forum )
(ETA2: had to upgrade the database to support unicode.... now emojis work. ? for me too. )