Parsing the Parameters of a Function - vba

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.

Related

VB trying to call function with multiple outputs getting "Unable to cast object of type 'System.Object[,]' to type 'System.String[,]'." Error

I'm trying to use a function with multiple outputs (an array and two integers). I thought I had it working but today I am getting an error, "Unable to cast object of type 'System.Object[,]' to type 'System.String[,]'."
The function:
Public Function convArray(ByVal inputArray As String(,)) As (outputArray As String(,), outputRows As Integer, outputCol As Integer)
Dim sColumns As Integer
Dim sRows As Integer
Dim AscArray As Boolean
sRows = inputArray.GetLength(1)
sColumns = inputArray.GetLength(0)
Dim outputArray(sColumns - 1, sRows - 1)
If inputArray(0, 1) > inputArray(0, 2) Then
AscArray = False
Else
AscArray = True
End If
For k As Integer = 0 To sColumns - 1
outputArray(k, 0) = inputArray(k, 0)
Next
For i As Integer = 0 To sColumns - 1
For j As Integer = 1 To sRows - 1
If AscArray Then
outputArray(i, j) = inputArray(i, j)
Else
outputArray(i, j) = inputArray(i, sRows - j)
End If
Next
Next
Return (outputArray, sRows, sColumns)
End Function
The call:
Dim blrArray = convArray(s)
sDRows = blrArray.outputRows
sDColumns = blrArray.outputCol
ReDim sD(sDColumns - 1, sDRows - 1)
sD = blrArray.outputArray
s and sD are arrays defined elsewhere.
I'm getting the error on the "Return" part of the function.
I apologize in advance for my inefficient code, i'm still pretty new at it.

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

Longest common substring large strings?

I need some help with this function. I am trying to find the longest common string between 2 strings. Here is the function that I am currently using:
Public Shared Function LCS(str1 As Char(), str2 As Char())
Dim l As Integer(,) = New Integer(str1.Length - 1, str2.Length - 1) {}
Dim lcs__1 As Integer = -1
Dim substr As String = String.Empty
Dim [end] As Integer = -1
For i As Integer = 0 To str1.Length - 1
For j As Integer = 0 To str2.Length - 1
If str1(i) = str2(j) Then
If i = 0 OrElse j = 0 Then
l(i, j) = 1
Else
l(i, j) = l(i - 1, j - 1) + 1
End If
If l(i, j) > lcs__1 Then
lcs__1 = l(i, j)
[end] = i
End If
Else
l(i, j) = 0
End If
Next
Next
For i As Integer = [end] - lcs__1 + 1 To [end]
substr += str1(i)
Next
Return substr
End Function
This works great on strings of up to around 600 words or so. If I try to compare strings with a larger word count than that it starts to throw system.outofmemoryexception. Obviously, this is hitting the memory pretty hard. Is there any way to fine tune this function or is there possibly another way of doing this that is more streamlined?

Converting arabic numerals to roman numerals in a visual basic console application [duplicate]

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

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