I am interested if it's possible to do string encryption/decryption using Excel Visual Basic and some cryptographic service provider.
I have found a walkthrough Encrypting and Decrypting Strings in Visual Basic, but it seems it's valid for standalone Visual Basic only.
So would you suggest me another encryption method or show how the walkthrough could be adopted for Excel Visual Basic?
The link you provide shows how to perform string encryption and decryption using VB.NET, and thus, using the .NET Framework.
Currently, Microsoft Office products cannot yet use the Visual Studio Tools for Applications component which will enable Office products to access the .NET framework's BCL (base class libraries) which, in turn, access the underlying Windows CSP (cryptographic server provider) and provide a nice wrapper around those encryption/decryption functions.
For the time being, Office products are stuck with the old VBA (Visual Basic for Applications) which is based on the old VB6 (and earlier) versions of visual Basic which are based upon COM, rather than the .NET Framework.
Because of all of this, you will either need to call out to the Win32 API to access the CSP functions, or you will have to "roll-your-own" encryption method in pure VB6/VBA code, although this is likely to be less secure. It all depends upon how "secure" you'd like your encryption to be.
If you want to "roll-your-own" basic string encryption/decryption routine, take a look at these link to get you started:
Encrypt a String Easily
Better XOR Encryption with a readable string
vb6 - encryption function
Visual Basic 6 / VBA String Encryption/Decryption Function
If you want to access the Win32 API and use the underlying Windows CSP (a much more secure option), see these links for detailed information on how to achieve this:
How to encrypt a string in Visual Basic 6.0
Access to CryptEncrypt (CryptoAPI/WinAPI) functions in VBA
That last link is likely the one you'll want and includes a complete VBA Class module to "wrap" the Windows CSP functions.
Create a Class Module called clsCifrado:
Option Explicit
Option Compare Binary
Private clsClave As String
Property Get Clave() As String
Clave = clsClave
End Property
Property Let Clave(value As String)
clsClave = value
End Property
Function Cifrar(Frase As String) As String
Dim Cachos() As Byte
Dim LaClave() As Byte
Dim i As Integer
Dim Largo As Integer
If Frase <> "" Then
Cachos() = StrConv(Frase, vbFromUnicode)
LaClave() = StrConv(clsClave, vbFromUnicode)
Largo = Len(clsClave)
For i = LBound(Cachos) To UBound(Cachos)
Cachos(i) = (Cachos(i) Xor LaClave(i Mod Largo)) + 34
Next i
Cifrar = StrConv(Cachos(), vbUnicode)
Else
Cifrar = ""
End If
End Function
Function Descifrar(Frase As String) As String
Dim Cachos() As Byte
Dim LaClave() As Byte
Dim i As Integer
Dim Largo As Integer
If Frase <> "" Then
Cachos() = StrConv(Frase, vbFromUnicode)
LaClave() = StrConv(clsClave, vbFromUnicode)
Largo = Len(clsClave)
For i = LBound(Cachos) To UBound(Cachos)
Cachos(i) = Cachos(i) - 34
Cachos(i) = (Cachos(i) Xor LaClave(i Mod Largo))
Next i
Descifrar = StrConv(Cachos(), vbUnicode)
Else
Descifrar = ""
End If
End Function
Now you can use it in your code:
to cipher
Private Sub btnCifrar_Click()
Dim Texto As String
Dim cCifrado As clsCifrado
Set cCifrado = New clsCifrado
'---poner la contraseña
If tbxClave.Text = "" Then
MsgBox "The Password is missing"
End Sub
Else
cCifrado.Clave = tbxClave.Text
End If
'---Sacar los datos
Texto = tbxFrase.Text
'---cifrar el texto
Texto = cCifrado.Cifrar(Texto)
tbxFrase.Text = Texto
End Sub
To descipher
Private Sub btnDescifrar_Click()
Dim Texto As String
Dim cCifrado As clsCifrado
Set cCifrado = New clsCifrado
'---poner la contraseña
If tbxClave.Text = "" Then
MsgBox "The Password is missing"
End Sub
Else
cCifrado.Clave = tbxClave.Text
End If
'---Sacar los datos
Texto = tbxFrase.Text
'---cifrar el texto
Texto = cCifrado.Descifrar(Texto)
tbxFrase.Text = Texto
End Sub
You can call pipe excel cell data through any shell script. Install the GPL Bert (http://bert-toolkit.com/) R language interface for Excel. Use the R script below in Excel to pipe cell data to Bash / perl / gpg / openssl.
c:\> cat c:\R322\callable_from_excel.R
CRYPTIT <- function( PLAINTEXT, MASTER_PASS ) {
system(
sprintf("bash -c 'echo '%s' |
gpg --symmetric --cipher-algo blowfish --force-mdc --passphrase '%s' -q |
base64 -w 0'",
PLAINTEXT, MASTER_PASS),
intern=TRUE)
}
DECRYPTIT <- function( CRYPTTEXT, MASTER_PASS ) {
system(
sprintf("bash -c 'echo '%s'|
base64 -d |
gpg --passphrase '%s' -q |
putclip | getclip' ",CRYPTTEXT,MASTER_PASS),
intern=TRUE)
}
In Excel, you can try: C1=CRYPTIT(A1,A2) and C2=DECRYPTIT(C1,A2) Optional: putclip saves decrypted text in clipboard. Both functions types are: String -> String. Usual caveats about escaping single-quotes in single-quoted strings.
Avoids dealing with not "normal" characters. You decide in AllowedChars what characters to allow.
Public Function CleanEncryptSTR(MyString As String, MyPassword As String, Encrypt As Boolean) As String
'Encrypts strings chars contained in Allowedchars
'MyString = String to decrypt
'MyPassword = Password
'Encrypt True: Encrypy False: Decrypt
Dim i As Integer
Dim ASCToAdd As Integer
Dim ThisChar As String
Dim ThisASC As Integer
Dim NewASC As Integer
Dim MyStringEncrypted As String
Dim AllowedChars As String
AllowedChars = "&0123456789;ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
If Len(MyPassword) > 0 Then
For i = 1 To Len(MyString)
' ThisASC = Asc(Mid(MyString, i, 1))
' ThisASC = IntFromArray(Asc(Mid(MyString, i, 1)), MyVector())
ThisChar = Mid(MyString, i, 1)
ThisASC = InStr(AllowedChars, ThisChar)
If ThisASC > 0 Then
ASCToAdd = Asc(Mid(MyPassword, i Mod Len(MyPassword) + 1, 1))
If Encrypt Then
NewASC = ThisASC + ASCToAdd
Else
NewASC = ThisASC - ASCToAdd
End If
NewASC = NewASC Mod Len(AllowedChars)
If NewASC <= 0 Then
NewASC = NewASC + Len(AllowedChars)
End If
MyStringEncrypted = MyStringEncrypted & Mid(AllowedChars, NewASC, 1)
Else
MyStringEncrypted = MyStringEncrypted & ThisChar
End If
Next i
Else
MyStringEncrypted = MyString
End If
CleanEncryptSTR = MyStringEncrypted
End Function
Here is a basic symmetric encryption/decryption example:
Sub testit()
Dim inputStr As String
inputStr = "Hello world!"
Dim encrypted As String, decrypted As String
encrypted = scramble(inputStr)
decrypted = scramble(encrypted)
Debug.Print encrypted
Debug.Print decrypted
End Sub
Function stringToByteArray(str As String) As Variant
Dim bytes() As Byte
bytes = str
stringToByteArray = bytes
End Function
Function byteArrayToString(bytes() As Byte) As String
Dim str As String
str = bytes
byteArrayToString = str
End Function
Function scramble(str As String) As String
Const SECRET_PASSWORD As String = "K*4HD%f#nwS%sdf032#gfl!HLKN*pq7"
Dim stringBytes() As Byte, passwordBytes() As Byte
stringBytes = stringToByteArray(str)
passwordBytes = stringToByteArray(SECRET_PASSWORD)
Dim upperLim As Long
upperLim = UBound(stringBytes)
ReDim scrambledBytes(0 To upperLim) As Byte
Dim idx As Long
For idx = LBound(stringBytes) To upperLim
scrambledBytes(idx) = stringBytes(idx) Xor passwordBytes(idx)
Next idx
scramble = byteArrayToString(scrambledBytes)
End Function
Be aware that this will crash if your given input string is longer than the SECRET_PASSWORD. This is just an example to get started with.
This code works well for me (3DES Encryption/Decryption):
I store INITIALIZATION_VECTOR and TRIPLE_DES_KEY as environment variables (obviously different values than those posted here) and get them using VBA Environ() function, so all sensitive data (passwords) in VBA code is encrypted.
Option Explicit
Public Const INITIALIZATION_VECTOR = "zlrs$5kd" 'Always 8 characters
Public Const TRIPLE_DES_KEY = ">tlF8adk=35K{dsa" 'Always 16 characters
Sub TestEncrypt()
MsgBox "This is an encrypted string: -> " & EncryptStringTripleDES("This is an encrypted string:")
Debug.Print EncryptStringTripleDES("This is an encrypted string:")
End Sub
Sub TestDecrypt()
MsgBox "u99CVItCGiMQEVYHf8+S22QbJ5CPQGDXuS5n1jvEIgU= -> " & DecryptStringTripleDES("u99CVItCGiMQEVYHf8+S22QbJ5CPQGDXuS5n1jvEIgU=")
End Sub
Function EncryptStringTripleDES(plain_string As String) As Variant
Dim encryption_object As Object
Dim plain_byte_data() As Byte
Dim encrypted_byte_data() As Byte
Dim encrypted_base64_string As String
EncryptStringTripleDES = Null
On Error GoTo FunctionError
plain_byte_data = CreateObject("System.Text.UTF8Encoding").GetBytes_4(plain_string)
Set encryption_object = CreateObject("System.Security.Cryptography.TripleDESCryptoServiceProvider")
encryption_object.Padding = 3
encryption_object.key = CreateObject("System.Text.UTF8Encoding").GetBytes_4(TRIPLE_DES_KEY)
encryption_object.IV = CreateObject("System.Text.UTF8Encoding").GetBytes_4(INITIALIZATION_VECTOR)
encrypted_byte_data = _
encryption_object.CreateEncryptor().TransformFinalBlock(plain_byte_data, 0, UBound(plain_byte_data) + 1)
encrypted_base64_string = BytesToBase64(encrypted_byte_data)
EncryptStringTripleDES = encrypted_base64_string
Exit Function
FunctionError:
MsgBox "TripleDES encryption failed"
End Function
Function DecryptStringTripleDES(encrypted_string As String) As Variant
Dim encryption_object As Object
Dim encrypted_byte_data() As Byte
Dim plain_byte_data() As Byte
Dim plain_string As String
DecryptStringTripleDES = Null
On Error GoTo FunctionError
encrypted_byte_data = Base64toBytes(encrypted_string)
Set encryption_object = CreateObject("System.Security.Cryptography.TripleDESCryptoServiceProvider")
encryption_object.Padding = 3
encryption_object.key = CreateObject("System.Text.UTF8Encoding").GetBytes_4(TRIPLE_DES_KEY)
encryption_object.IV = CreateObject("System.Text.UTF8Encoding").GetBytes_4(INITIALIZATION_VECTOR)
plain_byte_data = encryption_object.CreateDecryptor().TransformFinalBlock(encrypted_byte_data, 0, UBound(encrypted_byte_data) + 1)
plain_string = CreateObject("System.Text.UTF8Encoding").GetString(plain_byte_data)
DecryptStringTripleDES = plain_string
Exit Function
FunctionError:
MsgBox "TripleDES decryption failed"
End Function
Function BytesToBase64(varBytes() As Byte) As String
With CreateObject("MSXML2.DomDocument").createElement("b64")
.DataType = "bin.base64"
.nodeTypedValue = varBytes
BytesToBase64 = Replace(.Text, vbLf, "")
End With
End Function
Function Base64toBytes(varStr As String) As Byte()
With CreateObject("MSXML2.DOMDocument").createElement("b64")
.DataType = "bin.base64"
.Text = varStr
Base64toBytes = .nodeTypedValue
End With
End Function
Source code taken from here: https://gist.github.com/motoraku/97ad730891e59159d86c
Note the difference between the original code and my code, that is additional option encryption_object.Padding = 3 which forces VBA to not perform padding. With padding option set to 3 I get result exactly as in C++ implementation of DES_ede3_cbc_encrypt algorithm and which is in agreement with what is produced by this online tool.
