Encrypt Connection String

[amorts]

Hi,

Does anyone know how to encrypt a connection string in VBA?

Thanks

 

[Richard Schollar]

Why would you want to do this? What kind of encryption algorithm would you want to do this with?

 

[amorts]

Hi Richard,

I just require a basic encryption method but have no experience of encrypting data. I am aware of various types of encryption but I would not know which would be best.

The easiest to implement is the main priority here.

 

[Richard Schollar]

Hi

Well, here's one way to encrypt a string (it uses Xor to encrypt/decrypt).

Function Amorts(ByVal data As String, ByVal encKey As String) As Variant
Dim l As Long, i As Long, InB() As Byte, OutB() As Byte, KeyB() As Byte
If Len(data) = 0 Or Len(encKey) = 0 Then Amorts = "Invalid argument(s) used": Exit Function
InB = StrConv(data, vbFromUnicode)
ReDim OutB(0 To UBound(InB))
KeyB = StrConv(encKey, vbFromUnicode)
l = LBound(KeyB)
For i = LBound(InB) To UBound(InB) Step 1
   OutB(i) = InB(i) Xor KeyB(l)
   l = l + 1
   If l > UBound(KeyB) Then l = LBound(KeyB)
Next i
Amorts = StrConv(OutB, vbUnicode)
End Function


Sub test()
Dim sConn As String, sKey As String, myString As String
sConn = "This is my exciting connection string"
sKey = "Richard"
'encrypt string:
myString = Amorts(sConn, sKey)
MsgBox "Encrypted string is: " & Chr$(10) & myString
'de-encrypt string:
myString = Amorts(myString, sKey)
MsgBox "Decrypted string is: " & Chr$(10) & myString
End Sub

The sub is just there to show how it works (all you need is the function). You can't use this in worksheet cells - I think because of the characters that may get returned can truncate excel cells so you lose data. As long as you use this within code it works just fine. The key you supply to the function should be a reasonable length to make it very difficult to guess. It is case-sensitive. An encrypte string is decrypted by passing it to the function with exactly the same key.

Hope this helps!

 

[amorts]

Wow, thanks for your help with this. This looks really useful, I appreciate your time spent on this.

 

[Richard Schollar]

I think this should be amended to produce an output string which would be Ascii character values (in which case you'd need an encryption routine and a separate dencryption routine) - this is because if you're unable to write - properly - to Excel cells, there ain't much point using it. What you would end up with is a result something like (from a string of "This is my string"):

23,45,67,34,12,34,5,67,89,08,45,67,89

which could be written quite happily to worksheet cells (it almost has a second layer of encryption then which is the conversion of normal text characters to their ascii code equivalent).

I can implement this in the routine if required.

 

[Richard Schollar]

Here are two functions now: one to encrypt, one to decrypt. The encrypted string appears as a comma-delimited list of byte code values (but in string format). This can therefore it in worksheet cells without any problems. You would then need to run the decrypt function (using the exact same key) to decrypt it. Copy all the following code in and run the test sub.

Option Explicit
Sub test()
'this sub is only present to demonstrate use of the two functions!
'it is not required to use the functions.
Dim myString As String, holdingString As String, myKey As String
Application.ScreenUpdating = False
'sample string to encrypt:
myString = InputBox("Enter string to encrypt")
myKey = InputBox("Enter encryption key to use")
If Len(myString) = 0 Or Len(myKey) = 0 Then MsgBox "Invalid argument(s) used": Exit Sub
'report your entered string:
MsgBox "This is the string you entered: " & vbCr & myString
'run encryption function:
holdingString = XorEncrypt(myString, myKey)
'report encrypted string:
MsgBox "This is the encrypted string: " & vbCr & holdingString
'Decrypt encrypted string (by reversing process - must use exactly the same key
'(it is case-sensitive)
holdingString = XorDecrypt(holdingString, myKey)
'report decrypted string:
MsgBox "And decrypted: " & vbCr & holdingString
End Sub

Function XorEncrypt(ByVal sData As String, ByVal sKey As String) As String
Dim l As Long, i As Long, byIn() As Byte, SOut() As String, byKey() As Byte
If Len(sData) = 0 Or Len(sKey) = 0 Then XorEncrypt = "Invalid argument(s) used": Exit Function
byIn = StrConv(sData, vbFromUnicode)
ReDim SOut(LBound(byIn) To UBound(byIn))
byKey = StrConv(sKey, vbFromUnicode)
l = LBound(byKey)
For i = LBound(byIn) To UBound(byIn) Step 1
   SOut(i) = byIn(i) Xor byKey(l)
   l = l + 1
   If l > UBound(byKey) Then l = LBound(byKey)
Next i
XorEncrypt = Join(SOut, ",")
End Function

Function XorDecrypt(ByVal sData As String, ByVal sKey As String) As String
Dim i As Long, l As Long, byOut() As Byte, sIn() As String, byKey() As Byte
If Len(sData) = 0 Or Len(sKey) = 0 Then XorDecrypt = "Invalid argument(s) used": Exit Function
sIn = Split(sData, ",")
ReDim byOut(LBound(sIn) To UBound(sIn))
byKey = StrConv(sKey, vbFromUnicode)
l = LBound(byKey)
For i = LBound(sIn) To UBound(sIn) Step 1
   byOut(i) = Val(sIn(i)) Xor byKey(l)
   l = l + 1
   If l > UBound(byKey) Then l = LBound(byKey)
Next i
XorDecrypt = StrConv(byOut, vbUnicode)
End Function

 

[Richard Schollar]

Right, here's the definitive function:

Function XorCrypt(ByVal sData As String, ByVal sKey As String, ByVal EncOrDec As Boolean) As String
    Dim l As Long, i As Long, byIn() As Byte, byOut() As Byte, byKey() As Byte
    If Len(sData) = 0 Or Len(sKey) = 0 Then XorCrypt = "Invalid argument(s) used": Exit Function
    byIn = sData
    byOut = sData
    byKey = sKey
    l = LBound(byKey)
    For i = LBound(byIn) To UBound(byIn) - 1 Step 2
        byOut(i) = ((byIn(i) + 1 * (Not EncOrDec)) Xor byKey(l)) + 1 + (Not EncOrDec)
        l = l + 2
        If l > UBound(byKey) Then l = LBound(byKey)
    Next i
    XorCrypt = byOut
End Function

Can be used in worksheet cells. Now includes a third parameter (Boolean) specifying encryption (True) or decryption (False). This is used to add 1 to the encrypted byte after the Xor or to deduct 1 from the encrypted byte prior to the Xor decryption. This avoids having Ascii character 0 returned in the encrypted string (which won't be displayed in the cell, and will cause the encryption to fail).

Use like (in B1 say):

=XorCrypt(A1,"My Key",True)

to encrypt contents of A1 using a key of "My Key" and then decrypt via:

=XorCrypt(B1,"My Key",False)

Naturally, there would be no point doing this if you wanted to leave the formulas in the cells (as the key is obvious to an observer) so I envisage users encrypting and ten copying and pasting values (to remove the key from sight). Longer keys and longer strings to encrypt improve the security of this technique.

Hope this is of interest to anyone!

 

[tusharm]

You cannot encrypt information without knowing how it will be decrypted.

Hi,

Does anyone know how to encrypt a connection string in VBA?

Thanks