During a beta test of one of my screen savers, a beta tester pointed out that I was using my own password protection scheme. My method differs from the scheme used in the screen savers that come with Windows. That beta tester wanted me to use the same password as the Windows screen savers. This is a great idea. This means that the user does not have to remember two different passwords.

After some digging, I found some C code that handled the encryption. Here’s a Visual Basic version of it!

How To Use The Code

To check to see if the user entered the same password that's in the CONTROL.INI file, just call the EncryptPassWord function:

If EncryptPassWord(txtPassWord(0).Text) = _

sGetPassWord() Then

'Your Code Goes Here

End If

To write a new password into CONTROL.INI, just call the SavePassWord function:

Call SavePassWord(EncryptPassWord(txtPassWord(2).Text))

Declare

Declare Function WritePrivateProfileString Lib "Kernel" _

(ByVal AppName As String, ByVal KeyName As String, _

ByVal NewString As String, ByVal filename As String) _

As Integer

Declare Function GetPrivateProfileString Lib "Kernel" _

(ByVal AppName As String, ByVal KeyName As String, _

ByVal default As String, ByVal ReturnedString As _

String, ByVal MAXSIZE As Integer, ByVal filename _

As String) As Integer

Code

Function sGetPassWord () As String

Dim sTempPass As String



sTempPass = sReadINI("ScreenSaver", "Password", _

"control.ini")

sGetPassWord = sTempPass

End Function



Sub SavePassWord (sPassWord As String)

Dim R As Integer



Call WriteINI("ScreenSaver", "Password", sPassWord, _

"control.ini")

End Sub



Function sEncryptPassWord (ByVal sArg As String) As String

Dim iArgPt As Integer

Dim iArgChar As Integer

Dim iArgLen As Integer



iArgLen = Len(sArg)



If iArgLen = 0 Then

Exit Function' Nothing to check

End If



sArg = UCase$(sArg)



'First Pass

For iArgPt = 1 To iArgLen

iArgChar = Asc(Mid$(sArg, iArgPt, 1))

Call PassXor(iArgLen, iArgChar)

If iArgPt = 1 Then

Call PassXor(42, iArgChar)

Else

Call PassXor(iArgPt - 1, iArgChar)

Call PassXor(Asc(Mid$(sArg, iArgPt - 1)), _

iArgChar)

End If



Mid$(sArg, iArgPt, 1) = Chr$(iArgChar)

Next iArtPt



'Second Pass

If iArgLen > 1 Then

For iArgPt = iArgLen To 1 Step -1

iArgChar = Asc(Mid$(sArg, iArgPt, 1))

Call PassXor(iArgLen, iArgChar)



If iArgPt = iArgLen Then

Call PassXor(42, iArgChar)

Else

Call PassXor(iArgPt - 1, iArgChar)

Call PassXor(Asc(Mid$(sArg, iArgPt + 1, _

1)), iArgChar)

End If

Mid$(sArg, iArgPt, 1) = Chr$(iArgChar)

Next iArtPt

End If



sEncryptPassWord = sArg

End Function



Sub PassXor (x1 As Integer, x2 As Integer)

Select Case x2 Xor x1

Case 0 To 32, 127 To 144, 147 To 159, 61, 91, 93

' not allowed

Case Else

x2 = x2 Xor x1

End Select

End Sub



Function sReadINI (sAppName As String, sKeyName As String, _

sFilename As String) As String

Dim sReturn As String



sReturn = String(255, Chr(0))



sReadINI = Left(sReturn, _

GetPrivateProfileString(sAppName, ByVal sKeyName, _

"", sReturn, Len(sReturn), sFilename))

End Function



Sub WriteINI (sAppName As String, sKeyName As _

String, sNewString As String, sFilename As String)

Dim R As Integer



R = WritePrivateProfileString(sAppName, _

sKeyName, sNewString, sFilename)

End Sub