Xor algorithm with no special characters using VBA - 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

Related

How to fix error "Arithmetic operation resulted in an overflow"

Whenever I want to find out a grade in the program I made.
It highlights the statement k = k + 1 and says:
Arithmetic operation resulted in an overflow
Can someone help?
Sub SearchStudentData()
Dim Sname, G As String
Dim Lname, Lgradetext, position, j, k, position1 As Integer
Dim gradefile As IO.StreamReader
Dim Valid As Boolean
Valid = False
Console.WriteLine("Enter the name of the student of whom you want the grade!")
Sname = Console.ReadLine()
Lname = Len(Sname)
gradefile = New IO.StreamReader("D:\Grades.txt")
Do Until gradefile.EndOfStream
gradetext = gradefile.ReadLine()
Lgradetext = Len(gradetext)
j = 0
k = 0
Do
k = k + 1 'It highlights this line of code
position1 = k
Loop Until Mid(gradetext, k, 1) = ":"
Do
j = j + 1
position = j
Loop Until Mid(Lgradetext, j, 1) = ","
If Sname = Right(gradetext, position1 + 1) And Sname = Left(gradetext, position - 1) Then
Valid = True
End If
If Valid = True Then
G = Right(Lgradetext, Lgradetext - 1)
Console.WriteLine(G)
Else
Valid = False
Console.WriteLine("Ypu have failed this PROGRAM")
End If
Loop
gradefile.Close()
End Sub
Your input is not what you expected. The line from your file has no ":" or "," in it, resulting in an infinite loop, and eventually the error when the counter goes past the max. You could use String.IndexOf() to determine if the value is present, instead of a loop. When the value is not present, -1 will be returned. Here's an example:
Dim indexOfColon As Integer = gradetext.IndexOf(":")
Dim indexOfComma As Integer = gradetext.IndexOf(",")
If indexOfColon <> -1 AndAlso indexOfComma <> -1 Then
' ... both ":" and "," were present in the string, do something with those values ...
End If

How can I convert these inelegant formulae into VBA?

Good people of Stackland
I'm analysing strings comprised of 5 alpha chars which in their raw format look like this;
A2) BCDBE
A3) TLDPP
A4) FGGFC
A5) BBGBB
I need a way of evaluating each character to identify patterns within the strings themselves, eg repeating letters. I want to represent these patterns as follows, where the 1st letter is always given as "A", the 2nd "B"...;
A2) BCDBE --> ABCAD
A3) TLDPP --> ABCDD
A4) FGGFC --> ABBAC
A5) BBGBB --> AABAA
Now, I have achieved this with some pretty inelegant conditional formulae but had to do this to evaluate each character individually, as follows;
1) =IF(LEFT(A2,1)>0,"A")
2) =IF(MID(A2,2,1)=LEFT(A2,1),"A","B")
3) =IF(MID(A2,3,1)=LEFT(A2,1),"A",IF(MID(A2,3,1)=MID(A2,2,1),M2,CHAR(CODE(M2)+1)))
4) =IF(MID(A2,4,1)=LEFT(A2,1),"A",IF(MID(A2,4,1)=MID(A2,2,1),M2,IF(MID(A2,4,1)=MID(A2,3,1),N2,CHAR(MAX(CODE(L2:N2)+1)))))
5) =IF(MID(A2,5,1)=LEFT(A2,1),"A",IF(MID(A2,5,1)=MID(A2,2,1),M2,IF(MID(A2,5,1)=MID(A2,3,1),N2,IF(MID(A2,5,1)=MID(A2,4,1),O2,CHAR(MAX(CODE(L2:O2)+1))))))
Translated...
1) Call the first character "A"
2) If the 2nd character is the same as the same as the 1st call it "A", otherwise cause it "B"
3) If the 3rd character is the same as the 1st call it "A", if it's the same as the 2nd call it whatever the 2nd is, if not give it the value of the next letter, ie "C"
4) If the 4th character is the same as the 1st, call it "A", if it's the sames as the 2nd call it whatever the 2nd is, if it's the same as the 3rd call it whatever the 3rd is, if not then call it the next letter in the alphabet, ie "D"
5) If the 5th character is the same as the 1st, call it "A", if it's the same as the 2nd call it whatever the 2nd is, if it's the same as the 3rd call it whatever the 3rd is called, if it's the same as the 4th call it whatever the 4th is called, if not then call it the next letter in the alphabet, ie "E"
I'm doing this over 5 cols, one formula per col, and the concatenating the 5 results into one cell to get AABAA or whatever.
I just need to know if there's a nice, clean VBA solution to this.
Any ideas?
Here is the a Function to do the letter instead of numbers:
Function findPattern(inputStr As String) As String
Dim i As Integer
Dim t As Integer
t = 1
For i = 1 To 5 Step 1
If Asc(Mid(inputStr, i, 1)) > 54 Then
inputStr = Replace(inputStr, Mid(inputStr, i, 1), t)
t = t + 1
End If
Next i
For i = 1 To 5
inputStr = Replace(inputStr, i, Chr(i + 64))
Next i
findPattern = inputStr
End Function
Put it in a module attached to the workbook, and you can call it thus:
=findPattern(A2)
Driectly from the worksheet where A2 is the cell you want tested.
Or from vba:
Sub test()
Dim str as string
str = findPattern(Range("A2").value)
debug.print str
End Sub
Edit: By your Comment I assume you have more than just the first 5 characters that you want left original. If that is the case use this:
Function findPattern(Str As String) As String
Dim inputStr As String
Dim i As Integer
Dim t As Integer
inputStr = Left(Str, 5)
t = 1
For i = 1 To 5 Step 1
If Asc(Mid(inputStr, i, 1)) > 54 Then
inputStr = Replace(inputStr, Mid(inputStr, i, 1), t)
t = t + 1
End If
Next i
For i = 1 To 5
inputStr = Replace(inputStr, i, Chr(i + 64))
Next i
'This is the return line. As is it will only return 5 characters.
'If you want the whole string with only the first five as the pattern
'Remove the single quote in the middle of the string.
findPattern = inputStr '& Mid(Str, 6, (Len(Str)))
End Function
This seems like an easy approach:
's is the input string
dim pos, c, s_new, s_old
pos = 1 : c = 49
s_new = mid(s, 1, 5) ' take only first five characters
do while pos <= 5
s_old = s_new
s_new = replace(s_new, mid(s, pos, 1), chr(c))
if s_new <> s_old then c = c + 1
loop
s_new = replace(s_new, "1", "A")
s_new = replace(s_new, "2", "B")
s_new = replace(s_new, "3", "C")
s_new = replace(s_new, "4", "D")
s_new = replace(s_new, "5", "E")
'm assuming that you don't have any numeric characters in your input.
This has a certain elegance:
Function Pattern(r As Range)
Dim c&, i&, a
Const FORMULA = "iferror(find(mid(~,{2,3,4,5},1),left(~,{1,2,3,4})),)"
a = Evaluate(Replace(FORMULA, "~", r.Address))
c = 1: Pattern = "A"
For i = 1 To 4
If a(i) = 0 Then c = c + 1: a(i) = c
Pattern = Pattern & Chr$(64 + a(i))
Next
End Function
I had this for a while (it's handy for cryptograms), so I'll post it:
Function Pattern(ByVal sInp As String) As String
' shg 2012
' Returns the pattern of a string as a string of the same length
' First unique letter and all repeats is a, second is b, …
' E.g., Pattern("mississippi") returns "abccbccbddb"
Dim iChr As Long ' character index to sInp & Pattern
Dim sChr As String ' character in sInp
Dim iPos As Long ' position of first appearance of sChr in sInp
sInp = LCase(Trim(sInp))
If Len(sInp) Then
sChr = Chr(64)
Pattern = sInp
For iChr = 1 To Len(sInp)
iPos = InStr(sInp, Mid(sInp, iChr, 1))
If iPos = iChr Then ' it's new
sChr = Chr(Asc(sChr) + 1)
Mid(Pattern, iChr) = sChr
Else
Mid(Pattern, iChr) = Mid(Pattern, iPos, 1)
End If
Next iChr
End If
End Function

Cannot create algorithm for a sequence in VBA

After hours of work I give up as I do not see the solution anymore.
I therefore ask for your help to create following sequence:
for example given is the start code: 6D082A
The 1st position ("A") is from an array with 16 elements in this sequence:
Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
the 3rd to 5th position (082) has values from 000 to 999
the 2nd position ("D") has values from "A" to "Z"
the 1st position (6) has values from 1-9
So the sequence from the example code above is:
6D082A
6D082B
6D082C
..
6D082F
6D0830
6D0831
....
6D083F
6D0840
...
6D999F
6E0000
....
6Z999F
7A0000
....
9Z999F which is the absolut last code in this sequence
Whith all the loops within the counters I am lost!
At the end the user should also enter the given first code and the number of codes he wants.
My last trial was (without any start-code and any variable number of codes to create.
Sub Create_Barcodes_neu2()
Dim strErsterBC As String
Dim intRow As Integer
Dim str6Stelle As Variant
Dim intStart6 As Integer
Dim str6 As String
Dim i As Integer, ii As Integer, Index As Integer
'On Error Resume Next
Dim v As Variant
str6Stelle = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F") '16 Elemente
strErsterBC = InputBox("Enter the first Barcode.", "Barcode-Generator")
intRow = InputBox("Enter the number of barcodes to create.", "Barcode-Generator")
intStart6 = ListIndex(Mid(strErsterBC, 6, 1), str6Stelle)
str35stelle = CInt(Mid(strErsterBC, 3, 3)) 'Zahl 000-999
str2stelle = Mid(strErsterBC, 2, 1) letters A-Z
str1stelle = Left(strErsterBC, 1)
'Debug.Print str6Stelle(1); vbTab; str6Stelle(2); vbTab; str6Stelle(15); vbTab; str6Stelle(16)
For Z = 0 To 32
ausgabe6 = i + intStart6
i = i + 1
ausgabe35 = str35stelle
ausgabe2 = i3
ausgabe1 = i4
If i = 16 Then
i = 0
i2 = i2 + 1
ausgabe35 = i2 + str35stelle
If i2 = 999 Then
ausgabe35 = 999
i2 = 0
i3 = i3 + 1
If i3 = 26 Then
ausgabe2 = 26
i3 = 1
i4 = i4 + 1
If i4 > 9 Then
MsgBox "Ende"
Exit Sub
End If
End If
End If
End If
st6 = str6Stelle(ausgabe6)
st35 = Format(ausgabe35, "000")
ausgabe2 = Chr(i3)
ausgabe1 = i4
Next Z
End Sub
Hope you can help me in my solution!
Thanks a lot!
Michael
The approach to the right algorithm is to think of a number in the following way:
Let's take a normal decimal 3-digit number. Each digit can take one element of an ordered set of symbols, 0-9.
To add 1 to this number, we exchange the rightmost symbol for the next symbol (2 becomes 3 etc.) - but if it is already the 'highest' possible symbol ("9"),
then reset it to the first possible symbol ("0"), and increase the next digit to the left by one.
So 129 becomes 130, and 199 has two carrying overflows and becomes 200. If we had 999 and tried and inc by one, we'd have a final overflow.
Now this can be easily done with any set of symbols, and they can be completely different for every digit.
In the code, you store the symbol sets for every digit. And the "number" itself is stored as an array of indexes, pointing to which symbol is
used at each position. These indexes can easily be increased.
In case of an overflow for a single digit, the function IncByOne is called recursively for the next position to the left.
This is code for a class clSymbolNumber
Option Explicit
' must be a collection of arrays of strings
Public CharacterSets As Collection
' <code> must contain integers, the same number of elements as CharacterSets
' this is the indices for each digit in the corresponding character-set
Public code As Variant
Public overflowFlag As Boolean
Public Function IncByOne(Optional position As Integer = -1) As Boolean
IncByOne = True
If position = -1 Then position = CharacterSets.Count - 1
' overflow at that position?
If code(position) = UBound(CharacterSets(position + 1)) Then
If position = 0 Then
overflowFlag = True
IncByOne = False
Exit Function
Else
' reset this digit to lowest symbol
code(position) = 0
' inc the position left to this
IncByOne = IncByOne(position - 1)
Exit Function
End If
Else
code(position) = code(position) + 1
End If
End Function
Public Sub class_initialize()
overflowFlag = False
Set CharacterSets = New Collection
End Sub
Public Function getCodeString() As String
Dim i As Integer
Dim s As String
s = ""
For i = 0 To UBound(code)
s = s & CharacterSets(i + 1)(code(i))
Next
getCodeString = s
End Function
Testing sub in a worksheet module - this outputs all possible "numbers" with the given test data.
Sub test()
Dim n As New clSymbolNumber
n.CharacterSets.Add Array("1", "2", "3")
n.CharacterSets.Add Array("a", "b")
n.CharacterSets.Add Array("A", "B", "C", "D")
n.CharacterSets.Add Array("1", "2", "3")
' start code (indexes)
n.code = Array(0, 0, 0, 0)
' output all numbers until overflow
Dim row As Long
row = 2
Me.Columns("A").ClearContents
While Not n.overflowFlag
Me.Cells(row, "A") = n.getCodeString
n.IncByOne ' return value not immediately needed here
row = row + 1
DoEvents
Wend
MsgBox "done"
End Sub
I'm not sure if this is what you're looking for:
Option Explicit
Const MAX_FIRST_DEC_NUMBER As Integer = 9
Const MAX_MIDDLE_DEC_NUMBER As Integer = 999
Const MAX_LAST_HEX_NUMBER As Long= &HF
Sub Makro()
Dim codes() As String
Dim startCode As String
Dim numOfBarcodes As Integer
startCode = "0A0000" ' Starting with the "lowest" barcode
' Maximum number of barcodes = 4,160,000 because:
'0-9' * 'A-Z' * '0-9' * '0-9' * '0-9' * 'A-F'
numOfBarcodes = CLng(10) * CLng(26) * CLng(10) * CLng(10) * CLng(10) * CLng(16)
codes = CreateBarcodes(startCode , numOfBarcodes)
Dim i As Integer
For i = 0 To numOfBarcodes - 1
Debug.Print codes(i)
Next
End Sub
' NOTE: Given "9Z999F" as start code will give you a numberOfBarcodes-sized array with
' one valid barcode. The rest of the array will be empty. There is room for improvement.
Function CreateBarcodes(ByVal start As String, ByVal numberOfBarcodes As Long) As String()
' TODO: Check if "start" is a valid barcode
' ...
' Collect barcodes:
Dim firstDecNumber As Integer
Dim char As Integer
Dim middleDecNumber As Integer
Dim lastLetter As Integer
ReDim barcodes(0 To numberOfBarcodes - 1) As String
For firstDecNumber = Left(start, 1) To MAX_FIRST_DEC_NUMBER Step 1
For char = Asc(Mid(start, 2, 1)) To Asc("Z") Step 1
For middleDecNumber = CInt(Mid(start, 3, 3)) To MAX_MIDDLE_DEC_NUMBER Step 1
For lastLetter = CInt("&H" + Mid(start, 6, 1)) To MAX_LAST_HEX_NUMBER Step 1
numberOfBarcodes = numberOfBarcodes - 1
barcodes(numberOfBarcodes) = CStr(firstDecNumber) + Chr(char) + Format(middleDecNumber, "000") + Hex(lastLetter)
If numberOfBarcodes = 0 Then
CreateBarcodes = barcodes
Exit Function
End If
Next
Next
Next
Next
CreateBarcodes = barcodes
End Function
Output:
9Z999F
9Z999E
9Z999D
...
1A0001
1A0000
0Z999F
0Z999E
...
0B0002
0B0001
0B0000
0A999F
0A999E
...
0A0011
0A0010
0A000F
0A000E
...
0A0003
0A0002
0A0001
0A0000

Error throwing on Target CPU: x86

I got a problem with this function i use to retrieve the product key from my computer.
Public Function GetProductKey(ByVal KeyPath As String, ByVal ValueName As String) As String
Dim HexBuf As Object = My.Computer.Registry.GetValue(KeyPath, ValueName, 0)
If HexBuf Is Nothing Then Return "N/A"
Dim tmp As String = String.Empty
For l As Integer = LBound(CType(HexBuf, Array)) To UBound(CType(HexBuf, Array))
tmp = tmp & " " & Hex(CByte(AscW(HexBuf.ToString(1))))
Next
Dim StartOffset As Integer = 52
Dim EndOffset As Integer = 67
Dim Digits(24) As String
Digits(0) = "B" : Digits(1) = "C" : Digits(2) = "D" : Digits(3) = "F"
Digits(4) = "G" : Digits(5) = "H" : Digits(6) = "J" : Digits(7) = "K"
Digits(8) = "M" : Digits(9) = "P" : Digits(10) = "Q" : Digits(11) = "R"
Digits(12) = "T" : Digits(13) = "V" : Digits(14) = "W" : Digits(15) = "X"
Digits(16) = "Y" : Digits(17) = "2" : Digits(18) = "3" : Digits(19) = "4"
Digits(20) = "6" : Digits(21) = "7" : Digits(22) = "8" : Digits(23) = "9"
Dim dLen As Integer = 29
Dim sLen As Integer = 15
Dim HexDigitalPID(15) As String
Dim Des(30) As String
Dim tmp2 As String = String.Empty
Dim notbuffer As Array = CType(HexBuf, Array)
For i = StartOffset To EndOffset
HexDigitalPID(i - StartOffset) = notbuffer.GetValue(i).ToString
tmp2 = tmp2 & " " & Hex(HexDigitalPID(i - StartOffset))
Next
Dim KEYSTRING As String = String.Empty
For i As Integer = dLen - 1 To 0 Step -1
If ((i + 1) Mod 6) = 0 Then
Des(i) = "-"
KEYSTRING = KEYSTRING & "-"
Else
Dim HN As Integer = 0
For N As Integer = (sLen - 1) To 0 Step -1
Dim Value As Integer = CInt(CLng((HN * 2 ^ 8)) Or CLng(HexDigitalPID(N)))
HexDigitalPID(N) = (Value \ 24).ToString
HN = (Value Mod 24)
Next
Des(i) = Digits(HN)
KEYSTRING = KEYSTRING & Digits(HN)
End If
Next
Return StrReverse(KEYSTRING)
End Function
This works well if i compile using x64 or AnyCPU architecture, but if i put x86 (which is what i want) it throws me this error:
http://i.imgur.com/Kfpa7mh.png
It says: "Cannot associate the object type System.Int32 to System.Array"
I can't figure out the problem, i can't do a for Next with that arguments?
Why this works with x64 and AnyCPU (Still x64 since i got a 64-bit OS) and not x86?
Thanks.

Descrypt SagePay string 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