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.
Related
Here's the code I am not sure if there's any hidden error but on runtime when trying to import the rsa parameters it pops up that error
Imports System.Security.Cryptography
Imports System.Security
Imports System.Text
Imports System.IO
Public Class RSA_Test_Form
Public FactorList As New List(Of Integer)
Public FindFactor As Long
Public PString, QString, ModulusString, ExponentString, DString, DPString,
DQString, InverseQString As String
Function ModInverse(ByVal a As Long, ByVal b As Long) As Long
Dim b0 As Long = b
Dim t As Long
Dim q As Long
Dim x0 As Long = 0
Dim x1 As Long = 1
If b = 1 Then Return 1
While a > 1
q = a \ b
t = b
b = a Mod b
a = t
t = x0
x0 = x1 - q * x0
x1 = t
End While
If x1 < 0 Then x1 += b0
Return x1
End Function
Function gcd(ByVal n1 As Long, ByVal n2 As Long) As Long
Dim i As Integer
Dim minimum As Integer
If n1 < n2 Then
minimum = n1
Else
minimum = n2
End If
For i = minimum To 1 Step -1
If n1 Mod i = 0 And n2 Mod i = 0 Then
Return i
End If
Next
Return gcd
End Function
Sub FindFactorFunction()
Dim x As Long
For x = 2 To FindFactor - 1
If FindFactor Mod x = 0 Then
FactorList.Add(x)
End If
Next
End Sub
Private Sub GenerateBTN_Click(sender As Object, e As EventArgs) Handles GenerateBTN.Click
Dim Result As Long = 0
Dim Result2 As Long = 0
Dim Result3 As Long = 0
Dim Random1, Random2 As New Random()
Dim P, Q, Modulus As Long
Dim Exponent, D, DP, DQ As New Nullable(Of Long)
Dim InverseQ As New Nullable(Of ULong)
Dim Modulus1 As Long = 0
Dim LoopCount As Integer = 0
Dim ls, ls2 As New List(Of Long)
Dim PrimeString As String
PrimeString = ""
Using MyNewStreamReader As StreamReader = New StreamReader("AllPrimes.txt")
PrimeString = MyNewStreamReader.ReadLine().ToString
MessageBox.Show(PrimeString)
While PrimeString <> "" And LoopCount <= 1249
ls.Add(Long.Parse(PrimeString))
LoopCount += 1
PrimeString = ""
PrimeString = MyNewStreamReader.ReadLine
End While
End Using
Using MyNewStreamReader2 As StreamReader = New StreamReader("AllPrimes.txt")
PrimeString = ""
PrimeString = MyNewStreamReader2.ReadLine().ToString
LoopCount = 0
MessageBox.Show(PrimeString)
While PrimeString <> ""
If LoopCount >= 1250 And LoopCount <= 2499 Then
ls2.Add(Long.Parse(PrimeString))
End If
LoopCount += 1
PrimeString = ""
PrimeString = MyNewStreamReader2.ReadLine
End While
End Using
Dim rand = Random1.Next(0, ls.Count)
Dim rand2 = Random2.Next(0, ls2.Count)
P = ls(rand)
Q = ls2(rand2)
Result3 = gcd(P, Q)
While Result3 <> 1
rand = Random1.Next(0, ls.Count)
rand2 = Random2.Next(0, ls2.Count)
P = ls(rand)
Q = ls2(rand2)
Result3 = gcd(P, Q)
End While
MessageBox.Show("P= " & P & "Q= " & Q)
Modulus = (P - 1) * (Q - 1)
Modulus1 = Modulus + 1
FindFactor = Modulus1
FindFactorFunction()
Dim Count As Integer = 0
Dim Count2 As Integer = 0
For A As Integer = 0 To FactorList.Count - 1
Result = gcd(FactorList.ElementAt(A), Modulus)
If Result = 1 Then
Count += 1
End If
Next
Dim PositionArray(Count) As Integer
Count = 0
For A As Integer = 0 To FactorList.Count - 1
Result = gcd(FactorList.ElementAt(A), Modulus)
If Result = 1 Then
PositionArray(Count) = FactorList.ElementAt(A)
Count += 1
End If
Next
Dim Number1, Number2 As Long
Dim GetResult As Boolean = False
Count = 0
If PositionArray.Count = 2 Then
Exponent = PositionArray(0)
D = PositionArray(1)
Else
While GetResult = False And Count <> PositionArray.Count
For Count = 0 To PositionArray.Count - 1
For Count2 = Count + 1 To PositionArray.Count - 1
Number1 = PositionArray(Count)
Number2 = PositionArray(Count2)
Result2 = Number1 * Number2 Mod Modulus
If Result2 = 1 Then
GetResult = True
End If
If GetResult = True Then
Exit While
End If
Next
Next
End While
End If
Dim Selection As Integer = MessageBox.Show(Number1 & "=E And D= " & Number2, "Information", MessageBoxButtons.OKCancel, MessageBoxIcon.Information)
If Selection = DialogResult.OK Then
Exponent = Number1
D = Number2
DP = D * P
DQ = D * Q
InverseQ = ModInverse(Q, P)
MessageBox.Show("DP= " & DP)
MessageBox.Show("DQ= " & DQ)
MessageBox.Show("InverseQ= " & InverseQ)
In here when generating RSA numbers, I can not always get the correct numbers so i am using this website to check that i have get the correct RSA numbers and the D and Exponent was not = 0
Exponent=e
Everytime I get Exponent and D, I will always use this website to check P,Q,Exponent and D to make sure it's correct
https://www.cs.drexel.edu/~jpopyack/IntroCS/HW/RSAWorksheet.html
End If
If Exponent.HasValue And D.HasValue Then
PString = P.ToString
QString = Q.ToString
ModulusString = Modulus.ToString
ExponentString = Exponent.ToString
DString = D.ToString
DPString = DP.ToString
DQString = DQ.ToString
InverseQString = InverseQ.ToString
In here all D,P,Q,DP,DQ,Exponent,Modulus,InverseQ value has been calculated and checked
End If
End Sub
Private Sub Number2ByteConverterBTN_Click(sender As Object, e As EventArgs) Handles Number2ByteConverterBTN.Click
If it's possible try check the coding here, perhaps this place was the place that i do it wrongly
I initially thought of using BitCoverter.GetBytes() to convert the long and Ulong datatype value
But in the end, the bitconverter.getbytes() doesn't work for me so i have to first convert all those long and ulong data type values into string then use BYTE.PARSE() to convert the string into byte value
That's how i do it
If let's any experts here confirmed that the coding above worked and all the values are correct then try to check is there any potential error here
Dim PByte, QByte, ModulusByte, ExponentByte, DByte, DPByte, DQByte, InverseQByte As Byte()
ReDim PByte(PString.Count)
ReDim QByte(QString.Count)
ReDim ModulusByte(ModulusString.Count)
ReDim ExponentByte(ExponentString.Count)
ReDim DByte(DString.Count)
ReDim DPByte(DPString.Count)
ReDim DQByte(DQString.Count)
ReDim InverseQByte(InverseQString.Count)
Dim TempPByte, TempQByte, TempModulusByte, TempExponentByte, TempDByte As New Byte
Dim StringBuilder As New StringBuilder
Dim StringBuilder2 As New StringBuilder
Dim StringBuilder3 As New StringBuilder
Dim StringBuilder4 As New StringBuilder
Dim StringBuilder5 As New StringBuilder
Dim StringBuilder6 As New StringBuilder
Dim StringBuilder7 As New StringBuilder
Dim StringBuilder8 As New StringBuilder
For i As Integer = 0 To PString.Length - 1
PByte(i) = Byte.Parse(PString.ElementAt(i))
StringBuilder.Append(PByte(i).ToString)
Next
For i As Integer = 0 To QString.Length - 1
QByte(i) = Byte.Parse(QString.ElementAt(i))
StringBuilder2.Append(QByte(i).ToString)
Next
For i As Integer = 0 To ModulusString.Length - 1
ModulusByte(i) = Byte.Parse(ModulusString.ElementAt(i))
StringBuilder3.Append(ModulusByte(i).ToString)
Next
For i As Integer = 0 To ExponentString.Length - 1
ExponentByte(i) = Byte.Parse(ExponentString.ElementAt(i))
StringBuilder4.Append(ExponentByte(i).ToString)
Next
For i As Integer = 0 To DString.Length - 1
DByte(i) = Byte.Parse(DString.ElementAt(i))
StringBuilder5.Append(DByte(i).ToString)
Next
For i As Integer = 0 To DPString.Length - 1
DPByte(i) = Byte.Parse(DPString.ElementAt(i))
StringBuilder6.Append(DPByte(i).ToString)
Next
For i As Integer = 0 To DQString.Length - 1
DQByte(i) = Byte.Parse(DQString.ElementAt(i))
StringBuilder7.Append(DQByte(i).ToString)
Next
For i As Integer = 0 To InverseQString.Length - 1
InverseQByte(i) = Byte.Parse(InverseQString.ElementAt(i))
StringBuilder8.Append(InverseQByte(i).ToString)
Next
Dim MyRSAParams As New RSAParameters
MyRSAParams.P = PByte
MyRSAParams.Q = QByte
MyRSAParams.Exponent = ExponentByte
MyRSAParams.Modulus = ModulusByte
MyRSAParams.D = DByte
MyRSAParams.DP = DPByte
MyRSAParams.DQ = DQByte
MyRSAParams.InverseQ = InverseQByte
Dim MyRSA As RSA
MyRSA = RSA.Create()
MyRSA.ImportParameters(MyRSAParams)
End Sub
Private Sub RSA_Test_Form_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim temp, temp2 As Integer
temp = gcd(1, 2)
temp2 = gcd(2, 3)
FindFactor = 0
End Sub
End Class
What I am trying to do in the generate button was to create the suitable parameters for RSA.
The parameters I was actually able to generate them but in either ULong or Long data type.
When i first convert them into array of Bytes I have considered to use BitConverter but it doesn't work at least in my case.
The only way i am only able to make them into array of Bytes was by making the ULong or Long data type variable into string.
Then convert those string into Byte then put them into ByteArray
I hope it was correct but it is out of my reach for now.
Any ideas on how can i make the parameter data to be accepted as rsa parameter?
The code must add and subtract points based on the following criteria.
+5 for having one upper case
+5 for having one lower case
+5 for one digit
+5 for having one of these symbols !"$%^&()_-
-5 only containing upper case
-5 for only containing lowercase
-5 for only containing digits
-5 for only containing symbols
I am struggling to make the code add 5 points once per criteria instead of multiple times any help would be appreciated in VB.net. Sorry forgot to post my code.
points = Len(password)
counter = 1
While counter < Len(password) + 1
letter = GetChar(password, counter)
convletter = Asc(letter)
'Ascii values for uppercase exclusive
If 64 < convletter < 91 Then
'Adds 5 points
points = points + 5
'Ascii values for lowercase letters exclusive
ElseIf 96 < convletter < 123 Then
'If letter is lowercase + 5 points
points = points + 5
'Ascii values for digits exclusive
ElseIf 47 < convletter < 58 Then
points = points + 5
End If
counter = counter + 1
End While
Console.WriteLine(points)
Console.ReadLine()
I need the code to cycle through the letters of the string but only add 5 points once instead of repeatedly how could I solve this. *Sorry I'm new round here
Try this:
Dim symbols = "!""$%^&()_-"
Dim plusses = { _
password.Any(Function(c) symbols.Contains(c)), _
password.Any(Function(c) Char.IsDigit(c)), _
password.Any(Function(c) Char.IsUpper(c)), _
password.Any(Function(c) Char.IsLower(c)) _
}.Where(Function (x) x).Count() * 5
Dim minusses = { _
password.All(Function(c) symbols.Contains(c)), _
password.All(Function(c) Char.IsDigit(c)), _
password.All(Function(c) Char.IsUpper(c)), _
password.All(Function(c) Char.IsLower(c)) _
}.Where(Function (x) x).Count() * 5
Dim score = plusses - minusses
Dim UpCase As Boolean = False
Dim LowCase As Boolean = False
Dim Digit As Boolean = False
Dim Symbol As Boolean = False
Dim UpCaseOnly As Boolean = False
Dim LowCaseOnly As Boolean = False
Dim SymbolOnly As Boolean = False
Dim DigitOnly As Boolean = False
Dim Password As String = "!" & chr(34) & "/$%?&*()-_"
Dim Points As Integer = Password.Length
'check password
For Each xChar As Char In Password
Select Case xChar
Case "A" To "Z"
UpCase = True
Case "a" To "z"
LowCase = True
Case "0" To "9"
Digit = True
Case "!" To "/", "_" 'ascii 33 to 47 !"/$%?&*()- and 95 _ '
Symbol = True
End Select
Next
If (Symbol = True) And (UpCase = False) And (LowCase = False) And (Digit = False) Then SymbolOnly = True
If (Symbol = False) And (UpCase = True) And (LowCase = False) And (Digit = False) Then UpCaseOnly = True
If (Symbol = False) And (UpCase = False) And (LowCase = True) And (Digit = False) Then LowCaseOnly = True
If (Symbol = False) And (UpCase = False) And (LowCase = False) And (Digit = True) Then DigitOnly = True
'check for points
If SymbolOnly = True Then Points -= 5
If UpCaseOnly = True Then Points -= 5
If LowCaseOnly = True Then Points -= 5
If DigitOnly = True Then Points -= 5
If (LowCaseOnly = False) And (LowCase = True) Then Points += 5
If (UpCaseOnly = False) And (UpCase = True) Then Points += 5
If (DigitOnly = False) And (Digit = True) Then Points += 5
If (SymbolOnly = False) And (Symbol = True) Then Points += 5
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
I am trying to create a UDF within VBA which go through some function syntax and treat it as Text.
The function will look like :
FunctionA( Param1 , Param2 , Param3 , Param 4 )
I am trying to develop a UDF which will pull out the value of the Param based on the position I input into my UDF function.
GetN( FunctionA , 3 ) = "Param3"
GetN FunctionA , 1 ) = "Param1"
Here's my function so far but it's off....
It's behaving like :
GetN( FunctionA , 0 ) = Param2
Here's my function:
Function GetN(sInputString As String, n As Integer) As String
Dim sFindWhat As String
Dim j, FindA, FindB As Integer
Application.Volatile
sFindWhat = ","
FindA = 0
For j = 0 To n
FindA = InStr(FindA + 1, sInputString, sFindWhat)
FindB = InStr(FindA + 1, sInputString, sFindWhat)
If FindB = 0 Then FindB = InStr(FindA + 1, sInputString, ")")
If FindA = 0 Then Exit For
Next
GetN = Trim(Mid(sInputString, FindA + 1, FindB - FindA - 1))
End Function
Thank you for help
Split should work, though to correctly handle the case of nested functions, a preliminary hack is to first replace commas at the top level by a safe delimiter (e.g. [[,]]) and then splitting on that delimiter:
Function GetParameterN(func As String, n As Long) As String
Dim args As Variant
Dim safeArgs As String
Dim c As String
Dim i As Long, pdepth As Long
func = Trim(func)
i = InStr(func, "(")
args = Mid(func, i + 1)
args = Mid(args, 1, Len(args) - 1)
For i = 1 To Len(args)
c = Mid(args, i, 1)
If c = "(" Then
pdepth = pdepth + 1
ElseIf c = ")" Then
pdepth = pdepth - 1
ElseIf c = "," And pdepth = 0 Then
c = "[[,]]"
End If
safeArgs = safeArgs & c
Next i
args = Split(safeArgs, "[[,]]")
GetParameterN = Trim(args(n - 1))
End Function
For example,
Sub test()
Dim i As Long
For i = 1 To 3
Debug.Print GetParameterN("f(x,g(x,y,z),z)", i)
Next i
End Sub
Produces:
x
g(x,y,z)
z
I see no good reason to make this function volatile.
Is it possible to use Format function to display integers in roman numerals?
For Counter As Integer = 1 To 10
Literal1.Text &= Format(Counter, "???")
Next
This is what I found on http://www.source-code.biz/snippets/vbasic/7.htm
(originally written by Mr Christian d'Heureuse in VB)
I converted it to VB.net:
Private Function FormatRoman(ByVal n As Integer) As String
If n = 0 Then FormatRoman = "0" : Exit Function
' there is no Roman symbol for 0, but we don't want to return an empty string
Const r = "IVXLCDM" ' Roman symbols
Dim i As Integer = Math.Abs(n)
Dim s As String = ""
For p As Integer = 1 To 5 Step 2
Dim d As Integer = i Mod 10
i = i \ 10
Select Case d ' format a decimal digit
Case 0 To 3 : s = s.PadLeft(d + Len(s), Mid(r, p, 1))
Case 4 : s = Mid(r, p, 2) & s
Case 5 To 8 : s = Mid(r, p + 1, 1) & s.PadLeft(d - 5 + Len(s), Mid(r, p, 1))
Case 9 : s = Mid(r, p, 1) & Mid(r, p + 2, 1) & s
End Select
Next
s = s.PadLeft(i + Len(s), "M") ' format thousands
If n < 0 Then s = "-" & s ' insert sign if negative (non-standard)
FormatRoman = s
End Function
I hope this will help others.
Cheers - Dave.
No, there is no standard formatter for that.
If you read the Wikipedia on Roman numerals you'll find that there are multiple ways of formatting Roman Numerals. So you will have to write your own method our use the code of someone else.
I wrote this code that works perfectly up to a million.
You can use it but, please, do not make it your own.
Public NotInheritable Class BRoman
'Written by Bernardo Ravazzoni
Public Shared Function hexRoman(ByVal input As Integer) As String
Return mainROMAN(input)
End Function
Private Shared Function mainROMAN(ByVal input As Integer) As String
Dim under As Boolean = udctr(input)
Dim cifretotali As Integer = input.ToString.Length
Dim output As String = ""
Dim remaning As String = input
Dim cifracor As Integer = cifretotali
While Not cifracor = 0
output = output & coreROMAN(division(remaning, remaning), cifracor)
cifracor = cifracor - 1
End While
If under Then
output = "-" & output
End If
Return output
End Function
Private Shared Function coreROMAN(ByVal num As Integer, ByVal pos As Integer) As String
Dim output As String = ""
Debug.WriteLine(num)
Select Case num
Case 1 To 3
output = say(num, getStringFor(True, pos))
Case 4
output = getStringFor(True, pos) & getStringFor(False, pos)
Case 5 To 8
output = getStringFor(False, pos) & say(num - 5, getStringFor(True, pos))
Case 9, 10
output = say(10 - num, getStringFor(True, pos)) & getStringFor(True, pos + 1)
End Select
Return output
End Function
Private Shared Function getStringFor(ByVal first As Boolean, ByVal index As Integer) As String
Dim output As String = ""
index = index * 2
If first Then
index = index - 1
End If
output = rGetStringFor(index)
Return output
End Function
Private Shared Function rGetStringFor(ByVal index As Integer) As String
Dim output As String = ""
Dim sy As Integer
If index < 8 Then
output = rrGetStringFor(index)
Else
sy = index \ 6
output = say(sy, rrGetStringFor(8)) & rrGetStringFor(((index - 2) Mod 6) + 2) & say(sy, rrGetStringFor(9))
End If
Return output
End Function
Private Shared Function rrGetStringFor(ByVal index As Integer) As String
Dim output As String = ""
Select Case index
Case 1
output = "I"
Case 2 '8
output = "V"
Case 3 '9
output = "X"
Case 4 '10
output = "L"
Case 5 '11
output = "C"
Case 6 '12
output = "D"
Case 7 '13
output = "M"
Case 8
output = "["
Case 9
output = "]"
End Select
Return output
End Function
Private Shared Function division(ByVal inputs As String, ByRef resto As String) As Integer
resto = ""
If inputs.Length > 1 Then
resto = inputs.Substring(1)
End If
Dim output As Integer = Integer.Parse(StrReverse(inputs).Substring(inputs.Length - 1))
Return output
End Function
Public Shared Function say(ByVal index As Integer, ByVal letter As String) As String
Dim output As String = ""
While Not index = 0
output = output & letter
index = index - 1
End While
Return output
End Function
Public Shared Function udctr(ByRef num As Integer) As Boolean
Dim und As Boolean = (num < 0)
If und Then
num = 0 - num
End If
Return und
End Function
End Class
Use the function hexRoman, like this example:
msgbox(Broman.hexRoman(50))
Public Class RomanNumber
Public Shared Function FromNumber(val As Byte) As String
Return GetNumberToRoman(val)
End Function
Public Shared Function FromNumber(val As SByte) As String
Return GetNumberToRoman(val)
End Function
Public Shared Function FromNumber(val As Int16) As String
Return GetNumberToRoman(val)
End Function
Public Shared Function FromNumber(val As Int32) As String
Return GetNumberToRoman(val)
End Function
Public Shared Function FromNumber(val As UInt16) As String
Return GetNumberToRoman(val)
End Function
Public Shared Function FromNumber(val As UInt32) As String
Return GetNumberToRoman(val)
End Function
Public Shared Function ToByte(val As String) As Byte
Return GetNumberFromRoman(val)
End Function
Public Shared Function ToSByte(val As String) As SByte
Return GetNumberFromRoman(val)
End Function
Public Shared Function ToInt16(val As String) As Int16
Return GetNumberFromRoman(val)
End Function
Public Shared Function ToInt32(val As String) As Int32
Return GetNumberFromRoman(val)
End Function
Public Shared Function ToUInt16(val As String) As UInt16
Return GetNumberFromRoman(val)
End Function
Public Shared Function ToUInt32(val As String) As UInt32
Return GetNumberFromRoman(val)
End Function
Private Shared Function GetNumberToRoman(val As Integer) As String
Dim v As String = ""
Do While val > 0
If val >= 1000 Then
v &= "M" : val -= 1000
ElseIf val >= 900 Then
v &= "CM" : val -= 900
ElseIf val >= 500 Then
v &= "D" : val -= 500
ElseIf val >= 400 Then
v &= "CD" : val -= 400
ElseIf val >= 100 Then
v &= "C" : val -= 100
ElseIf val >= 90 Then
v &= "XC" : val -= 90
ElseIf val >= 50 Then
v &= "L" : val -= 50
ElseIf val >= 40 Then
v &= "XL" : val -= 40
ElseIf val >= 10 Then
v &= "X" : val -= 10
ElseIf val >= 9 Then
v &= "IX" : val -= 9
ElseIf val >= 5 Then
v &= "V" : val -= 5
ElseIf val >= 4 Then
v &= "IV" : val -= 4
Else
v &= "I" : val -= 1
End If
Loop
Return v
End Function
Private Shared Function GetNumberFromRoman(val As String) As Object
Dim v As Integer = 0
If val.Contains("IV") Then v += 4 : val = val.Replace("IV", "")
If val.Contains("IX") Then v += 9 : val = val.Replace("IX", "")
If val.Contains("XL") Then v += 40 : val = val.Replace("XL", "")
If val.Contains("XC") Then v += 90 : val = val.Replace("XC", "")
If val.Contains("CD") Then v += 400 : val = val.Replace("CD", "")
If val.Contains("CM") Then v += 900 : val = val.Replace("CM", "")
For Each c As Char In val
If c = "I" Then v += 1
If c = "V" Then v += 5
If c = "X" Then v += 10
If c = "L" Then v += 50
If c = "C" Then v += 100
If c = "D" Then v += 500
If c = "M" Then v += 1000
Next
Return v
End Function
End Class