2
\$\begingroup\$

I am using this syntax to query a table and return a record set and if the number of times total the customer has been emailed is less than 5, send an email with a canned response. If the number of times emailed is >= 6 then the draft is saved with bold text so the user knows to review this (case by case basis of what should be sent.)

I'm sure this code can be optimized, but I lack the know-how...

Sub GetAccountsNeedingAttention()
Dim rs As DAO.Recordset
Dim primaryContact As String
Dim searchEmail As String
Dim startDate As String
Dim emailsSent As Integer
Dim emailOpener As String
Dim emailBody As String
Dim fullEmailBody As String
Dim emailSig As String: emailSig = "html syntax to put in the text for email sig"


Set rs = CurrentDb.OpenRecordset("Select *, CDate(Mid(NR, InStrRev(NR, ' ')+1) & '/01/' & [Year] As Date From prodInfo Having CDate(Mid(NR, ' ')+1) & '/01/' & [Year] <= DateValue(CStr(Now()))")

With rs
    .MoveLast
    .MoveFirst
    Do While Not .EOF
        primaryContact = rs![Name]
        emailOpener = "<p>Hello,</p>"
        startDate = rs![Date]
        If InStr(1, rs![contactEmail], InStr(rs![contactEmail], ", ") - 1) Then
            'we have a comma
            searchEmail = Left(rs![contactEmail], InStr(rs![contactEmail], ", ") - 1)
        Else
            'we do not have a comma
            searchEmail = rs![contactEmail]
        End If
        If primaryContact <> "Both" Then
            If InStr(primaryContact, ",") > 0 Then
                primaryContact = Left(primaryContact, InStr(1, primaryContact, " ") - 1)
            Else
                primaryContact = primaryContact
            End If
            emailsSent = GetNumberOfTimesEmailed(searchEmail, startDate)
            If emailsSent >= 6 Then
                fullEmailBody = "<p><strong>PLEASE REVIEW</strong></p>"
            Else
                emailBody = DLookup("Response", "_Responses", "ID = " & emailsSent)
                fullEmailBody = emailOpener & "<p>" & emailBody & "</p> & emailSig"
            End If
            ComposeResponse searchEmail, fullEmailBody
        End If
        .MoveNext
    Loop
End With
rs.Close
End Sub

Function GetNumberOfTimesEmailed(searchEmail As String, startDate As String) As Integer
Dim currDateTime As Date: currDateTime = Now()
Dim OLApp As Outlook.Application
Dim olNS As NameSpace
Dim Fldr As MAPIFolder
Dim olReply As Outlook.MailItem
Dim msg As Object
Set OLApp = New Outlook.Application
Set olNS = OLApp.GetNamespace("MAPI")
Set Fldr = olNS.GetDefaultFolder(olFolderSentMail)
startDate = startDate & " 07:00:00 AM"
GetNumberOfTimesEmailed = 1
For Each msg In Fldr.Items
    If TypeName(msg) = "MailItem" Then
        For Each recip In msg.Recipients
            If recip.Address = searchEmail Then
                If msg.SentOn >= startDate And msg.SentOn <= currDateTime Then
                    GetNumberOfTimesEmailed = GetNumberOfTimesEmailed + 1
                End If
            End If
        Next recip
    End If
Next msg
End Function

Function ComposeResponse(searchEmail As String, fullEmailBody As String)
Dim currDateTime As Date: currDateTime = Now()
Dim tenDayPrior As Date: tenDayPrior = DateValue(CStr(Now())) - 10 & " 07:00:00 AM"
Dim OLApp As Outlook.Application
Dim olNS As NameSpace
Dim Fldr As MAPIFolder
Dim olReply As Outlook.MailItem
Dim msg As Object
Set OLApp = New Outlook.Application
Set olNS = OLApp.GetNamespace("MAPI")
Set Fldr = olNS.GetDefaultFolder(olFolderSentMail)
For Each msg In Fldr.Items
    If TypeName(msg) = "MailItem" Then
        For Each recip In msg.Recipients
            If recip.Address = searchEmail Then
                If msg.SentOn >= tenDayPrior And msg.SentOn <= currDateTime Then
                    Set olReply = msg.ReplyAll
                    With olReply
                        .BodyFormat = olFormatHTML
                        .HTMLBody = Replace(.HTMLBody, "&nbsp;", fullEmailBody, Count:=1)
                        .Save
                        .Close olSave
                    End With
                End If
            End If
        Next recip
    End If
Next msg
End Function
\$\endgroup\$
  • 1
    \$\begingroup\$ GetAccountsNeedingAttention() did not paste properly. Please fix the code so that it will compile. \$\endgroup\$ – TinMan Jul 11 at 12:49
  • \$\begingroup\$ @TinMan - my mistake. Try it now. Compile fine for me now :) \$\endgroup\$ – user2676140 Jul 11 at 14:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.