OUTLOOK-CannedReply.vba

CannedReply.vba

Public Sub EXTREQ()
Dim oMail, oMailS As Outlook.MailItem
Dim Recip, first, last, rResult, dResult As String
Dim oFSO, oFS, bstring, cstring, sstring, rVar, lVar, fn, ln, rsVar, lsVar, test
Dim objAttach As Outlook.Attachment
Dim SentFrom As Outlook.NameSpace
Set SentFrom = Application.GetNamespace("MAPI")
Set objFolder = Application.ActiveExplorer.CurrentFolder.Items
Set colItems = objFolder

If Application.ActiveExplorer.Selection.Count Then
    If TypeOf Application.ActiveExplorer.Selection(1) Is Outlook.MailItem Then
        Set oMail = Application.ActiveExplorer.Selection(1).Reply
        Set oMailS = Application.ActiveExplorer.Selection(1)
        BodyString = oMailS.Body
                'Keywords to search for to verify this is the type of email message you are looking for
                If Not InStr(LCase(oMailS.Body), "keyword1") Then
                  If InStr(LCase(oMailS.Body), "keyword2") Then
                    oMail.BodyFormat = olFormatHTML
                    oMail.Recipients.ResolveAll
                    oMail.SentOnBehalfOfName = "your email account name"
                    '-------- Begin Recipient / Greeting parsing
                    
                    BodyString = oMailS.Body

                    If InStr(LCase(oMailS.SenderEmailAddress), "[email protected]") Then  ' Is it from ITSD?
                      If InStr(UCase(oMailS.Subject), "keyword3") Then       'Does it contain "keyword3"?
                        If InStr(UCase(oMailS.Body), "keyword4") Then  'Check body for the words "keyword4:"
                            BodyText = oMailS.Body                           ' Pass BodyText the full contents of the message body
                            msgLines = Split(BodyText, vbCrLf)                   ' Break apart body into separate lines
        
                          For Each msgLine In msgLines                      'Scan each line and replace certain words
                          If InStr(LCase(msgLine), "keyword 6 ") Then
                            Description = Replace(UCase(msgLine), "replace1", "")
                                rVar = InStr(1, msgLine, "grab this text") + 21
                                Emp = Mid(msgLine, 22)
                                Dim EmpNameArray() As String
                            Emp = Replace(Emp, " ", ".")  'replace space with .
                            EmpNameArray = Split(Emp, ".") ' split the . (used to split a first.last name)
                                EmpNameArray(0) = StrConv(EmpNameArray(0), vbProperCase)
                                EmpNameArray(1) = StrConv(EmpNameArray(1), vbProperCase)
                                Emp = EmpNameArray(0) + "." + EmpNameArray(1)
                            End If
        
                          If InStr(LCase(msgLine), "keyword 6") Then
                                Dim ReqNameArray() As String
                                Req = Replace(msgLine, " ", ".")
                                ReqNameArray = Split(Req, ".")
                                ReqNameArray(0) = StrConv(ReqNameArray(0), vbProperCase)
                                ReqNameArray(1) = StrConv(ReqNameArray(1), vbProperCase)
                                Req = ReqNameArray(0) + "." + ReqNameArray(1)
                                                
                                    ' ---------broken down to last, first -------------
                    
                                first = ReqNameArray(0)
                                last = ReqNameArray(1)
                                oMail.To = Req
                            End If
                    Next
                End If
            End If
        End If
        
            
oMail.HTMLBody = "<font face=calibri size=2 color=darkblue>Hello " & ReqNameArray(0) & _
                  "<br><br>We have received your order for " & EmpNameArray(0) & ". We will contact you." & _
oMail.HTMLBody
oMail.Display
        
        Set BodyString = Nothing
        Set SubjString = Nothing
        Set rVar = Nothing
        Set olApp = Nothing
        End If
    End If
End If
End If
End Sub