VB6 Encryption & Decryption Try it ! (Make itSimple)

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 :

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 :

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 !

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.

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

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.

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

Example attached.

Encryption method 5

Attachment 193806

Code:

---

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

---

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

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

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

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.

Code:

---

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

---