Descrypt SagePay string vb.net - vb.net

I have been having some problems trying to decrypt the string returned back from SagePay.
I used their asp.net kit which included the encrypt and decrypt functions using base64 - sending the information to SagePay is not a problem but I am having a number of problems trying to descrypt the string.
Here is the function I am using to descypt:
Private Function base64Decode(ByVal strEncoded As String) As String
Dim iRealLength As Integer
Dim strReturn As String
Dim iBy4 As Integer
Dim iIndex As Integer
Dim iFirst As Integer
Dim iSecond As Integer
Dim iThird As Integer
Dim iFourth As Integer
If Len(strEncoded) = 0 Then
base64Decode = ""
Exit Function
End If
'** Base 64 encoded strings are right padded to 3 character multiples using = signs **
'** Work out the actual length of data without the padding here **
iRealLength = Len(strEncoded)
Do While Mid(strEncoded, iRealLength, 1) = "="
iRealLength = iRealLength - 1
Loop
'** Non standard extension to Base 64 decode to allow for + sign to space character substitution by **
'** some web servers. Base 64 expects a +, not a space, so convert vack to + if space is found **
Do While InStr(strEncoded, " ") <> 0
strEncoded = Left(strEncoded, InStr(strEncoded, " ") - 1) & "+" & Mid(strEncoded, InStr(strEncoded, " ") + 1)
Loop
strReturn = ""
'** Convert the base 64 4x6 byte values into 3x8 byte real values by reading 4 chars at a time **
iBy4 = (iRealLength \ 4) * 4
iIndex = 1
Do While iIndex <= iBy4
iFirst = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 0, 1)))
'iFirst = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 0, 1), Char)), Integer)
iSecond = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 1, 1)))
'iSecond = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 1, 1), Char)), Integer)
iThird = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 2, 1)))
'iThird = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 2, 1), Char)), Integer)
iFourth = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 3, 1)))
'iFourth = CType(System.Convert.ToByte(CType(Mid(strEncoded, iIndex + 3, 1), Char)), Integer)
strReturn = strReturn + CType(System.Convert.ToChar(((iFirst * 4) And 255) + ((iSecond \ 16) And 3)), String) 'Chr(((iFirst * 4) And 255) + ((iSecond \ 16) And 3))
strReturn = strReturn + CType(System.Convert.ToChar(((iSecond * 16) And 255) + ((iThird \ 4) And 15)), String) 'Chr(((iSecond * 16) And 255) + ((iThird \ 4) And 15))
strReturn = strReturn + CType(System.Convert.ToChar(((iThird * 64) And 255) + (iFourth And 63)), String) 'Chr(((iThird * 64) And 255) + (iFourth And 63))
iIndex = iIndex + 4
Loop
'** For non multiples of 4 characters, handle the = padding **
If iIndex < iRealLength Then
iFirst = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 0, 1)))
iSecond = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 1, 1)))
strReturn = strReturn & Chr(((iFirst * 4) And 255) + ((iSecond \ 16) And 3))
If iRealLength Mod 4 = 3 Then
iThird = arrBase64DecMap(Asc(Mid(strEncoded, iIndex + 2, 1)))
strReturn = strReturn & Chr(((iSecond * 16) And 255) + ((iThird \ 4) And 15))
End If
End If
base64Decode = strReturn
End Function
I don't think the web server is trying to encode anything as there are no + symbols within the url string and I have just glanced over the two to compair they are the same.
This returns a blank string whereas when I use the sections commented out in the first loop i get a really weired string back and when I use their simpleXor function it just returns complete nonsense.
There support is a bit useless as they "are not programmers"! So I am hoping someone can help me out who has used SagePay before.
Thanks in advance.

Managed to get it working:
Private Function base64Decode(ByVal strEncoded As String) As String
Dim output As String = ""
Dim bt64 As Byte() = System.Convert.FromBase64String(strEncoded)
For i As Integer = 0 To (bt64.Length - 1)
output &= System.Convert.ToChar(CInt(bt64(i))).ToString()
Next
Return output
End Function

Related

Securely store password in a VBA project

I built a file used by various people in one of my company service.
Each sheet is protected by a password and all users entries are handled with a VBA user form. All sheets are protected by the same password and my code protect/unprotect sheet when users modify data.
The problem is I'm storing the password in clear text in the VBA project so as to call the ActiveSheet.Protect password method. The VBA project is also protected by this password.
Is there a secure way to store that password in the VBA project ?
Anyone who knows how to search a bit would find a code to crack that VBA project password and be able to read it.
EDIT :
I have thought of computing a new password each time the file is open by adding some randomness in it. This way one could read the code without knowing the password. Adding a msgbox could reveal it but only until the file is reopenend. The problem is I cannot manually unprotect/protect sheet with that method as I won't be aware of the password.
Summarising the useful info from comments:
if your code has access to the password (even directly or through obfuscation) anybody having access to the code have access to the password too
password protection of Excel VBA is very weak, it's a trivial job to crack it
Conclusion : there is no way securely storing password in Excel VBA
This should do the trick. The password is smp2smp2, which you will get when running GetPassword, but that actual value is not stored in the project. It is stored using the code 30555112012321187051111661144119, which will be converted to the actual password (human readable) by using CreatePasswordFromCode. By the way, I have no idea how to easily get the code that belongs to a certain password. And in this way, it is always 8 characters long, no room for changes unless you adjust the code. I have found this somewhere in an old project of somebody else, no source mentioned unfortunately.
Option Explicit
Function GetPassword() As String
'the password is stored as codes, so the real password is not stored in this project
GetPassword = CreatePasswordFromCode("30555112012321187051111661144119")
End Function
Function CreatePasswordFromCode(ByVal pstrPasswordCode As String) As String
Dim intChar As Integer
Dim intCode As Integer
Dim arrintShifts(0 To 7) As Integer
Dim arrlngCharCode(0 To 7) As Long
Dim strMessage As String
intChar = 0
intCode = 0
For intCode = 0 To 7
'store -8 to -1 into 0-7
arrintShifts(intCode) = intCode - 8
Next intCode
'the code is stored by using the number of the letter of the password in the 4th character.
'the real code of the character is directly behind that.
'so the code 30555112012321187051111661144119
'has on position 3, 055, 5, 112, 0, 123, 2, 118, 7, 051, 1, 116, 6, 114 and 4, 119
'so sorted this is 0, 123, 1, 116, 2, 118, 3, 055, 4, 119, 5, 112, 6, 114, 7, 051
'then there is also the part where those charcode are shifted by adding -8 to -1 to them.
'leading to the real charactercodes:
'0, 123-8, 1, 116-7, 2, 118-6, 3, 055-5, 4, 119-4, 5, 112-3, 6, 114-2, 7, 051-1
'0, 115, 1, 109, 2, 112, 3, 050, 4, 115, 5, 109, 6, 112, 7, 050
For intChar = 0 To 7
If Mid(pstrPasswordCode, 1, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 2, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 5, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 6, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 9, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 10, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 13, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 14, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 17, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 18, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 21, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 22, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 25, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 26, 3) + arrintShifts(intChar))
ElseIf Mid(pstrPasswordCode, 29, 1) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 30, 3) + arrintShifts(intChar))
End If
Next intChar
'by getting the charcodes of these values, you create the password
CreatePasswordFromCode = Chr(arrlngCharCode(0)) & Chr(arrlngCharCode(1)) & Chr(arrlngCharCode(2)) & Chr(arrlngCharCode(3)) & Chr(arrlngCharCode(4)) & Chr(arrlngCharCode(5)) & Chr(arrlngCharCode(6)) & Chr(arrlngCharCode(7))
End Function
Modified the code for use with up to 99 characters. Added Password generator.
But still: this all is just an obfuscation of the real password.
Function CreatePasswordFromCode(ByVal pstrPasswordCode As String) As String
' Original Code https://stackoverflow.com/questions/47990187/securely-store-password-in-a-vba-project?utm_medium=organic&utm_source=google_rich_qa&utm_campaign=google_rich_qa
' Modified to extend password length
' Modifications free to use
Dim codeLen As Integer
Dim intChar As Integer
Dim intCode As Integer
Dim arrintShifts() As Integer
Dim arrlngCharCode() As Long
Dim icp As Integer
' Initialise Arrays
icp = IIf(Right(pstrPasswordCode, 1) Mod 2 = 0, 5, 4)
pstrPasswordCode = Left(pstrPasswordCode, Len(pstrPasswordCode) - IIf(Right(pstrPasswordCode, 1) Mod 2 = 0, 1, 1))
codeLen = Len(pstrPasswordCode) / icp - 1 ' Array Index starts with 0
ReDim arrintShifts(codeLen)
ReDim arrlngCharCode(codeLen)
intChar = 0
intCode = 0
For intCode = 0 To codeLen
'store -8 to -1 into 0-7
arrintShifts(intCode) = intCode - (codeLen + 1)
Next intCode
'the code is stored by using the number of the letter of the password in the 4th character.
'the real code of the character is directly behind that.
'so the code 30555112012321187051111661144119
'has on position 3, 055, 5, 112, 0, 123, 2, 118, 7, 051, 1, 116, 6, 114 and 4, 119
'so sorted this is 0, 123, 1, 116, 2, 118, 3, 055, 4, 119, 5, 112, 6, 114, 7, 051
'then there is also the part where those charcode are shifted by adding -8 to -1 to them.
'leading to the real charactercodes:
'0, 123-8, 1, 116-7, 2, 118-6, 3, 055-5, 4, 119-4, 5, 112-3, 6, 114-2, 7, 051-1
'0, 115, 1, 109, 2, 112, 3, 050, 4, 115, 5, 109, 6, 112, 7, 050
For intChar = 0 To codeLen
For intCode = 0 To codeLen
If CInt(Mid(pstrPasswordCode, intCode * icp + 1, icp - 3)) = intChar Then
arrlngCharCode(intChar) = (Mid(pstrPasswordCode, (intCode + 1) * icp - 2, 3) + arrintShifts(intChar))
Exit For
End If
Next intCode
Next intChar
'by getting the charcodes of these values, you create the password
CreatePasswordFromCode = ""
For intChar = 0 To codeLen
CreatePasswordFromCode = CreatePasswordFromCode & Chr(arrlngCharCode(intChar))
Next intChar
End Function
Function CreateCodeFromPassword(ByVal pstrPasswordCode As String) As String
' Generator free to use
Dim pwLen As Integer
Dim scp As String ' String Code Position, for formatting "0" or "00"
Dim icp As Integer ' marker if pwLen < 10 or > 10
Dim intCode As Integer
Dim arrintShifts() As Integer
Dim arrlngCharCode() As Long
Dim pw() As String
Dim Temp As Variant
Dim arnd() As Variant
Dim irnd As Variant
Randomize
' Initialise Arrays
pwLen = Len(pstrPasswordCode) - 1 ' Array Index starts with 0
scp = IIf(pwLen < 10, "0", "00")
' Create odd/even marker if we have 1 (odd) or 2 (even) byte index digits (scp), values between 0 and 9
icp = IIf(pwLen < 10, Int(Rnd() * 5 + 1) * 2 - 1, Int(Rnd() * 5 + 1) * 2)
ReDim arrintShifts(pwLen)
ReDim arrlngCharCode(pwLen)
ReDim pw(pwLen)
ReDim arnd(pwLen)
For intCode = 0 To pwLen
arnd(intCode) = intCode
Next intCode
' randomize the indizes to bring the code into a random order
For intCode = LBound(arnd) To UBound(arnd)
irnd = CLng(((UBound(arnd) - intCode) * Rnd) + intCode)
If intCode <> irnd Then
Temp = arnd(intCode)
arnd(intCode) = arnd(irnd)
arnd(irnd) = Temp
End If
Next intCode
'by getting the charcodes of these values, you create the password
For intCode = 0 To pwLen
'get characters
pw(intCode) = Mid(pstrPasswordCode, intCode + 1, 1)
'and store -8 to -1 into 0-7 (for additional obfuscation)
arrintShifts(intCode) = intCode - (pwLen + 1)
Next intCode
' Search for the random index and throw the shifted code at this position
For intCode = 0 To pwLen
arrlngCharCode(Application.Match(intCode, arnd, False) - 1) = AscB(pw(intCode)) - arrintShifts(intCode)
Next intCode
' Chain All Codes, combination of arnd(intcode) and arrlngCharCode(intcode) gives the random order
CreateCodeFromPassword = ""
For intCode = 0 To pwLen
CreateCodeFromPassword = CreateCodeFromPassword & Format(arnd(intCode), scp) & Format(arrlngCharCode(intCode), "000")
Next intCode
CreateCodeFromPassword = CreateCodeFromPassword & icp
End Function
Obfuscated version
'VBA code protection using: www.excel-pratique.com/en/vba_tricks/vba-obfuscator.php
Function CreatePasswordFromCode(ByVal z4891679d877f1da36647b21d6197fbfd As String) As String
Dim b2da54ddb60c93bf346493d7e08bc6d08 As Integer
Dim bf56f94eb6ed9a658e82e88591237324d As Integer
Dim bec732ae8e18b7b2ff2e9ccd058f3e8fc As Integer
Dim m06993036154505accc9ce092bdb57b17() As Integer
Dim b8026f9f8f7fe86372be0799d8c9c6691() As Long
Dim q24471047c7a6e466b78de3c6ae66f20f As String
Dim t5f443e88a552a3f943275f985dde03ca As Integer
t5f443e88a552a3f943275f985dde03ca = IIf(Right(z4891679d877f1da36647b21d6197fbfd, 1) Mod 2 = 0, 5, 4)
z4891679d877f1da36647b21d6197fbfd = Left(z4891679d877f1da36647b21d6197fbfd, Len(z4891679d877f1da36647b21d6197fbfd) - IIf(Right(z4891679d877f1da36647b21d6197fbfd, 1) Mod 2 = 0, 1, 1))
b2da54ddb60c93bf346493d7e08bc6d08 = Len(z4891679d877f1da36647b21d6197fbfd) / t5f443e88a552a3f943275f985dde03ca - 1
ReDim m06993036154505accc9ce092bdb57b17(b2da54ddb60c93bf346493d7e08bc6d08)
ReDim b8026f9f8f7fe86372be0799d8c9c6691(b2da54ddb60c93bf346493d7e08bc6d08)
bf56f94eb6ed9a658e82e88591237324d = 0
bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To b2da54ddb60c93bf346493d7e08bc6d08
m06993036154505accc9ce092bdb57b17(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = bec732ae8e18b7b2ff2e9ccd058f3e8fc - (b2da54ddb60c93bf346493d7e08bc6d08 + 1)
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bf56f94eb6ed9a658e82e88591237324d = 0 To b2da54ddb60c93bf346493d7e08bc6d08
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To b2da54ddb60c93bf346493d7e08bc6d08
If CInt(Mid(z4891679d877f1da36647b21d6197fbfd, bec732ae8e18b7b2ff2e9ccd058f3e8fc * t5f443e88a552a3f943275f985dde03ca + 1, t5f443e88a552a3f943275f985dde03ca - 3)) = bf56f94eb6ed9a658e82e88591237324d Then
b8026f9f8f7fe86372be0799d8c9c6691(bf56f94eb6ed9a658e82e88591237324d) = (Mid(z4891679d877f1da36647b21d6197fbfd, (bec732ae8e18b7b2ff2e9ccd058f3e8fc + 1) * t5f443e88a552a3f943275f985dde03ca - 2, 3) + m06993036154505accc9ce092bdb57b17(bf56f94eb6ed9a658e82e88591237324d))
Exit For
End If
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
Next bf56f94eb6ed9a658e82e88591237324d
CreatePasswordFromCode = ""
For bf56f94eb6ed9a658e82e88591237324d = 0 To b2da54ddb60c93bf346493d7e08bc6d08
CreatePasswordFromCode = CreatePasswordFromCode & Chr(b8026f9f8f7fe86372be0799d8c9c6691(bf56f94eb6ed9a658e82e88591237324d))
Next bf56f94eb6ed9a658e82e88591237324d
End Function
Function CreateCodeFromPassword(ByVal z4891679d877f1da36647b21d6197fbfd As String) As String
Dim qe564274d6cab7b91a3393ef092dac78f As Integer
Dim b330c8da5472f3c36b801671ef5a54797 As String
Dim t5f443e88a552a3f943275f985dde03ca As Integer
Dim bec732ae8e18b7b2ff2e9ccd058f3e8fc As Integer
Dim m06993036154505accc9ce092bdb57b17() As Integer
Dim b8026f9f8f7fe86372be0799d8c9c6691() As Long
Dim b343223dcae485b35af2792c7dd91f92b() As String
Dim e0d4cf763c9da42470a729a29b30d7d50 As Variant
Dim b41d8f2e79c0e09113beb7629aa0d8c48() As Variant
Dim b42a57d0c121b9fe34a74143aa279157c As Variant
Randomize
qe564274d6cab7b91a3393ef092dac78f = Len(z4891679d877f1da36647b21d6197fbfd) - 1
b330c8da5472f3c36b801671ef5a54797 = IIf(qe564274d6cab7b91a3393ef092dac78f < 10, "0", "00")
t5f443e88a552a3f943275f985dde03ca = IIf(qe564274d6cab7b91a3393ef092dac78f < 10, Int(Rnd() * 5 + 1) * 2 - 1, Int(Rnd() * 5 + 1) * 2)
ReDim m06993036154505accc9ce092bdb57b17(qe564274d6cab7b91a3393ef092dac78f)
ReDim b8026f9f8f7fe86372be0799d8c9c6691(qe564274d6cab7b91a3393ef092dac78f)
ReDim b343223dcae485b35af2792c7dd91f92b(qe564274d6cab7b91a3393ef092dac78f)
ReDim b41d8f2e79c0e09113beb7629aa0d8c48(qe564274d6cab7b91a3393ef092dac78f)
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = bec732ae8e18b7b2ff2e9ccd058f3e8fc
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = LBound(b41d8f2e79c0e09113beb7629aa0d8c48) To UBound(b41d8f2e79c0e09113beb7629aa0d8c48)
b42a57d0c121b9fe34a74143aa279157c = CLng(((UBound(b41d8f2e79c0e09113beb7629aa0d8c48) - bec732ae8e18b7b2ff2e9ccd058f3e8fc) * Rnd) + bec732ae8e18b7b2ff2e9ccd058f3e8fc)
If bec732ae8e18b7b2ff2e9ccd058f3e8fc <> b42a57d0c121b9fe34a74143aa279157c Then
e0d4cf763c9da42470a729a29b30d7d50 = b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc)
b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = b41d8f2e79c0e09113beb7629aa0d8c48(b42a57d0c121b9fe34a74143aa279157c)
b41d8f2e79c0e09113beb7629aa0d8c48(b42a57d0c121b9fe34a74143aa279157c) = e0d4cf763c9da42470a729a29b30d7d50
End If
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
b343223dcae485b35af2792c7dd91f92b(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = Mid(z4891679d877f1da36647b21d6197fbfd, bec732ae8e18b7b2ff2e9ccd058f3e8fc + 1, 1)
m06993036154505accc9ce092bdb57b17(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = bec732ae8e18b7b2ff2e9ccd058f3e8fc - (qe564274d6cab7b91a3393ef092dac78f + 1)
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
b8026f9f8f7fe86372be0799d8c9c6691(Application.Match(bec732ae8e18b7b2ff2e9ccd058f3e8fc, b41d8f2e79c0e09113beb7629aa0d8c48, False) - 1) = AscB(b343223dcae485b35af2792c7dd91f92b(bec732ae8e18b7b2ff2e9ccd058f3e8fc)) - m06993036154505accc9ce092bdb57b17(bec732ae8e18b7b2ff2e9ccd058f3e8fc)
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
CreateCodeFromPassword = ""
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
CreateCodeFromPassword = CreateCodeFromPassword & Format(b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc), b330c8da5472f3c36b801671ef5a54797) & Format(b8026f9f8f7fe86372be0799d8c9c6691(bec732ae8e18b7b2ff2e9ccd058f3e8fc), "000")
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
CreateCodeFromPassword = CreateCodeFromPassword & t5f443e88a552a3f943275f985dde03ca
End Function

Xor algorithm with no special characters using VBA

For a project I am developing I need to use some kind of encryption algorithm to encrypt some sensitive data, where each user has a unique hex key.
Basically I have to encrypt a string and write it to a file to import to a Access database (we are not authorised to use other RDBMS as the company policies don't allow it).
So while researching what algorithms to use, I've came across this awesome sample of an XOR algorithm from VBA Express, but there are some limitations with this particular algorithm (please correct me if I'm wrong) :
For certain combinations of string vs key, a overflow happens;
Excel uses a "different" ASCII code table which causes some entropy as well (can't use the first 32 codes because they refer to special characters);
I want to avoid special characters (line feeds, carriage returns) because I want to write to a file and if they exist I can't read the file as the splits will go bad.
With this being said, I can't maintain a 1 to 1 relationship of encoding and decoding.
So should I use another encryption system or are there changes should I do to fix this bad encryption?
Should I use another reading/writing file system other than line by line?
The code to generate the keys to test
Private Sub getDictionaryValues()
Dim atc As String
Dim wsheet As Worksheet
Dim wstmp As Worksheet
Dim rng As Range
Dim k As Long, j As Long
Dim arrrr(1 To 223) As String
Dim arc()
On Error Resume Next
j = 2
Set wsheet = ThisWorkbook.Worksheets("Sheet4")
arc = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
For i = 33 To 255
arrrr(i - 32) = Chr(i)
Next i
For k = LBound(arc) To UBound(arc)
For i = LBound(arrrr) To UBound(arrrr)
atc = XorC(arrrr(i), arc(k))
wsheet.Range(Cells(j, 1), Cells(j, 1)) = arc(k)
wsheet.Range(Cells(j, 2), Cells(j, 2)) = i + 32
wsheet.Range(Cells(j, 3), Cells(j, 3)) = arrrr(i)
wsheet.Range(Cells(j, 4), Cells(j, 4)) = Right(atc, Len(atc) - 3)
wsheet.Cells(j, 5) = XorC(atc, arc(k))
'wsheet.Cells(j, 6) = getUnicode(arrrr(i), arc(k))
j = j + 1
Next i
atc = vbNullString
Next k
End Sub
My version of the Xor algorithm
Function XorC(ByVal sData As String, ByVal sKey As String) As String
Dim l As Long, i As Long, byIn() As Byte, byOut() As Byte, byKey() As Byte
Dim bEncOrDec As Boolean
Dim addVal
If Len(sData) = 0 Or Len(sKey) = 0 Then XorC = "Invalid argument(s) used": Exit Function
If Left$(sData, 3) = "xxx" Then
bEncOrDec = False 'decryption
sData = Mid$(sData, 4)
Else
bEncOrDec = True 'encryption
End If
byIn = sData
byOut = sData
byKey = sKey
If bEncOrDec = True Then
addVal = 32
Else
addVal = 1 * -32
End If
l = LBound(byKey)
For i = LBound(byIn) To UBound(byIn) - 1 Step 2
If (((byIn(i) + Not bEncOrDec) Xor byKey(l)) + addVal) > 255 Then
byOut(i) = (((byIn(i) + Not bEncOrDec) Xor byKey(l)) + addVal) Mod 255 + addVal
Else
'If bEncOrDec Then
If ((byIn(i) + Not bEncOrDec) Xor byKey(l)) - addVal < 32 Then byOut(i) = ((byIn(i) + Not bEncOrDec) Xor byKey(l)) + addVal
If ((byIn(i) + Not bEncOrDec) Xor byKey(l)) - addVal > 255 Then byOut(i) = ((byIn(i) + Not bEncOrDec) Xor byKey(l)) - addVal
If ((byIn(i) + Not bEncOrDec) Xor byKey(l)) > 32 And (byIn(i) + Not bEncOrDec) Xor byKey(l) < 256 Then byOut(i) = ((byIn(i) + Not bEncOrDec) Xor byKey(l))
End If
l = l + 2
If l > UBound(byKey) Then l = LBound(byKey)
Next i
XorC = byOut
If bEncOrDec Then XorC = "xxx" & XorC 'add "xxx" onto encrypted text
End Function

Performance loss in VB.net equivalent of light weight conversion from hex to byte

I have read through the answers here https://stackoverflow.com/a/14332574/44080
I've also tried to produce equivalent VB.net code:
Option Strict ON
Public Function ParseHex(hexString As String) As Byte()
If (hexString.Length And 1) <> 0 Then
Throw New ArgumentException("Input must have even number of characters")
End If
Dim length As Integer = hexString.Length \ 2
Dim ret(length - 1) As Byte
Dim i As Integer = 0
Dim j As Integer = 0
Do While i < length
Dim high As Integer = ParseNybble(hexString.Chars(j))
j += 1
Dim low As Integer = ParseNybble(hexString.Chars(j))
j += 1
ret(i) = CByte((high << 4) Or low)
i += 1
Loop
Return ret
End Function
Private Function ParseNybble(c As Char) As Integer
If c >= "0"C AndAlso c <= "9"C Then
Return c - "0"C
End If
c = ChrW(c And Not &H20)
If c >= "A"C AndAlso c <= "F"C Then
Return c - ("A"C - 10)
End If
Throw New ArgumentException("Invalid nybble: " & c)
End Function
Can we remove the compile errors in ParseNybble without introducing data conversions?
Return c - "0"c Operator '-' is not defined for types 'Char' and 'Char'
c = ChrW(c And Not &H20) Operator 'And' is not defined for types 'Char' and 'Integer'
As it stands, no.
However, you could change ParseNybble to take an integer and pass AscW(hexString.Chars(j)) to it, so that the data conversion takes place outside of ParseNybble.
This solution is much much faster than all the alternative i have tried. And it avoids any ParseNybble lookup.
Function hex2byte(s As String) As Byte()
Dim l = s.Length \ 2
Dim hi, lo As Integer
Dim b(l - 1) As Byte
For i = 0 To l - 1
hi = AscW(s(i + i))
lo = AscW(s(i + i + 1))
hi = (hi And 15) + ((hi And 64) >> 6) * 9
lo = (lo And 15) + ((lo And 64) >> 6) * 9
b(i) = CByte((hi << 4) Or lo)
Next
Return b
End Function

Converting Numbers to Excel Letter Column vb.net

I am trying to write data to excel files using vb.net. So I my function which converts number column into excel letter columns.
Public Function ConvertToLetter(ByRef iCol As Integer) As String
Dim Reminder_Part As Integer = iCol Mod 26
Dim Integer_Part As Integer = Int(iCol / 26)
If Integer_Part = 0 Then
ConvertToLetter = Chr(Reminder_Part + 64)
ElseIf Integer_Part > 0 And Reminder_Part <> 0 Then
ConvertToLetter = Chr(Integer_Part + 64) + Chr(Reminder_Part + 64)
ElseIf Integer_Part > 0 And Reminder_Part = 0 Then
ConvertToLetter = Chr(Integer_Part * 26 + 64)
End If
End Function
The Function works ok with any other numbers.
For example,
1 => A
2 => B
...
26 => Z
27 => AA
...
51 => AY
52 => t (And here is when it start to went wrong) It is suppose to return AZ, but it returned t.
I couldn't figure out what part I made a mistake. Can someone help me or show me how to code a proper function of converting numbers to excel letter columns using vb.net.
This should do what you want.
Private Function GetExcelColumnName(columnNumber As Integer) As String
Dim dividend As Integer = columnNumber
Dim columnName As String = String.Empty
Dim modulo As Integer
While dividend > 0
modulo = (dividend - 1) Mod 26
columnName = Convert.ToChar(65 + modulo).ToString() & columnName
dividend = CInt((dividend - modulo) / 26)
End While
Return columnName
End Function
This will work up to 52.
Public Function ConvertToLetterA(ByRef iCol As Integer) As String
Select Case iCol
Case 1 To 26
Return Chr(iCol + 64)
Case 27 To 52
Return "A" & Chr(iCol - 26 + 64)
End Select
End Function
On a side note, you can write XLSX files directly with EPPlus via .Net. You can use letter notation for columns if you wish, or you can use numbers.
There are a couple flaws in the logic, the second else clause is not required and the operations should be zero based.
Public Function ConvertToLetter(ByRef iCol As Integer) As String
Dim col As Integer = iCol - 1
Dim Reminder_Part As Integer = col Mod 26
Dim Integer_Part As Integer = Int(col / 26)
If Integer_Part = 0 Then
ConvertToLetter = Chr(Reminder_Part + 65)
Else
ConvertToLetter = Chr(Integer_Part + 64) + Chr(Reminder_Part + 65)
End If
End Function

Bitwise And with Large Numbers in VBA

I keep getting an Overflow on the bitwise and in this first function. I fixed the other overflows by converting from Long to Currency (still seems weird), but I can't get this And to work.
Any ideas? I'm just trying to convert some IP addresses to CIDRs and calculate some host numbers.
Option Explicit
Public Function ConvertMaskToCIDR(someIP As String, someMask As String)
Dim ipL As Variant
ipL = iPToNum(someIP)
Dim maskL As Variant
maskL = iPToNum(someMask)
maskL = CDec(maskL)
'Convert Mask to CIDR(1-30)
Dim oneBit As Variant
oneBit = 2147483648#
oneBit = CDec(oneBit)
Dim CIDR As Integer
CIDR = 0
Dim x As Integer
For x = 31 To 0 Step -1
If (maskL And oneBit) = oneBit Then
CIDR = CIDR + 1
Else
Exit For
End If
oneBit = oneBit / 2# 'Shift one bit to the right (>> 1)
Next
Dim answer As String
answer = numToIp(ipL And maskL) & " /" & CStr(CIDR)
End Function
Public Function NumHostsInCidr(CIDR As Integer) As Currency
Dim mask As Currency
mask = maskFromCidr(CIDR)
NumHostsInCidr = iPnumOfHosts(mask)
End Function
Private Function maskFromCidr(ByVal CIDR As Integer) As Currency
'x = 32 - CIDR
'z = (2^x)-1
'return z xor 255.255.255.255
maskFromCidr = CLng(2 ^ ((32 - CIDR)) - 1) Xor 4294967295# '255.255.255.255
End Function
Private Function iPnumOfHosts(ByVal IPmsk As Currency) As Currency 'a mask for the host portion
'255.255.255.0 XOR 255.255.255.255 = 255 so 0 to 255 is 256 hosts
iPnumOfHosts = IPmsk Xor 4294967295# '255.255.255.255 , calculate the number of hosts
End Function
Private Function numToIp(ByVal theIP As Currency) As String 'convert number back to IP
Dim IPb(3) As Byte '4 octets
Dim theBit As Integer
theBit = 31 'work MSb to LSb
Dim addr As String 'accumulator for address
Dim x As Integer
For x = 0 To 3 'four octets
Dim y As Integer
For y = 7 To 0 Step -1 '8 bits
If (theIP And CLng(2 ^ theBit)) = CLng(2 ^ theBit) Then 'if the bit is on
IPb(x) = IPb(x) + CByte(2 ^ y) 'accumulate
End If
theBit = theBit - 1
Next
addr = addr & CStr(IPb(x)) & "." 'add current octet to string
Next
numToIp = trimLast(addr, ".")
End Function
Private Function iPToNum(ByVal ip As String) As Currency
Dim IPpart As Variant
Dim IPbyte(3) As Byte
IPpart = Split(ip, ".")
Dim x As Integer
For x = 0 To 3
IPbyte(x) = CByte(IPpart(x))
Next x
iPToNum = (IPbyte(0) * (256 ^ 3)) + (IPbyte(1) * (256 ^ 2)) + (IPbyte(2) * 256#) + IPbyte(3)
End Function
Private Function trimLast(str As String, chr As String)
'****
'* Remove "chr" (if it exists) from end of "str".
'****
trimLast = str
If Right(str, 1) = chr Then trimLast = Left(str, Len(str) - 1)
End Function
Whoah,
it is definitelly interesting functionality. But I would do this in very different way. I would treat IP adress and Mask as array of four bytes. Moreover as far as I remeber (well it was some time ago) CIDR and mask can be converted to each other in very simply way (did you looked at the table?). Why don't you apply bitwise operations to each byte separatelly?
BR.
edit: ok I looked closer at the code. The reason why it is overflowing is that you can't use currency and and. I think and is internally defined as Long and can't return any bigger values. It is very common in other languages too. I remember that once I had this problem in other language (Pascal?). You can try to replace and by division. It will be slow but it can't be matter here I suppose. Other solution is, like I wrote, to treat those valueas all the time as byte arrays and perform bitwise operations on each byte.
This is an entirely mathematical approach to working with IPv4 addresses in VBA (Excel specifically).
The first three functions are serving a strictly supporting role.
Support #1:
Public Function RoundDouble(ByVal Number As Double, ByVal Places As Long) As Double
On Error GoTo Err_RoundDouble
Dim i As Long
Dim j As Long
i = 0
j = 0
While Number < -(2 ^ 14)
Number = Number + (2 ^ 14)
i = i - 1
Wend
While Number > (2 ^ 14)
Number = Number - (2 ^ 14)
i = i + 1
Wend
While Number < -(2 ^ 5)
Number = Number + (2 ^ 5)
j = j - 1
Wend
While Number > (2 ^ 5)
Number = Number - (2 ^ 5)
j = j + 1
Wend
RoundDouble = Round(Number, Places) + (i * (2 ^ 14)) + (j * (2 ^ 5))
Exit_RoundDouble:
Exit Function
Err_RoundDouble:
MsgBox Err.Description
Resume Exit_RoundDouble
End Function
Support #2:
Public Function RoundDownDouble(ByVal Number As Double, ByVal Places As Long) As Double
On Error GoTo Err_RoundDownDouble
Dim i As Double
i = RoundDouble(Number, Places)
If Number < 0 Then
If i < Number Then
RoundDownDouble = i + (10 ^ -Places)
Else
RoundDownDouble = i
End If
Else
If i > Number Then
RoundDownDouble = i - (10 ^ -Places)
Else
RoundDownDouble = i
End If
End If
Exit_RoundDownDouble:
Exit Function
Err_RoundDownDouble:
MsgBox Err.Description
Resume Exit_RoundDownDouble
End Function
Support #3
Public Function ModDouble(ByVal Number As Double, ByVal Divisor As Double) As Double
On Error GoTo Err_ModDouble
Dim rndNumber As Double
Dim rndDivisor As Double
Dim intermediate As Double
rndNumber = RoundDownDouble(Number, 0)
rndDivisor = RoundDownDouble(Divisor, 0)
intermediate = rndNumber / rndDivisor
ModDouble = (intermediate - RoundDownDouble(intermediate, 0)) * rndDivisor
Exit_ModDouble:
Exit Function
Err_ModDouble:
MsgBox Err.Description
Resume Exit_ModDouble
End Function
This first function will convert a Double back into an IP address.
Public Function NUMtoIP(ByVal Number As Double) As String
On Error GoTo Err_NUMtoIP
Dim intIPa As Double
Dim intIPb As Double
Dim intIPc As Double
Dim intIPd As Double
If Number < 0 Then Number = Number * -1
intIPa = RoundDownDouble(ModDouble(Number, (2 ^ 32)) / (2 ^ 24), 0)
intIPb = RoundDownDouble(ModDouble(Number, (2 ^ 24)) / (2 ^ 16), 0)
intIPc = RoundDownDouble(ModDouble(Number, (2 ^ 16)) / (2 ^ 8), 0)
intIPd = ModDouble(Number, (2 ^ 8))
NUMtoIP = intIPa & "." & intIPb & "." & intIPc & "." & intIPd
Exit_NUMtoIP:
Exit Function
Err_NUMtoIP:
MsgBox Err.Description
Resume Exit_NUMtoIP
End Function
This second function is strictly to convert from IPv4 dotted octet format to a Double.
Public Function IPtoNUM(ByVal IP_String As String) As Double
On Error GoTo Err_IPtoNUM
Dim intIPa As Integer
Dim intIPb As Integer
Dim intIPc As Integer
Dim intIPd As Integer
Dim DotLoc1 As Integer
Dim DotLoc2 As Integer
Dim DotLoc3 As Integer
Dim DotLoc4 As Integer
DotLoc1 = InStr(1, IP_String, ".", vbTextCompare)
DotLoc2 = InStr(DotLoc1 + 1, IP_String, ".", vbTextCompare)
DotLoc3 = InStr(DotLoc2 + 1, IP_String, ".", vbTextCompare)
DotLoc4 = InStr(DotLoc3 + 1, IP_String, ".", vbTextCompare)
If DotLoc1 > 1 And DotLoc2 > DotLoc1 + 1 And _
DotLoc3 > DotLoc2 + 1 And DotLoc4 = 0 Then
intIPa = CInt(Mid(IP_String, 1, DotLoc1))
intIPb = CInt(Mid(IP_String, DotLoc1 + 1, DotLoc2 - DotLoc1))
intIPc = CInt(Mid(IP_String, DotLoc2 + 1, DotLoc3 - DotLoc2))
intIPd = CInt(Mid(IP_String, DotLoc3 + 1, 3))
If intIPa <= 255 And intIPa >= 0 And intIPb <= 255 And intIPb >= 0 And _
intIPc <= 255 And intIPc >= 0 And intIPd <= 255 And intIPd >= 0 Then
IPtoNUM = (intIPa * (2 ^ 24)) + (intIPb * (2 ^ 16)) + _
(intIPc * (2 ^ 8)) + intIPd
Else
IPtoNUM = 0
End If
Else
IPtoNUM = 0
End If
Exit_IPtoNUM:
Exit Function
Err_IPtoNUM:
MsgBox Err.Description
Resume Exit_IPtoNUM
End Function
Next we have the conversion from an IPv4 address to it's bitmask representation (assuming that the source entry is a string containing only the dotted octet format of the subnet mask).
Public Function IPtoBitMask(ByVal strIP_Address As String) As Integer
On Error GoTo Err_IPtoBitMask
IPtoBitMask = (32 - Application.WorksheetFunction.Log((2 ^ 32 - IPtoNUM(strIP_Address)), 2))
Exit_IPtoBitMask:
Exit Function
Err_IPtoBitMask:
MsgBox Err.Description
Resume Exit_IPtoBitMask
End Function
This last one is to convert a bitmask back into dotted octet format.
Public Function BitMasktoIP(ByVal intBit_Mask As Integer) As String
On Error GoTo Err_BitMasktoIP
BitMasktoIP = NUMtoIP((2 ^ 32) - (2 ^ (32 - intBit_Mask)))
Exit_BitMasktoIP:
Exit Function
Err_BitMasktoIP:
MsgBox Err.Description
Resume Exit_BitMasktoIP
End Function
Edited to remove leftover debugging code (it's been working for me so long, that I had entirely forgotten about it).
As an aside, it is faster to perform mathematical operations on a computer than it is to work with a string.
This was my "cheating" way:
Option Explicit
Public Function ConvertMaskToCIDR(varMask As Variant) As String
Dim strCIDR As String
Dim mask As String
mask = CStr(varMask)
Select Case mask
Case "255.255.255.255":
strCIDR = "/32"
Case "255.255.255.254":
strCIDR = "/31"
Case "255.255.255.252":
strCIDR = "/30"
Case "255.255.255.248":
strCIDR = "/29"
Case "255.255.255.240":
strCIDR = "/28"
Case "255.255.255.224":
strCIDR = "/27"
Case "255.255.255.192":
strCIDR = "/26"
Case "255.255.255.128":
strCIDR = "/25"
Case "255.255.255.0":
strCIDR = "/24"
Case "255.255.254.0":
strCIDR = "/23"
Case "255.255.252.0":
strCIDR = "/22"
Case "255.255.248.0":
strCIDR = "/21"
Case "255.255.240.0":
strCIDR = "/20"
Case "255.255.224.0":
strCIDR = "/19"
Case "255.255.192.0":
strCIDR = "/18"
Case "255.255.128.0":
strCIDR = "/17"
Case "255.255.0.0":
strCIDR = "/16"
Case "255.254.0.0":
strCIDR = "/15"
Case "255.252.0.0":
strCIDR = "/14"
Case "255.248.0.0":
strCIDR = "/13"
Case "255.240.0.0":
strCIDR = "/12"
Case "255.224.0.0":
strCIDR = "/11"
Case "255.192.0.0":
strCIDR = "/10"
Case "255.128.0.0":
strCIDR = "/9"
Case "255.0.0.0":
strCIDR = "/8"
Case "254.0.0.0":
strCIDR = "/7"
Case "252.0.0.0":
strCIDR = "/6"
Case "248.0.0.0":
strCIDR = "/5"
Case "240.0.0.0":
strCIDR = "/4"
Case "224.0.0.0":
strCIDR = "/3"
Case "192.0.0.0":
strCIDR = "/2"
Case "128.0.0.0":
strCIDR = "/1"
Case "0.0.0.0":
strCIDR = "/0"
End Select
ConvertMaskToCIDR = strCIDR
End Function
Public Function NumUsableIPs(cidr As String) As Long
Dim strHosts As String
If Len(cidr) > 3 Then
'They probably passed a whole address.
Dim slashIndex As String
slashIndex = InStr(cidr, "/")
If slashIndex = 0 Then
NumUsableIPs = 1
Exit Function
End If
cidr = Right(cidr, Len(cidr) - slashIndex + 1)
End If
Select Case cidr
Case "/32":
strHosts = 1
Case "/31":
strHosts = 0
Case "/30":
strHosts = 2
Case "/29":
strHosts = 6
Case "/28":
strHosts = 14
Case "/27":
strHosts = 30
Case "/26":
strHosts = 62
Case "/25":
strHosts = 126
Case "/24":
strHosts = 254
Case "/23":
strHosts = 508
Case "/22":
strHosts = 1016
Case "/21":
strHosts = 2032
Case "/20":
strHosts = 4064
Case "/19":
strHosts = 8128
Case "/18":
strHosts = 16256
Case "/17":
strHosts = 32512
Case "/16":
strHosts = 65024
Case "/15":
strHosts = 130048
Case "/14":
strHosts = 195072
Case "/13":
strHosts = 260096
Case "/12":
strHosts = 325120
Case "/11":
strHosts = 390144
Case "/10":
strHosts = 455168
Case "/9":
strHosts = 520192
Case "/8":
strHosts = 585216
Case "/7":
strHosts = 650240
Case "/6":
strHosts = 715264
Case "/5":
strHosts = 780288
Case "/4":
strHosts = 845312
Case "/3":
strHosts = 910336
Case "/2":
strHosts = 975360
Case "/1":
strHosts = 1040384
End Select
NumUsableIPs = strHosts
End Function