VB6 Encryption & Decryption Try it ! (Make itSimple)

[ahsan_ali]

Hi Guys,
I am providing you the code through which you can make your information/file unreadable from other users while making some kind of your personal application or database.

1. Encryption allows you to encrypt your data into unreadable form by using getting ASCII value and converting it to some number plus some KEY (your private key!) and finally using chr() function to convert it your secured file (for example: Letter "A" , get it ASCII which you know 65, then add some key/number assum 13 , which result 65+13=78, and then convert chr(78) to unreadable which "N")


2. Decryption is opposite to encryption simply subtract your key ! Cool


here are two function for vb6 beginners enjoy !

Encryption Code :

Public Function Encrypt(Name As String, Key As Long) As String 

Dim v As Long, c1 As String, z As String

For v = 1 To Len(Name)  

 c1 = Asc(Mid(Name, v, 1)) 

   c1 = Chr(c1 + Key)             ' your private goes key here !
  
 z = z & c1 

Next v 

Encrypt = z 

End Function

Decryption Code :

Public Function Decrypt(Name As String, Key As Long) As String

Dim v As Long, c1 As String, z As String 

For v = 1 To Len(Name)

  c1 = Asc(Mid(Name, v, 1)) 

   c1 = Chr(c1 - Key)            'your private goes key here ! 

  z = z & c1 

Next v 

Decrypt = z  

End Function

Look Below Attachement for Sample !

[LaVolpe]

No offense, but your algorithm is extremely limited, at best. Try encrypting, passing a Key as 500.
Additionally. If you were to encrypt a string containing an ASCII value of 255 an error would occur unless your Key was zero or negative value. Negative key values will not work for small ASCII values. A good encryption algorithm will not generate errors for any ASCII value, nor any valid key.

[ahsan_ali]

So what is best method to encrypt & decrypt which do not give me error at zero/-ve as you said

[LaVolpe]

There are many encryption routines; even file compression can be considered a form of encryption. The XOR encryption method is the simplest I believe but probably the least secure. Search this forum for encryption and other sites too; planetsourcecode.com also has many examples.

[dilettante]

One simple approach is to use the CAPICOM (Crypto API COM) wrapper.

Example attached.

[rjrobin008]

Encryption method 5

Encrypt.zip

[HackerVlad]

Public Function EncryptString(xString As String) As String
    Dim Password As String
    Dim Counter As Double
    Dim temp As Byte
    
    Counter = 1
    
    Do Until Counter = Len(xString) + 1
        temp = Asc(Mid(xString, Counter, 1))
        temp = temp Xor (96)
        Password = Password + Chr(temp)
        Counter = Counter + 1
    Loop
    
    EncryptString = Password
End Function

Public Function DecryptString(xString As String) As String
    Dim Password As String
    Dim Counter As Double
    Dim temp As Byte
    
    Counter = 1
    
    Do Until Counter = Len(xString) + 1
        temp = Asc(Mid(xString, Counter, 1)) Xor (96)
        Password = Password + Chr(temp)
        Counter = Counter + 1
    Loop
    
    DecryptString = Password
End Function

[BenJones]

Ok for encryption of small strings from praying eyes but not much use data. as said you should use xor or add random with it to.
here is a simple one you chould get idea from https://gist.github.com/wqweto/42a6c...b2ac9f3c9d8510

also take a look at
https://www.amazon.co.uk/Developing-.../dp/0672318369

RC4 may also be a simple idea to get started to
https://stackoverflow.com/questions/...ipt-and-python

[HackerVlad]

BenJones, wqweto, thank you for your efforts, but I don't think your code will work in Windows XP, as Windows XP doesn't even have the library itself bcrypt.dll

[HackerVlad]

Isn't it easier to use Crypt32.dll which is also available in Windows XP?

[HackerVlad]

For example, I have written a code for encrypting and decrypting a byte array using Crypt32.dll . But please note that the CryptProtectData function encrypts only for one computer. It is unlikely to be decrypted on another computer. You can also use other functions to encrypt and decrypt messages on different computers.

Option Explicit

Private Type CRYPTPROTECT_PROMPTSTRUCT
   cbSize As Long
   dwPromptFlags As ProtectDataPromptFlags ' CrypyProtectPromptFlags
   hwndApp As Long
   szPrompt As Long
End Type

Private Type CRYPTOAPI_BLOB
   cbData As Long
   pbData As Long
End Type

Private Declare Function CryptProtectData Lib "crypt32.dll" ( _
   pDataIn As Any, _
   ByVal szDataDescr As Long, _
   pOptionalEntropy As Any, _
   ByVal pvReserved As Long, _
   pPromptStruct As Any, _
   ByVal dwFlags As Long, _
   pDataOut As Any) As Long

Private Declare Function CryptUnprotectData Lib "crypt32.dll" ( _
   pDataIn As Any, _
   ppszDataDescr As Long, _
   pOptionalEntropy As Any, _
   ByVal pvReserved As Long, _
   pPromptStruct As Any, _
   ByVal dwFlags As Long, _
   pDataOut As Any) As Long

Private Declare Sub MoveMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    Dest As Any, Src As Any, ByVal Ln As Long)

Private Declare Function LocalFree Lib "kernel32" (ByVal Ptr As Long) As Long

Enum ProtectDataPromptFlags
   PromptOnUnprotect = &H1
   PromptOnProtect = &H2
   Strong = &H8
   RequireStrong = &H10
End Enum

Enum ProtectDataFlags
   UIForbidden = &H1
   LocalMachine = &H4
   CredSync = &H8
   Audit = &H10
   NoRecovery = &H20
   VerifyProtection = &H40
   CredRegenerate = &H80
End Enum

'
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsA" (ByVal pszPath As String) As Long

Dim b2() As Byte
'

Public Function ProtectData( _
   Data() As Byte, _
   ByVal DataDescription As String, _
   Optional ByVal ParentWnd As Long, _
   Optional ByVal DialogTitle As String, _
   Optional ByVal Flags As ProtectDataFlags = LocalMachine, _
   Optional ByVal PromptFlags As ProtectDataPromptFlags) As Byte()
Dim tBlobIn As CRYPTOAPI_BLOB
Dim tBlobOut As CRYPTOAPI_BLOB
Dim tPS As CRYPTPROTECT_PROMPTSTRUCT
Dim abEnc() As Byte
Dim lRes As Long

   ' Fill the blob structure
   With tBlobIn
      .cbData = UBound(Data) - LBound(Data) + 1
      .pbData = VarPtr(Data(0))
   End With
   
   With tPS
      .cbSize = Len(tPS)
      .hwndApp = ParentWnd
      .dwPromptFlags = PromptFlags
      If Len(DialogTitle) Then .szPrompt = StrPtr(DialogTitle)
   End With
   
   ' Encrypt the data
   lRes = CryptProtectData( _
            tBlobIn, _
            StrPtr(DataDescription), _
            ByVal 0&, _
            0&, _
            tPS, _
            Flags, _
            tBlobOut)
   If lRes = 0 Then Err.Raise &H80070000 Or Err.LastDllError
      
   ' Copy the encrypted data to a byte array
   ReDim abEnc(0 To tBlobOut.cbData - 1)
   MoveMemory abEnc(0), ByVal tBlobOut.pbData, tBlobOut.cbData
   
   ' Return the encrypted data
   ProtectData = abEnc
   
   ' Release the returned data
   LocalFree tBlobOut.pbData
   
End Function

Public Function UnProtectData( _
   Data() As Byte, _
   Optional DataDescription As String, _
   Optional ByVal ParentWnd As Long, _
   Optional ByVal DialogTitle As String, _
   Optional ByVal Flags As ProtectDataFlags = LocalMachine, _
   Optional ByVal PromptFlags As ProtectDataPromptFlags) As Byte()
Dim tBlobIn As CRYPTOAPI_BLOB
Dim tBlobOut As CRYPTOAPI_BLOB
Dim tPS As CRYPTPROTECT_PROMPTSTRUCT
Dim abData() As Byte
Dim lPtr As Long
Dim lRes As Long

   ' Fill the blob structure
   With tBlobIn
      .cbData = UBound(Data) - LBound(Data) + 1
      .pbData = VarPtr(Data(0))
   End With
   
   With tPS
      .cbSize = Len(tPS)
      .hwndApp = ParentWnd
      .dwPromptFlags = PromptFlags
      If Len(DialogTitle) Then .szPrompt = StrPtr(DialogTitle)
   End With
   
   ' Unprotect the data
   lRes = CryptUnprotectData( _
            tBlobIn, _
            lPtr, _
            ByVal 0&, _
            0&, _
            tPS, _
            Flags, _
            tBlobOut)
   If lRes = 0 Then Err.Raise &H80070000 Or Err.LastDllError
      
   ' Copy the data to a byte array
   ReDim abData(0 To tBlobOut.cbData - 1)
   MoveMemory abData(0), ByVal tBlobOut.pbData, tBlobOut.cbData
   
   ' Get the description
   'DataDescription = Ptr2Str(lPtr)
   
   ' Return the data
   UnProtectData = abData
   
   ' Release the returned data pointer
   LocalFree tBlobOut.pbData
   LocalFree lPtr
   
End Function

Private Sub Command1_Click()
    Dim str As String
    Dim b() As Byte
    Dim i, c As Long
    
    str = "12345"
    b = str
    
    b2 = ProtectData(b, "")
    
    Text1.Text = ""
    For i = 0 To UBound(b2)
        Text1.Text = Text1.Text & IIf(Len(Hex(b2(i))) = 2, Hex(b2(i)), "0" & Hex(b2(i))) & "  "
        c = c + 1
        If c = 16 Then c = 0: Text1.Text = Text1.Text & vbCrLf
    Next
    Me.Caption = UBound(b2) + 1
End Sub

Private Sub Command2_Click()
    Dim str As String
    Dim b() As Byte
    
    b = UnProtectData(b2, "")
    
    str = b
    MsgBox str
End Sub

Private Sub Command3_Click()
    Dim FileNo As Integer
    
    FileNo = FreeFile
    
    If IsFileAPI(App.Path + "\dump.dat") <> 0 Then Kill App.Path + "\dump.dat"
    
    Open App.Path + "\dump.dat" For Binary As FileNo
        Put #FileNo, , b2
    Close FileNo
End Sub

Private Sub Command4_Click()
    Dim FileNo As Integer
    Dim fLen As Long
    
    FileNo = FreeFile
    
    Open App.Path + "\dump.dat" For Binary As FileNo
        fLen = LOF(FileNo)
        ReDim b2(fLen - 1)
        Get #FileNo, , b2
    Close FileNo
    Me.Caption = UBound(b2) + 1
End Sub