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
