www.pudn.com > DataCollectionSystem.rar > Cipher.bas, change:2003-09-12,size:8222b


Attribute VB_Name = "Cipher" 
' ================================================================= 
' Password Guard source code 
' Version 1.1 
' Copyright (C) 2000 Khaery Rida 
' ================================================================= 
 
' Cipher Strength: 128-bit 
' Cipher.bas written by Tom Pickles 
' tom_pickles@hotmail.com 
' http://www.digital-harmony.com 
' ================================================================= 
Public UserRegSection As String 
 
' User-defined types 
Public Type DataRecord 
    Description As String 
    Server As String 
    UserName As String 
    Password As String 
    Notes As String 
End Type 
 
Dim x1a0(9) As Long 
Dim cle(17) As Long 
Dim x1a2 As Long 
 
Dim inter As Long, res As Long, ax As Long, bx As Long 
Dim cx As Long, dx As Long, si As Long, tmp As Long 
Dim i As Long, C As Byte 
 
 
Sub Assemble() 
 
x1a0(0) = ((cle(1) * 256) + cle(2)) Mod 65536 
code 
inter = res 
 
x1a0(1) = x1a0(0) Xor ((cle(3) * 256) + cle(4)) 
code 
inter = inter Xor res 
 
 
x1a0(2) = x1a0(1) Xor ((cle(5) * 256) + cle(6)) 
code 
inter = inter Xor res 
 
x1a0(3) = x1a0(2) Xor ((cle(7) * 256) + cle(8)) 
code 
inter = inter Xor res 
 
x1a0(4) = x1a0(3) Xor ((cle(9) * 256) + cle(10)) 
code 
inter = inter Xor res 
 
x1a0(5) = x1a0(4) Xor ((cle(11) * 256) + cle(12)) 
code 
inter = inter Xor res 
 
x1a0(6) = x1a0(5) Xor ((cle(13) * 256) + cle(14)) 
code 
inter = inter Xor res 
 
x1a0(7) = x1a0(6) Xor ((cle(15) * 256) + cle(16)) 
code 
inter = inter Xor res 
 
i = 0 
 
End Sub 
 
Sub code() 
dx = (x1a2 + i) Mod 65536 
ax = x1a0(i) 
cx = &H15A 
bx = &H4E35 
 
tmp = ax 
ax = si 
si = tmp 
 
tmp = ax 
ax = dx 
dx = tmp 
 
If (ax <> 0) Then 
ax = (ax * bx) Mod 65536 
End If 
 
tmp = ax 
ax = cx 
cx = tmp 
 
If (ax <> 0) Then 
ax = (ax * si) Mod 65536 
cx = (ax + cx) Mod 65536 
End If 
 
tmp = ax 
ax = si 
si = tmp 
ax = (ax * bx) Mod 65536 
dx = (cx + dx) Mod 65536 
 
ax = ax + 1 
 
x1a2 = dx 
x1a0(i) = ax 
 
res = ax Xor dx 
i = i + 1 
 
End Sub 
 
Function crypt(ByVal inp As String, ByVal Key As String) As String 
 
crypt = "" 
si = 0 
x1a2 = 0 
i = 0 
 
For fois = 1 To 16 
cle(fois) = 0 
Next fois 
 
champ1 = Key 
lngchamp1 = Len(champ1) 
 
For fois = 1 To lngchamp1 
cle(fois) = Asc(Mid(champ1, fois, 1)) 
Next fois 
 
champ1 = inp 
lngchamp1 = Len(champ1) 
For fois = 1 To lngchamp1 
C = Asc(Mid(champ1, fois, 1)) 
 
Assemble 
 
cfc = (((inter / 256) * 256) - (inter Mod 256)) / 256 
cfd = inter Mod 256 
 
For compte = 1 To 16 
 
cle(compte) = cle(compte) Xor C 
 
Next compte 
 
C = C Xor (cfc Xor cfd) 
 
d = (((C / 16) * 16) - (C Mod 16)) / 16 
e = C Mod 16 
 
crypt = crypt + Chr$(&H61 + d) ' d+&h61 give one letter range from a to p for the 4 high bits of c 
crypt = crypt + Chr$(&H61 + e) ' e+&h61 give one letter range from a to p for the 4 low bits of c 
 
 
Next fois 
 
End Function 
 
Function decrypt(ByVal inp As String, ByVal Key As String) As String 
 
decrypt = "" 
si = 0 
x1a2 = 0 
i = 0 
 
For fois = 1 To 16 
cle(fois) = 0 
Next fois 
 
champ1 = Key 
lngchamp1 = Len(champ1) 
 
For fois = 1 To lngchamp1 
cle(fois) = Asc(Mid(champ1, fois, 1)) 
Next fois 
 
champ1 = inp 
lngchamp1 = Len(champ1) 
 
For fois = 1 To lngchamp1 
 
d = Asc(Mid(champ1, fois, 1)) 
If (d - &H61) >= 0 Then 
d = d - &H61  ' to transform the letter to the 4 high bits of c 
If (d >= 0) And (d <= 15) Then 
d = d * 16 
End If 
End If 
If (fois <> lngchamp1) Then 
fois = fois + 1 
End If 
e = Asc(Mid(champ1, fois, 1)) 
If (e - &H61) >= 0 Then 
e = e - &H61 ' to transform the letter to the 4 low bits of c 
If (e >= 0) And (e <= 15) Then 
C = d + e 
End If 
End If 
 
Assemble 
 
cfc = (((inter / 256) * 256) - (inter Mod 256)) / 256 
cfd = inter Mod 256 
 
C = C Xor (cfc Xor cfd) 
 
For compte = 1 To 16 
 
cle(compte) = cle(compte) Xor C 
 
Next compte 
 
decrypt = decrypt + Chr$(C) 
 
Next fois 
 
End Function 
 
Public Function FileExists(Path$) As Integer 
 
' This function is used to ensure that a file is openable. 
   
    x = FreeFile 
 
    On Error Resume Next 
    Open Path$ For Input As x 
    If Err = 0 Then 
        FileExists = True 
    Else 
        FileExists = False 
    End If 
    Close x 
 
End Function 
Public Function IsValidUserID(UserID As String) As String 
     
    Dim vUserIndex As String 
    Dim vUserRegSection As String 
     
    For currentIndex = 1 To Len(Index) Step 6 
        vUserRegSection = Mid$(Index, currentIndex, 6) 
        regString = GetSetting(MainTitle, vUserRegSection, "Index") 
        vUserIndex = decrypt(regString, Key2 & vUserRegSection) 
        regString = GetSetting(MainTitle, vUserRegSection, Left$(vUserIndex, 8)) 
        UserIDKeyword = Left$(vUserRegSection, 2) & Right$(Left$(vUserIndex, 8), 2) & Key1 
         
        If decrypt(regString, UserIDKeyword) = UserID Then 
            IsValidUserID = vUserRegSection & vUserIndex 
            Exit Function 
        End If 
    Next 
     
    IsValidUserID = "" 
     
End Function 
 
Public Function IsValidMasterPassword(regSection As String, regKey As String, UserID As String, MasterPassword As String) As String 
 
    regString = GetSetting(MainTitle, regSection, regKey) 
    MasterPasswordKeyword = Mid$(regSection, 3, 1) & Left$(UserID, 1) & Left$(MasterPassword, Len(MasterPassword) - 5) & Right$(MasterPassword, 1) & Right$(regKey, 1) & Right$(UserID, 1) 
    tmpString = decrypt(regString, MasterPasswordKeyword) 
     
    If Trim(MasterPassword) = tmpString Then 
        IsValidMasterPassword = Left$(UserID, 1) & Mid$(regSection, 5, 2) & MasterPassword 
    Else 
        IsValidMasterPassword = "" 
    End If 
     
End Function 
 
Public Function RandomPinString(PinNum As Integer) As String 
     
    Dim tOffset As Integer, currentPin As Long, tmpPin As String 
    Dim PinNumCount As Long 
     
GenerateRndPinString: 
        Randomize 
        For currentPin = 1 To PinNum 
            tOffset = (Rnd * 10000 Mod 255) + 1 
            RandomPinString = RandomPinString & Format$(Hex$(tOffset), "@@") 
        Next 
         
        ' The Format$ function is used to make sure that always 2 bytes are returned. 
        ' For example, instead of returning "B", the Format$ function, returns "B " 
        ' in this way, the resulting RandomPinString will always consist of 8 characters. 
         
        PinNumCount = 0 
         
        For currentPin = 1 To Len(RandomPinString) 
            tmpPin = Mid$(RandomPinString, currentPin, 1) 
            If IsNumeric(tmpPin) Then PinNumCount = PinNumCount + 1 
        Next 
         
        If PinNumCount = (PinNum * 2) Then GoTo GenerateRndPinString 
        ' Since this RandomPinString will be used as a ListItem key, we need to ensure that the 
        ' result RadnomPinString is not a whole Row value. For example, a RandomPinString 
        ' may take te value 24982751 which is an invalid ListItem's key. 
        
End Function 
 
Public Function ReadRecord(regKey As String) As DataRecord 
     
    Dim memberCount As Long 
    Dim memberLen As Long 
    Dim LastPos As Long 
 
    regString = GetSetting(MainTitle, UserRegSection, regKey) 
    tmpString = decrypt(regString, UserKeyword & Mid$(regKey, 3, 1) & Mid$(regKey, 5, 1)) 
    memberCount = 0 
    memberLen = 0 
    LastPos = 0 
     
    For currentChr = 1 To Len(tmpString) 
        tmpString2 = Mid$(tmpString, currentChr, 1) 
        memberLen = memberLen + 1 
         
        If tmpString2 = sDivide Then 
            memberCount = memberCount + 1 
             
            Select Case memberCount 
                Case 1 
                    ReadRecord.Description = Left$(tmpString, currentChr - 1) 
                Case 2 
                    ReadRecord.Server = Mid$(tmpString, LastPos, memberLen - 1) 
                Case 3 
                    ReadRecord.UserName = Mid$(tmpString, LastPos, memberLen - 1) 
                Case 4 
                    ReadRecord.Password = Mid$(tmpString, LastPos, memberLen - 1) 
                Case 5 
                    ReadRecord.Notes = Mid$(tmpString, LastPos, memberLen - 1) 
            End Select 
             
            memberLen = 0 
            LastPos = currentChr + 1 
        End If 
    Next 
     
End Function