none
How to search for card numbers in outlook RRS feed

  • Question

  • I'm looking to write a simple macro that will search an email on sending for card numbers and account numbers (to prevent people sending sensitive information). I want it to search for number patterns like "#### #### #### ####" and "###### / ####" for example. Then prompt to check if you are sure you want to send.

    I have no experience in writing macros in VBA and have spent many hours trying to find an answer on the net, but I can't quite get it to work. I managed to get a text search to work, but not number patterns.

    This macro would preferably search the entire email, including previous messages in the chain.

    Any help would be appreciated.

    Ben

    Monday, October 1, 2012 8:52 PM

Answers

  • Insert the following code in the ThisOutlookSession module

    Private Sub Application_ItemSend _
            (ByVal Item As Object, Cancel As Boolean)
    Dim strMsg As String
    Dim i As Long
    Dim strtext As String
    If AutomateReplyWithSearchString = True Then
        Cancel = True
        strMsg = "This message contains card or account numbers. Please remove before sending!"
        MsgBox strMsg, _
               vbExclamation + vbSystemModal, "Content Warning"
    End If
    Item.Display
    Set Item = Nothing
    End Sub

    and in an ordinary module, insert the following function code

    Function AutomateReplyWithSearchString() As Boolean
    Dim olInspector As Outlook.Inspector
    Dim olObject As Object
    Dim olItem As Outlook.MailItem
    Dim wdDoc As Object
    Dim strItem As String
    Dim bFound As Boolean
    Dim strMsg As String
    Dim oRng As Range
    Dim i As Long
    Dim vFindText As Variant

    vFindText = Array("[0-9]{4} [0-9]{4} [0-9]{4} [0-9]{4}", "[0-9]{5} / [0-9]{4}")

    Set olInspector = Application.ActiveInspector
    Set olObject = olInspector.CurrentItem

    If olObject.MessageClass = "IPM.Note" And _
       olInspector.IsWordMail = True Then
        Set olItem = olInspector.CurrentItem
        Set wdDoc = olInspector.WordEditor
        For i = 0 To UBound(vFindText)
            Set oRng = wdDoc.Range
            With oRng.Find
                Do While .Execute(FindText:=vFindText(i), MatchWildcards:=True) = True
                    AutomateReplyWithSearchString = True
                    Exit For
                Loop
            End With
        Next i
    End If
    Set olInspector = Nothing
    Set olObject = Nothing
    Set wdDoc = Nothing
    Set olItem = Nothing
    End Function


    The macro calls the function which checks the complete message for the numeric strings that you have identified from the array. You can add other wildcard strings (http://www.gmayor.com/replace_using_wildcards.htm ) to the array each surrounded by quotes and separated by commas.

    If one of the strings is found, the message is not sent and the user warned with the message defined at strMsg.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by bpearce888 Tuesday, October 2, 2012 9:10 PM
    Tuesday, October 2, 2012 7:02 AM

All replies

  • Insert the following code in the ThisOutlookSession module

    Private Sub Application_ItemSend _
            (ByVal Item As Object, Cancel As Boolean)
    Dim strMsg As String
    Dim i As Long
    Dim strtext As String
    If AutomateReplyWithSearchString = True Then
        Cancel = True
        strMsg = "This message contains card or account numbers. Please remove before sending!"
        MsgBox strMsg, _
               vbExclamation + vbSystemModal, "Content Warning"
    End If
    Item.Display
    Set Item = Nothing
    End Sub

    and in an ordinary module, insert the following function code

    Function AutomateReplyWithSearchString() As Boolean
    Dim olInspector As Outlook.Inspector
    Dim olObject As Object
    Dim olItem As Outlook.MailItem
    Dim wdDoc As Object
    Dim strItem As String
    Dim bFound As Boolean
    Dim strMsg As String
    Dim oRng As Range
    Dim i As Long
    Dim vFindText As Variant

    vFindText = Array("[0-9]{4} [0-9]{4} [0-9]{4} [0-9]{4}", "[0-9]{5} / [0-9]{4}")

    Set olInspector = Application.ActiveInspector
    Set olObject = olInspector.CurrentItem

    If olObject.MessageClass = "IPM.Note" And _
       olInspector.IsWordMail = True Then
        Set olItem = olInspector.CurrentItem
        Set wdDoc = olInspector.WordEditor
        For i = 0 To UBound(vFindText)
            Set oRng = wdDoc.Range
            With oRng.Find
                Do While .Execute(FindText:=vFindText(i), MatchWildcards:=True) = True
                    AutomateReplyWithSearchString = True
                    Exit For
                Loop
            End With
        Next i
    End If
    Set olInspector = Nothing
    Set olObject = Nothing
    Set wdDoc = Nothing
    Set olItem = Nothing
    End Function


    The macro calls the function which checks the complete message for the numeric strings that you have identified from the array. You can add other wildcard strings (http://www.gmayor.com/replace_using_wildcards.htm ) to the array each surrounded by quotes and separated by commas.

    If one of the strings is found, the message is not sent and the user warned with the message defined at strMsg.


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by bpearce888 Tuesday, October 2, 2012 9:10 PM
    Tuesday, October 2, 2012 7:02 AM
  • Thanks, Graham, this is very useful. Appreciate your help

    Tuesday, October 2, 2012 9:10 PM
  • Hi Graham,

    This is working really well in outlook 2010, so thank you! However I have tried it on another computer which only has outlook 2003 but it isn't working. I notice that 2003 has visual basic 6.5 but 2010 has version 7.0. Do you think this is what is causing me issues? Unfortunately I'm not able to update the software on this computer!

    Do you have any quick fixes for this?

    Thanks again for your help

    Monday, October 8, 2012 10:53 PM