View Full Version : Alert on Initial, but Ignore Subsequent Text
Hi all,
Hope everyone is doing well.
Is there a macro for outlook to alert me based on a specific body text? For example, if body LIKE 'You are now 40% bigger'; the alert should trigger. However, if I get another email with the text LIKE 'You are now 40% bigger', the alert should ignore it since it already alerted me.
Any help would be greatly appreciated. Thank you and stay well.
gmayor
03-28-2020, 04:03 AM
So basically you want a macro that only runs once? You could do what you want with a rule, then disable the rule after it has fired.
So basically you want a macro that only runs once? You could do what you want with a rule, then disable the rule after it has fired.
yes, but since I get hundreds of these emails with various percentages, it’s not possible to disable manually so need a systemic way to accomplish. Any thoughts?
gmayor
03-28-2020, 10:26 PM
OK. In that case you will need to record the values in an Excel worksheet with two columns and interrogate that worksheet to see if the value in the string exists e.g.
26232
Create a new module for the following code. Change the worksheet path and sheet name as appropriate.
Run the main macro CheckPercentage as a script from a rule to identify the messages in question as they arrive.
You can test it by selecting a message and running the test macro.
If the value exists, the macro stops. If it doesn't, it is added to the worksheet and you get a message.
If you edit the worksheet subsequently, don't leave any empty rows.
Option Explicit
Private Const strWorkbook As String = "C:\Path\Email Messages\Percentages.xlsx" 'The workbook path
Private Const strSheet As String = "Sheet1" 'the worksheet name
Private olInsp As Outlook.Inspector
Private wdDoc As Object
Private oRng As Object
Private strFind As String, strNum As String
Private Arr() As Variant
Private bFound As Boolean
Private sDate As String
Sub Test()
Dim olMsg As MailItem
'On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select
CheckPercentage olMsg
lbl_Exit:
Exit Sub
End Sub
Sub CheckPercentage(oItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 29 Mar 2020
strFind = "You are now [0-9]{1,}% bigger"
If TypeName(oItem) = "MailItem" Then
On Error Resume Next
Arr = xlFillArray(strWorkbook, strSheet)
With oItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(findText:=strFind, MatchWildcards:=True)
strNum = Replace(Mid(oRng.Text, 13), "% bigger", "")
'Debug.Print strNum
bFound = GetArrayValue(strNum)
'Debug.Print bFound
Exit Do
Loop
End With
If bFound = False Then
MsgBox "You are now " & strNum & "% bigger"
sDate = Format(Date, "yyyymmdd")
WriteToWorksheet strWorkbook, strSheet, sDate & "', '" & strNum
End If
End With
End If
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function xlFillArray(strWorkbook As String, _
strRange As String) As Variant
'Graham Mayor - https://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long
On Error Resume Next
strRange = strRange & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")
'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
With RS
.MoveLast
iRows = .recordcount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
lbl_Exit:
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
Exit Function
End Function
Private Function GetArrayValue(strItem As String) As Boolean
'Graham Mayor - https://www.gmayor.com - 24/09/2016
Dim i As Long
Dim sResult As String
Arr = xlFillArray(strWorkbook, strSheet)
For i = 0 To UBound(Arr, 2)
sResult = Arr(1, i)
If InStr(1, sResult, strItem) > 0 Then
GetArrayValue = True
Exit For
End If
Next i
lbl_Exit:
Exit Function
End Function
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
'Graham Mayor - https://www.gmayor.com - 24/09/2016
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
OK. In that case you will need to record the values in an Excel worksheet with two columns and interrogate that worksheet to see if the value in the string exists e.g.
26232
Create a new module for the following code. Change the worksheet path and sheet name as appropriate.
Run the main macro CheckPercentage as a script from a rule to identify the messages in question as they arrive.
You can test it by selecting a message and running the test macro.
If the value exists, the macro stops. If it doesn't, it is added to the worksheet and you get a message.
If you edit the worksheet subsequently, don't leave any empty rows.
Option Explicit
Private Const strWorkbook As String = "C:\Path\Email Messages\Percentages.xlsx" 'The workbook path
Private Const strSheet As String = "Sheet1" 'the worksheet name
Private olInsp As Outlook.Inspector
Private wdDoc As Object
Private oRng As Object
Private strFind As String, strNum As String
Private Arr() As Variant
Private bFound As Boolean
Private sDate As String
Sub Test()
Dim olMsg As MailItem
'On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select
CheckPercentage olMsg
lbl_Exit:
Exit Sub
End Sub
Sub CheckPercentage(oItem As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 29 Mar 2020
strFind = "You are now [0-9]{1,}% bigger"
If TypeName(oItem) = "MailItem" Then
On Error Resume Next
Arr = xlFillArray(strWorkbook, strSheet)
With oItem
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(findText:=strFind, MatchWildcards:=True)
strNum = Replace(Mid(oRng.Text, 13), "% bigger", "")
'Debug.Print strNum
bFound = GetArrayValue(strNum)
'Debug.Print bFound
Exit Do
Loop
End With
If bFound = False Then
MsgBox "You are now " & strNum & "% bigger"
sDate = Format(Date, "yyyymmdd")
WriteToWorksheet strWorkbook, strSheet, sDate & "', '" & strNum
End If
End With
End If
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function xlFillArray(strWorkbook As String, _
strRange As String) As Variant
'Graham Mayor - https://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long
On Error Resume Next
strRange = strRange & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")
'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
With RS
.MoveLast
iRows = .recordcount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
lbl_Exit:
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
Exit Function
End Function
Private Function GetArrayValue(strItem As String) As Boolean
'Graham Mayor - https://www.gmayor.com - 24/09/2016
Dim i As Long
Dim sResult As String
Arr = xlFillArray(strWorkbook, strSheet)
For i = 0 To UBound(Arr, 2)
sResult = Arr(1, i)
If InStr(1, sResult, strItem) > 0 Then
GetArrayValue = True
Exit For
End If
Next i
lbl_Exit:
Exit Function
End Function
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
'Graham Mayor - https://www.gmayor.com - 24/09/2016
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Thank you so very much. I will review now and hopefully, i can get it to work on my end. Thanks again.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.