/ Snippet Library - View Code

Visual Basic / Miscellaneous / Reading/Writing Screensaver pass.

Snippet details

ID: 394

Viewed: 1222

Added: 2002-08-19

Version:

Snippets in this catagory
Show Printable Version

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!

Compatible with:
Visual Basic 3, Visual Basic 4 16-bit

General Details

Snippet uploaded by: snippet

Email : webmaster@snippetlibrary.com

Snippet By: Unknown

Snippet By:	Unknown
Declarations
Highlight AllTo 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
Highlight AllFunction 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

No Reviews to show