Consulting

Results 1 to 5 of 5

Thread: Alert on Initial, but Ignore Subsequent Text

  1. #1
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location

    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.

  2. #2
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location
    Quote Originally Posted by gmayor View Post
    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?

  4. #4
    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.

    Sheet.png
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Newbie
    Joined
    Mar 2020
    Posts
    3
    Location
    Quote Originally Posted by gmayor View Post
    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.

    Sheet.png
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •