Script that automatically replies to email based on rules.

Not open for further replies.


Outlook version
Outlook 2010 32 bit
Email Account
I am very new to VBA (2 days) and would to like automate responses that goes to a specific outlook mail box based on rules set in that box. The response is a script I created. Currently the script can reply to an email if that mail is selected. However, I would like it to be triggered whenever a mail comes in.

I found some text online which does that but i'm unable to format it to my use.

This is what I have:

Sub FwdSelToAddr()

Dim objOL As Outlook.Application

Dim objItem As Object

Dim objFwd As Outlook.MailItem

Dim strAddr As String

On Error Resume Next

Set objOL = Application

Set objItem = objOL.ActiveExplorer.Selection(1)

If Not objItem Is Nothing Then

empID = ParseTextLinePair(objItem.Body, "Employee ID:")

leavCat = ParseTextLinePair(objItem.Body, "Leave Category:")

leavFre = ParseTextLinePair(objItem.Body, "Leave Frequency:")

leavRe = ParseTextLinePair(objItem.Body, "Leave Reason:")

casSta = ParseTextLinePair(objItem.Body, "Case Status:")

staDat = ParseTextLinePair(objItem.Body, "Start Date:")

leavHr = ParseTextLinePair(objItem.Body, "Leave Hours:")

appxLhr = ParseTextLinePair(objItem.Body, "Approximate Daily Leave Hours:")

deTal = ParseTextLinePair(objItem.Body, "Details:")

enDat = ParseTextLinePair(objItem.Body, "End Date:")

If empID <> "" Then

Set objFwd = objItem.Reply

objFwd.Subject = "Leave Case Submitted"

objFwd.HTMLBody = "Employee ID: " & empID & "<bt><br>" & "Leave Category: " & leavCat & "<bt><br>" & "Leave Reason: " & leavRe & "<bt><br>" _

& "Leave Frequency: " & leavFre & "<bt><br>" & "Case Status: " & casSta & "<bt><br>" & "Start Date: " & staDat & "<bt><br>" & "End Date: " & enDat & "<bt><br>" _

& "Leave Hours: " & leavHr & "<bt><br>" & "Approximate Daily Leave Hours: " & appxLhr & "<bt><br>" & "Details: " & deTal



MsgBox "Could not extract string from message."

End If

End If

Set objOL = Nothing

Set objItem = Nothing

Set objFwd = Nothing

End Sub

Function ParseTextLinePair _

(strSource As String, strLabel As String)

Dim intLocLabel As Integer

Dim intLocCRLF As Integer

Dim intLenLabel As Integer

Dim strText As String

intLocLabel = InStr(strSource, strLabel)

intLenLabel = Len(strLabel)

If intLocLabel > 0 Then

intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)

If intLocCRLF > 0 Then

intLocLabel = intLocLabel + intLenLabel

strText = Mid(strSource, _

intLocLabel, _

intLocCRLF - intLocLabel)


intLocLabel = _

Mid(strSource, intLocLabel + intLenLabel)

End If

End If

ParseTextLinePair = Trim(strText)

End Function
Not open for further replies.