Find all upper, lower and mixed case permutations of a string

Question

Background:

In collecting data we wanted associate each item of data with individuals who contributed it but without actually identifying them individually. To do this we used MD5(Environ("UserName")) and stored this 'ID' on each of the individual contributors PCs. The unforeseen problem that thwarted our plan was that under some conditions windows changes the case of Environ("UserName"), probably depending on how the user logs in. This incorrectly flagged that the user was unregistered and prevented them from contributing.

Having learned from our mistake we now use lowercase version of the UserName to anonymize respondents: MD5(lCase(Environ("UserName"))).

But we still need to re-validate each user who was flagged as un-registered and rewrite their MD5 IDs. Part of this strategy means checking the current MD5 is in-fact for this user, i.e. systematically change case until a match is found then rewrite the MD5 based on lCase(UserName); this is the crux of the question.

Problem:

I have a need to find all possible combinations of a string between lCase(string) and uCase(string) - without rearranging characters. For example, given the input string of: abc I would expect the code to return: abc, abC, aBc, aBC, Abc, AbC, ABc, & ABC.

The following code does that, but perhaps not as efficiently as it could. I'm working on the following assumptions:

• the input characters will be limited to:
  • upper and lower case characters, A-z
  • regular numbers, 0-9
  • regular space character, " "
• the input strings are relatively short, 1 to 20 characters
• Users typically log into Windows using:
  • FirstMiddleLast,
  • FLast
  • FMLast
  • FirstL, etc.
  • (but other combinations and cases are also possible & likely)

The code basically works by converting an input string to lower case and then into a byte array. This provides each character in the input string with an easy-to-access index.

The next step is to create a binary number with 1 digit for each character in the input string. Then starting from 000 (i.e. for abc) use a loop to keep adding 1 (to a decimal number and converting) to binary until there are no zeros left in the binary number. For each iteration of the loop the "1's" in the binary number represent possible uppercase characters for the original input string.

On my test PC it takes approximately 60 seconds to process a 16 character input string. I'm sure there is room for improvement.

In addition to speed I would like to better structure the code so that it is easier to test and so that when I look at it later I'm not left cursing myself.

The code is as follows:

Option Explicit
Const BASE_2 As Long = 2
Const CHR_1 As String = "1"
Const CHR_0 As String = "0"
Public Sub CasePermutation(ByVal stringPassed As String)
 Dim stringIn As String
 stringIn = LCase$(stringPassed)
 Const SKIP_BLANKS As Long = 2
 Dim stringInArray() As Byte
 stringInArray = stringIn 'Assign Unicode string to bytes.'
 Dim caseToggleArray() As Byte
 Dim exponent As Long
 exponent = Len(stringIn)
 Dim maxDecimal As Long
 maxDecimal = BASE_2 ^ exponent
 Dim decimalNumber As Long
 For decimalNumber = 0 To maxDecimal - 1
 caseToggleArray = DecToBin(decimalNumber, exponent)
 Dim positionInString As Long
 For positionInString = LBound(stringInArray) To UBound(stringInArray) Step SKIP_BLANKS
 Dim tempString As String
 If Chr$(caseToggleArray(positionInString)) = CHR_1 Then
 tempString = tempString & UCase$(Chr$(stringInArray(positionInString)))
 Else
 tempString = tempString & Chr$(stringInArray(positionInString))
 End If
 Next positionInString
 Debug.Print tempString
 ' Reset for next iteration
 tempString = vbNullString
 Next decimalNumber
End Sub
Public Function DecToBin(ByVal decimalPassed As Long, ByVal digitsToCount As Long) As String
 Dim curDec As Long
 curDec = decimalPassed
 Dim strTemp As String
 Dim positionInString As Long
 positionInString = digitsToCount
 Do While positionInString >= 0
 If curDec >= (BASE_2 ^ positionInString) Then
 strTemp = strTemp & CHR_1
 curDec = curDec - (BASE_2 ^ positionInString)
 Else
 If positionInString <> digitsToCount Then
 strTemp = strTemp & CHR_0
 End If
 End If
 positionInString = positionInString - 1
 Loop
 DecToBin = strTemp
End Function
Public Sub test()
 Dim myNow As Date
 myNow = now()
 CasePermutation "a 1"
 Debug.Print now & " " & myNow ' rough but ok for testing with 16 chr input strings
End Sub

Answer 1

The main reason for the slowdown is the repeated "Debug.Print" command. Store your results in an array instead, and "print" it to a worksheet. Just by making that change, the time elapsed was reduced to 1.2 seconds on my computer.

There are a few other slowdowns (like using the "Chr$()" function twice every time through the inner loop) but nothing major.

My reworked version processed a 16-character string + printed the results in 0.6 seconds on my computer, approximately twice as fast as the slightly reworked original code. I find it somewhat easier to read (mostly due to avoiding the Byte arrays) but that may just be personal preference. The logic is similar in both.

EDIT: Slightly modified to avoid use of Application.Transpose, which caused errors with>16 characters in string.

Sub casePermutation(ByVal str As String, destWS As Worksheet)
 'Loop through characters in string and record whether they are "flippable"
 '(ie whether they are a letter from a-z)
 ReDim flippable(1 To Len(str), 1 To 2) As Variant
 str = LCase(str)
 Dim numLetters As Long
 Dim i As Long
 For i = 1 To Len(str)
 flippable(i, 1) = Mid(str, i, 1)
 Dim aVal As Long
 aVal = Asc(flippable(i, 1))
 If aVal >= 97 And aVal <= 122 Then
 flippable(i, 2) = True
 numLetters = numLetters + 1
 Else
 flippable(i, 2) = False
 End If
 Next
 'Alert user if character limit has been exceeded
 If numLetters > 20 Then
 MsgBox "Error: Function only supports up to 20 ""flippable"" letters"
 Stop
 Exit Sub
 End If
 'Fill array of permutations
 ReDim resultsArr(1 To 2 ^ numLetters, 1 To 1) As String
 Dim toRepeat As Long
 toRepeat = 1
 For i = 1 To Len(str)
 Dim uBool As Boolean
 Dim repeatCounter As Long
 Dim j As Long
 uBool = False
 repeatCounter = 0
 For j = 1 To UBound(resultsArr, 1)
 If flippable(i, 2) = True Then
 If repeatCounter >= toRepeat Then
 uBool = Not uBool
 repeatCounter = 0
 End If
 If uBool = False Then
 resultsArr(j, 1) = resultsArr(j, 1) & flippable(i, 1)
 Else
 resultsArr(j, 1) = resultsArr(j, 1) & UCase(flippable(i, 1))
 End If
 repeatCounter = repeatCounter + 1
 Else
 resultsArr(j, 1) = resultsArr(j, 1) & flippable(i, 1)
 End If
 Next
 If flippable(i, 2) = True Then
 toRepeat = toRepeat * 2
 End If
 Next
 'Paste results to destination sheet
 With destWS
 .Range(.Cells(1, 1), .Cells(UBound(resultsArr), 1)) = resultsArr
 End With
End Sub

• SlowLearner: Thanks for that. I'll have a look and get back to you 😎
• SlowLearner: Nice. There is 1 big difference in the logic - your code is processing the permutations concurrently whereas mine is processing the permutations sequentially. This is something that I never anticipated and it is really cool to see how other people approach problems differently; and educational too. Now I see the need to be more specific with stating requirements (and I guess seeking clarification).
• SlowLearner: I did notice your code generates Error 13 for strings larger than 16 characters: casePermutation "abcdefghijklmnop", activeworkbook.Sheets(1) on this line .Range(.Cells(1, 1), .Cells(UBound(resultsArr), 1)) = Application.Transpose(resultsArr). I didn't test the impact of non-flippable characters.
• SlowLearner: I'll update my question to provide some more clarity as to why I am looking to generate the permutations sequentially - basically it is so I can exit the code if I find a match with text in another location. E.g. If EncodePermutation = someString Then Stop. I think this forces the sequential approach as (unstated in the OP) each permutation is encoded and checked against a string.
• SlowLearner: In case you're interested, see initial guesses below. Many thanks for your help :-D

Answer 2

About this Answer

Thanks to Daniel McCracken for his thoughts on this. Daniel's answer was a great solution to the original question; hence his is the accepted answer.

This answer suits my needs better but those needs could not have been guessed from the original question. However...

After considering Daniel's proposal I realized that it might be appropriate to make some guesses before launching into what was essentially a Brute Force approach to solving my problem which is essentially to generate all possible Upper/Lower case permutations of a username and compare that to an encrypted string.

Declarations

Option Explicit
Const BASE_2 As Long = 2
Const CHR_1 As String = "1"
Const CHR_0 As String = "0"

Fake MD5

For the purpose of testing I created FakeMD5:

Function fakeMD5(ByVal inputString As String) As String
 Dim i As Long
 Dim c As String
 Dim outputString As String
 For i = 1 To Len(inputString)
 c = Mid(inputString, i, 1)
 If UCase(c) = c Then
 outputString = outputString & CHR_1
 Else
 outputString = outputString & CHR_0
 End If
 Next i
 fakeMD5 = outputString
End Function

FakeMD5 generates a string of '0' and '1' to represent upper and lower case characters in the UserName (e.g. UserName => 10001000).

For some tests Daniel's code blew mine out of the water - I was surprised because he generated string permutations concurrently so all permutations have to be generated before any can be tested. On the other hand my code generates permutations sequentially allowing testing to be done sooner for some permutations.

Initial Tweak to DecToBin

Looking at Daniels code it became obvious that his code was producing strings that would likely match real usernames before my code would. This realization prompted two slight modifications in the method DecToBin (which incidentally mandates a rename):

 If curDec >= (BASE_2 ^ positionInString) Then
 'strTemp = CHR_1 * strTemp
 strTemp = strTemp & CHR_1 ' <= Modified
 curDec = curDec - (BASE_2 ^ positionInString)
 Else
 If positionInString <> digitsToCount Then
 'strTemp = CHR_0 & strTemp
 strTemp = strTemp & CHR_0 ' <= Modified
 End If
 End If

This change meant the binary string was reversed and therefore would match a normal UserName sooner (i.e. string is built like this: 10000000, 01000000, 11000000 instead of 00000001, 00000010, 00000011).

[EDIT: Overhaul of DecToBin] (still needs a name change)

After posting this answer some more thought went into DecToBin... essentially the problem requires adding 1 to a binary number... there is no need to recalculate the binary number so it is declared as Static.

The DecToBin function was replaced with the following code to yield a better than 30% improvement in overall speed:

Public Function DecToBin(ByVal decimalPassed As Long, ByVal digitsToCount As Long) As String
 Static binaryR As String
 Static zeros As String
 Dim iPos As Long
 Dim iZero As Long
 Select Case True
 Case decimalPassed = 1, 0
 binaryR = vbNullString
 For iPos = 1 To digitsToCount
 binaryR = CHR_0 & binaryR
 Next iPos
 zeros = binaryR
 binaryR = CHR_1 & binaryR
 Case Mid$(binaryR, 1, 1) = CHR_0
 Mid$(binaryR, 1, 1) = CHR_1
 Case InStr(binaryR, CHR_0) = 0
 ' this is the end
 For iPos = 1 To digitsToCount
 binaryR = CHR_0 & binaryR
 Next iPos
 Case Else
 iPos = InStr(binaryR, CHR_0)
 Mid$(binaryR, iPos, 1) = CHR_1
 Dim iCount As Long
 For iCount = 1 To iPos
 Mid$(binaryR, iCount, 1) = CHR_0
 Next iCount
 End Select
 DecToBin = binaryR
End Function

Note: An attempt was made to eliminate the For Loop in favor of using Mid$() (code below was proposed rewrite of Dec2Bin with name change) but it turns out the Mid$() was slower than using a loop. The test strings for this were all 1 lowercase character followed but 'n' uppercase characters.

Function binaryAddOne() As String ' Expected to be fast, but was slow NOT Used (see results: 'Old Shift')
 Static zeros As String
 Static binin As String
 Dim iPos As Long
 iPos = InStr(1, binin, CHR_0)
 Select Case True
 Case binin = vbNullString
 zeros = Replace$(Space$(30), " ", CHR_0)
 binin = Replace$(zeros, CHR_0, CHR_1, 1, 1)
 Case CBool(iPos)
 Mid$(binin, iPos, 1) = CHR_1
 Mid$(binin, 1, iPos - 1) = Left$(zeros, iPos - 1)
 End Select
 binaryAddOne = binin
 'Debug.Print binin
End Function

In the image below times are in seconds (calculated (Now(End) - Now(start)) * 10 ^ 5 , "Loop" is the time for the original code (as in OP), and "Shift" is the time for adding +1 using BinaryAddOne() (instead of recalculating the entire binary number). Surprisingly "Old Shift" was the result when using Mid$() to replace zeros instead of looping through the characters to replace zeros.

enter image description here

Opportunity for CasePermutation

Nothing was changed in the method CasePermutation.

There might be some opportunity to do away with the Byte array by using the builtin Mid function to modify strings.

Initial Guesses

The Mid function is used in the newly added InitialGuesses method, code:

Private Function InitialGuesses(ByVal stringIn As String, ByVal encrypted As String) As String
 Dim tempString As String
 Dim i As Long
 tempString = LCase(stringIn)
 Dim testString As String
 ' All UpperCase
 If fakeMD5(UCase(tempString)) = encrypted Then
 InitialGuesses = UCase(tempString)
 GoTo foundResult
 End If
 ' Only letter is Cap
 For i = 1 To Len(stringIn)
 'testString = Left(tempString, i - 1) & UCase(Mid(tempString, i, 1)) & Right(tempString, Len(tempString) - i)
 testString = tempString
 Mid(testString, i, 1) = UCase(Mid(tempString, i, 1))
 If fakeMD5(testString) = encrypted Then
 InitialGuesses = UCase(testString)
 GoTo foundResult
 End If
 Next i
 ' First letter + 1 other letter is Cap
 For i = 2 To Len(tempString)
 testString = tempString
 Mid(testString, 1, 1) = UCase(Mid(tempString, 1, 1))
 Mid(testString, i, 1) = UCase(Mid(testString, i, 1))
 If fakeMD5(testString) = encrypted Then
 InitialGuesses = testString
 GoTo foundResult
 End If
 Next i
 ' First letter + 2 consecutive letters are Cap
 For i = 2 To Len(tempString) - 1
 testString = tempString
 Mid(testString, 1, 1) = UCase(Mid(tempString, 1, 1))
 Mid(testString, i, 2) = UCase(Mid(testString, i, 2))
 If fakeMD5(testString) = encrypted Then
 InitialGuesses = testString
 GoTo foundResult
 End If
 Next i
 ' First letter + 2 letters separated by a space (XxxxxXxX) are Cap
 For i = 2 To Len(tempString) - 2
 testString = tempString
 Mid(testString, 1, 1) = UCase(Mid(tempString, 1, 1))
 Mid(testString, i, 1) = UCase(Mid(testString, i, 1))
 Mid(testString, i + 2, 1) = UCase(Mid(testString, i + 2, 1))
 If fakeMD5(testString) = encrypted Then
 InitialGuesses = testString
 GoTo foundResult
 End If
 Next i
foundResult:
End Function

Initial guesses is designed to quickly test likely combinations of case permutations based on typical UserNames. The last two guesses were included for people with surnames like OBrien and McCracken (or with initials in their names like VerySLearner).

Testing the Code

The whole thing is driven by this test method:

FakeMD5 creates a string that for all intents and purposes serves as our unique ID for a given user - it is generated from myTestString and is used to compare each permutation against.

Compare the speed of finding a match for a very long first name using initial guesses and brute force by commenting out the line: stringFound = InitialGuesses(myTestString, encrypted) (word of warning this could take a while, hold Ctrl+Esc before pressing Ctrl+Break works for me, you could add DoEvents in the main For loop of CasePermutation)

Sub test()
 Dim myNow As Date
 Dim myNow2 As Date
 Const myTestString As String = "Daniel_has_a_longnameMcCracken" ' Change this for testing 
 Dim encrypted As String
 encrypted = fakeMD5(myTestString)
 Debug.Print "Encrypted by fakeMD5: " & encrypted & " (" & Len(encrypted) & ")"
 Dim stringFound As String
 myNow = Now()
 Debug.Print "Attempting initial guesses..."
 stringFound = InitialGuesses(myTestString, encrypted)
 If stringFound <> vbNullString Then
 Debug.Print stringFound
 GoTo foundID
 End If
 Debug.Print "Initial guesses failed, attempting brute force..."
 stringFound = CasePermutation(myTestString, encrypted)
 If stringFound <> vbNullString Then
 Debug.Print stringFound
 GoTo foundID
 End If
foundID:
 Debug.Print "v1 " & (Now - myNow) * 10 ^ 5 ' rough estimate of time
 Exit Sub
End Sub