Solved: Masking credit card numbers in a mixed field

[Andrew Hulting]

I am working on a project to look in a couple of fields for 16 consecutive numbers, I am masking credit card numbers I can get this to work with the following code, for fields where it begins or ends with 16 consecutive numbers. The problem I am having is a field with alpha on either side, or a numeric string longer then 16 digits. I guess what I need is something to look for 16 digits in a field, and replace place 7-12 with *’s. VBA doesn’t like wild cards in any of the string functions. Any help would be great.

Andrew

Public Function fnMaskCCNumbers(Item As String, fld As String)

Dim str As String
Dim rst As Recordset
Dim str1 As String
Dim str2 As String
Dim strlen As Integer

Set rst = CurrentDb.OpenRecordset(Item, dbOpenDynaset)


rst.MoveFirst

Do Until rst.EOF = True

If rst(fld) Like "*################" Or rst(fld) Like "################*" Or rst(fld) Like "*################" Then

str = rst(fld)
    'starts with CC rst(fld) Like "################*"
    If IsNumeric(Left(str, 16)) = True Then
    str1 = Left(str, 6) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Mid(str, 12, 37)
    Debug.Print str1
    rst.Edit
    rst(fld) = str1
    rst.Update
    
    'ends with CC rst(fld) Like "*################"
    ElseIf IsNumeric(Right(str, 16)) = True Then
    strlen = Len(str)
    str2 = Left(str, (strlen - 10)) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Right(str, 4)
    Debug.Print str2
    rst.Edit
    rst(fld) = str2
    rst.Update


End If
End If
rst.MoveNext
Loop

rst.Close



End Function

[gershwyn]

I'm assuming that the number is surrounded by spaces on either side. This function loops through, checking the characters between each pair of spaces in the string.

Public Function MaskDigits(StringValue As String)
  startPos = 0
  Do While startPos < Len(StringValue)
    endPos = InStr(startPos + 1, StringValue, " ")
    If endPos = 0 Then endPos = Len(StringValue) + 1
    If (endPos - startPos - 1) = 16 Then
      If IsNumeric(Mid(StringValue, startPos + 1, 16)) Then
        StringValue = Left(StringValue, startPos + 6) & String(6, Chr(42)) & Right(StringValue, Len(StringValue) - startPos - 12)
        Exit Do
      End If
    End If
    startPos = endPos
  Loop
  MaskDigits = StringValue
End Function

This has the potential to give a false positive, on the off chance your data contains 16 consecutive characters that can be interpreted as a number, but are not entirely made of digits (e.g., "123,456,789.12 34") If that is a real possibility, you could add another check to make sure you're dealing with 16 straight digits.

[jimatqsi]

Andrew,
Here is a recursive routine to do what you want. I've included a little test routine that I used to check it out.

Public Function Find16Digits(ByVal strField As String, intLevel) As String
' Incoming parameter strField is a string of unknown length
' and how deep we are nested in Find16Digits calls

   On Error GoTo Find16Digits_Error

    Dim intRetry As Integer
    
    Find16Digits = ""
    
    Do While intRetry >= 0
        If Len(strField) < 16 - intLevel Then ' keep trying until there is not enough left to try
            Find16Digits = ""
            Exit Function ' cannot possibly work without 16 chars
        End If
        
        If IsNumeric(Left(strField, 1)) Then ' check 1st char to see if it is a number
            If intLevel >= 15 Then
                Find16Digits = strField   ' the field we started with is okay
            Else
                Find16Digits = Find16Digits(Mid(strField, 2), intLevel + 1) ' recursive call for all chars to the right, bumping up intLevel
                If Find16Digits <> "" Then Find16Digits = strField
            End If
        Else  ' as soon as we find a non-numeric, return with bad news
            Find16Digits = ""
        End If
        
        If Len(Find16Digits) < (16 - intLevel) Then ' if we failed
            If intLevel = 0 Then   ' If we're at the lowest level, STRIP OFF 1 CHAR AND TRY AGAIN
                intRetry = intRetry + 1
                strField = Mid(strField, 2) ' eliminate the first character of the field, try again
            Else
                ' If we're not at the lowest level, go back and try again
                Exit Function
            End If
        Else
            Find16Digits = Left(Find16Digits, 16) ' cut off any extra chars
            intRetry = -1
        End If
        
    Loop
   
   On Error GoTo 0
   Exit Function

Find16Digits_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Find16Digits of VBA Document Form_ComponentBuilder_frm"
    Resume Next
    
End Function

Public Sub GetCCNumber()
    
    Dim strTestCC As String
    Dim strResult As String
    
   On Error GoTo GetCCNumber_Error

    strTestCC = "1234567890123456"
    strResult = Find16Digits(strTestCC, 0)
    MsgBox "The CC Number in " & strTestCC & " is " & strResult
    
    strTestCC = "CR154A1234567890123456"
    strResult = Find16Digits(strTestCC, 0)
    MsgBox "The CC Number in " & strTestCC & " is " & strResult
        
    strTestCC = "1234569923456aa44a123456789012345689aa"
    strResult = Find16Digits(strTestCC, 0)
    MsgBox "The CC Number in " & strTestCC & " is " & strResult
    
   On Error GoTo 0
   Exit Sub

GetCCNumber_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetCCNumber of VBA Document Form_ComponentBuilder_frm"
    Resume Next
    
End Sub

My routine returns the 16 character string. You could present 16 asterisks and the right-most 4 characters in your UI.

Jim

[Andrew Hulting]

Thanks for the reply's I did get it to work with a REGex Function, It was very frustrating. It works realativly fast, as I was able to mask the numbers in a few history talbes, with ~300K records each, in only a few mins. Here is what I used. Not to bad for 50 some lines of code, I just passed in my recordset, and the targeted field.

Public Function fnMaskCCNumbers(Item As String, fld As String)

Dim str As String
Dim rst As Recordset
Dim str2 As String
Dim str3 As String
Dim str4 As String

Set rst = CurrentDb.OpenRecordset(Item, dbOpenDynaset)

rst.MoveFirst

Do Until rst.EOF = True
'If rst(fld) Like "*################*" Or rst(fld) Like "################*" Or rst(fld) Like "*################" And rst(fld)not Like "*#################*" Then

If rst(fld) Like "*################*" And Not rst(fld) Like "*#################*" Then

str = rst(fld)

str2 = RE16(str)

'Debug.Print str2
str3 = Left(str2, 6) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Chr(42) & Right(str2, 4)
'Debug.Print str3
str4 = Replace(rst(fld), str2, str3)
'Debug.Print str4

    rst.Edit
    rst(fld) = str4
    rst.Update

End If

rst.MoveNext
Loop

rst.Close

End Function

Public Function RE16(strData As String) As String
    Dim RE As Object, REMatches As Object

    Set RE = CreateObject("vbscript.regexp")
    With RE
        .MultiLine = False
        .Global = False
        .IgnoreCase = True
        .Pattern = "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]"
    End With
    
    Set REMatches = RE.Execute(strData)
    RE16 = REMatches(0)

End Function