'VERIFY USER AND PASSWORD
Set objUserDBRS = New ADODB.Recordset
EncryptedPassword = SEC_EncryptOnly(txtPassword.Text, "passkeyencryptor")
TempSql = "Select * from [Users] where UserName = '" & LCase(txtUserName.Text) & _
"' and UserPassword = '" & EncryptedPassword & "'"
With objUserDBRS
If .State = adStateOpen Then .Close
.ActiveConnection = objMainDBCon
.CursorType = adOpenKeyset
.Source = TempSql
.Open
If .RecordCount = 0 Then
tempanswer = MsgBox("User Name or password incorrect. Try again.", vbExclamation, "Incorrect Login")
txtUserName.SetFocus
SendKeys "{Home}+{End}"
GoTo EndLoginCheck
End If
.MoveFirst
End With
'--------------------------------------------- USER SUCCEED
' show as logged in
LoggedIn = True
' do other stuff like retrieve user's security level here
Another
'==================================================
' These Routines are lightweight security routines
' they are NOT strong, but just keep out nosey people
' by Mark R Hamner (maxhamner (aht) hotmail (daught) com)
'==================================================
Public Function SEC_EncryptOnly(ByVal mystring As String, Optional ByVal myseed As String) As String
'this performs a one-way encryption - good for storing passwords
'when you try to log-in, encrypt the submitted password
'do a record select kinda like:
'
' select * from Users where username like 'username' and userpass like 'encryptedpw'
'
'You will only get a match if the passwords match
'this is always better than retrieving the password from a system for compare
Dim i, c, lastc As Integer
Dim charfirst, charrange As Integer
Dim strTemp, strTemp2 As String
strTemp = ""
lastc = 0
'initial encryption for first charcter & seed from WHOLE string
For i = 1 To Len(mystring)
lastc = lastc Xor Asc(Mid(mystring, i, 1))
Next
'each character now encrypted as function of seed & character & position
For i = 1 To Len(mystring)
c = Asc(Mid(mystring, i, 1))
If Len(myseed) > 0 And i < Len(myseed) - 1 Then
' mask char with previous value AND position AND user seed (up to user seed length)
c = c Xor i Xor lastc Xor Asc(Mid(myseed, i, 1))
Else
' mask char with previous value AND position
c = c Xor i Xor lastc
End If
'add our encrypted character
strTemp = strTemp & Chr(c)
'new value is new mask for next character
lastc = c
Next
'chracters are scrambled, but contain 'illegal' values, and I want to be able to
'save it in a text file, etc, or not have conflict when I build a compare string,
' so this brings them into a valid range that eliminates the single and double
'quotes, making string handling easier.
'
'This is NOT done durring the first loop because it would weaken our scramble...
strTemp2 = ""
charfirst = 40 'lowest charcter 40 means no quote
charrange = 121 'maximum range (121 possible chracters)
For i = 1 To Len(strTemp)
c = Asc(Mid(strTemp, i, 1))
c = c Mod (charrange - charfirst) 'truncate to chracter range
c = c + charfirst 'bump up to lowest char
strTemp2 = strTemp2 & Chr(c)
Next
SEC_EncryptOnly = strTemp2
End Function