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.1234") 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