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
objFwd.Send
Else
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)
Else
intLocLabel = _
Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function
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
objFwd.Send
Else
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)
Else
intLocLabel = _
Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function