' ' pb_enc.bas ' ' Encryption for PB-DLL and PB-CC ' This file depends on no others, it may be included ' with any program to add basic string encryption features. ' ' By Don Dickinson ' ddickinson@usinternet.com ' dickinson.basicguru.com ' ' ' DEPENDENCIES ' ' (NONE) ' ' ' DISCLAIMER ' ' Use it as you see fit. By using or compiling this code or derivative thereof, ' you are consenting to the hold the author, Don Dickinson, harmless from ' all effects or side-effects its use. ' ' Also, I am not a cryptographer. This is a very complicated science. ' I use these encryption routines in non-critical situations where ' those I'm hiding data from are only casual users. I make no claims that ' these routines are safe in any way. I only know they "seem" to scramble ' data pretty well. ' ' ' FUNCTIONS ' ' Function crypt_string ( ByVal TheString As String, _ ' ByVal Password As String) As String ' This function takes a string buffer and encrypts it against ' the given password. It is a symetrical encryption algorithm, ' that is, to decrypt the string, give it the same password ' and the encrypted string and it will return the decrypted ' result. ' ' Function crypt_in_chunks( ByVal sString As String, _ ' ByVal sPassword As String, _ ' ByVal iBlockSize As Long ) As String ' ' ' Constants '============================================================================ #If Not %Def(%PB_ENC_BAS) %PB_ENC_BAS = 1 %SUB_KEY_LEN=7 ' ' Globals '============================================================================ Global g_pbenc_bas_LastPW As String Global g_pbenc_bas_LastBlock As Long ' ' Function Prototypes '============================================================================ Declare Function create_key ( ByVal PW As String, _ ByVal stringlen As Integer) As String Declare Function crypt_string ( ByVal TheString As String, _ ByVal Password As String ) As String ' ' crypt_in_chunks ' ' If you have a big string, it's faster to encrypt the buffer ' in blocks instead of just calling crypt_string in one ' motion. This helps because the encryption hash only ' needs to be generated once for the first block. Otherwise ' crypt_string builds a hug encryption hash - the length of the ' string. Since building the hash is what takes the most ' time, only have to do this on the first block greatly improves ' speed. '============================================================================ Function crypt_in_chunks( ByVal sString As String, ByVal sPassword As String, ByVal iBlockSize As Long ) As String Dim i As Long Dim iNumBlocks As Long Dim iLeft As Long Dim sResult As String iNumBlocks = Len(sString) \ iBlockSize iLeft = Len(sString) Mod iBlockSize For i = 1 To iNumBlocks sResult = sResult + crypt_string(Mid$(sString, (i - 1) * iBlockSize + 1, iBlockSize), sPassword) Next i If iLeft > 0 Then sResult = sResult + crypt_string(Right$(sString, iLeft), sPassword) Function = sResult End Function ' ' crypt_string '============================================================================ Function crypt_string ( ByVal TheString As String, _ ByVal Password As String ) As String Dim iNumSubKeys As Long Dim sTemp As String Dim iStringLen As Long Dim iLenLastKey As Long Dim iLenPW As Long Dim tPW As String Dim a As Long Dim i As Long Dim j As Long Dim sT As String Static sBigKey As String Static iLenBigKey As Long Dim iMask As Long Dim iPtr As Long Dim iChar As Long Dim sFinalString As String Dim ptrFinal As Byte Ptr Dim ptrFinalKey As Byte Ptr Static sFinalKey As String iLenPW = Len(Password) iStringLen = Len(TheString) '- We don't need to re-create a key if ' the last password was the same, and the ' length of the block is also the same, ' since the key is a function of the password ' and the length of the encryption block. ' If (g_pbenc_bas_LastPW <> Password) Or (g_pbenc_bas_LastBlock <> Len(TheString)) Then '- Prepare the main key - bigKey$ ' we keep looping until this is at least as long ' as the string we're trying to encrypt. ' g_pbenc_bas_LastPW = Password g_pbenc_bas_LastBlock = Len(TheString) sBigKey = "" iLenBigKey = 0 iNumSubKeys = Len(Password) \ %SUB_KEY_LEN iLenLastKey = Len(Password) Mod %SUB_KEY_LEN sBigKey = "" For i = 1 To iStringlen \ Len(Password) + 1 If iNumSubKeys > 0 Then For a = 1 To iNumSubKeys tPW = "" sT = "" For j = 1 To %SUB_KEY_LEN sT = Mid$(Password, ((a - 1) * %SUB_KEY_LEN) + j, 1) tPW = tPW + Chr$((i + 256) Mod (Asc(sT) + 1)) Next j sBigKey = sBigKey + create_key (tPW, iStringLen) Next a End If If iLenLastKey > 0 Then tPW = "" sT = "" For j = iLenLastKey To 1 Step -1 sT = Left$(Right$(Password, j), 1) tPW = tPW + Chr$((i + 256) Mod (Asc(sT) + 1)) Next j sBigKey = sBigKey + create_key (tPW, iStringLen) End If If Len(sBigKey) > iStringLen Then Exit For Next i iLenBigKey = Len(sBigKey) '- Build final key sFinalKey = Space$(iStringLen) ptrFinalKey = StrPtr(sFinalKey) iPtr = 0 For a = 1 To iStringLen Incr iPtr If iPtr > (iLenBigKey - 3) Then iPtr = 1 End If @ptrFinalKey = (Int(Val(Mid$(sBigKey, iPtr, 3))) + 256) Mod 256 If @ptrFinalKey = 0 Then @ptrFinalKey = (a + iPtr) Mod 256 Incr ptrFinalKey Next a End If '- Do the actual encryption sFinalString = Space$(iStringLen) ptrFinal = StrPtr(sFinalString) iPtr = 0 For a = 1 To iStringLen iMask = Asc(Mid$(sFinalKey, a, 1)) iChar = Asc(Mid$(TheString, a, 1)) @ptrFinal = iMask Xor iChar Incr ptrFinal Next a Function = sFinalString End Function ' ' create_key '============================================================================ Function create_key (ByVal PW As String, _ ByVal stringlen As Integer) As String Dim a As Integer Dim qTemp As Quad Dim tKey As String '- Zip through each character in the password ' multiplying each by the characters before it. ' qTemp = 1 For a = 1 To Len(PW) qTemp = qTemp * (Asc(Mid$(PW, a, 1)) + a) Next a qTemp = qTemp + stringlen tKey = Ltrim$(Rtrim$(Str$(qTemp))) '- This first three digits of this thing are predicatible ' since mostly characters are used as passwords, so we ' just trim them off. ' If Len(tKey) > 3 Then tKey = Mid$(tKey, 4) End If '- The result Function = tKey End Function ' ' crypt_ascii ' ' despite it's name, this function doesn't do any encryption. It ' takes a string and formats each of it's characters in hex format ' separated by a space. '============================================================================ Function crypt_ascii(sIncoming As String) As String Dim i As Long Dim sHex As String Dim sAccum As String sAccum = "" If Len(sIncoming) > 0 Then For i = 1 To Len(sIncoming) sHex = Hex$(Asc(Mid$(sIncoming, i, 1))) If Len(sHex) = 1 Then sHex = "0" + sHex If sAccum = "" Then sAccum = sHex Else sAccum = sAccum + " " + sHex End If Next i End If Function = sAccum End Function ' ' crypt_ascii ' ' Reverses crypt_ascii '============================================================================ Function decrypt_ascii(sIncoming As String) As String Dim i As Long Dim iInt As Long Dim sHex As String Dim sAccum As String If Trim$(sIncoming) = "" Then Function = "" Exit Function End If sAccum = "" For i = 1 To ParseCount(sIncoming, Chr$(32)) On Error Resume Next iInt = Int(Val("&h" + Parse$(sIncoming, Chr$(32), i))) sAccum = sAccum + Chr$(iInt) Next i Function = sAccum End Function #EndIf