Quote:Do you by the way share your array functions anywhere? If so, I'd be interested in having a look. Maybe they will reduce my phobia.
Sure!
Code: (Select All)
Option _Explicit
_Title "String Array Tools works mainly with Dynamic arrays"
'2018-11-05 Unique, Split might benefit from chunking with REDIM _PRESERVE
'2019-04-06 added slice which can replace copy
Randomize Timer
Dim n As Integer, x As Integer, r As Integer, i As Integer
Dim b$, store$, t$, enter$
''test subs and functions from Float Tools
'REDIM test(n) AS STRING
't$ = "B B C D D D A B C D B A C"
'PRINT "Test: "; t$
'PRINT "Split, Unique, Sorted, Reversed and Join$: ";
'Split t$, " ", test()
'Unique test()
'Sort 0, UBOUND(test), test()
'Reverse test()
't$ = Join$(test(), ",")
'PRINT t$
'INPUT "Press enter for next test, Addend (Append) and copie and Show (boring stuff)..."; enter$
'REDIM test(1 TO 1) AS STRING
'test(1) = "This is a test."
'store$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz 0123456789"
''store$ = "ABCD" 'test unique
'PRINT "Test addend"
'n = 10
'FOR x = 1 TO n
' b$ = ""
' r = (RND * 3) \ 1 + 2
' FOR i = 0 TO r
' b$ = b$ + MID$(store$, INT(RND * LEN(store$)) + 1, 1)
' NEXT
' Addend test(), b$
'NEXT
'PRINT "Result of Addend:"
'Show test()
'REDIM copie(0) AS STRING
'PRINT "Copying test()..."
'Copy test(), copie()
'PRINT "Showing copied array:"
'Show copie()
'PRINT "Here is joint, of first 5 items: "; Joint$(copie(), 0, 4, ", ")
'PRINT "Here is whole join: "; Join$(copie(), ": ")
ReDim copie(0) As String
Split "0 1 2 3 4 5 6 7", copie(), " "
Insert copie(), 3, "This is inserted into the " + Str$(3) + " index position."
Show copie()
Print
Delete copie(), 3
Show copie()
'a() must be initialized as redim a(lb to ub)
Sub Unique (a() As String) 'make all the items in the a array unique like a proper set
Dim i As Long, ti As Long, j As Long, u As Integer, lba As Long
lba = LBound(a)
ReDim t(lba To lba) As String 'rebuild container
t(lba) = a(lba): ti = lba
For i = lba + 1 To UBound(a) 'for each element in array
u = -1
For j = lba To ti 'check if not already in new build
If a(i) = t(j) Then u = 0: Exit For 'oh it is unique is false
Next
If u Then 'OK add it to rebuild
ti = ti + 1
ReDim _Preserve t(lba To ti) As String
t(ti) = a(i)
End If
Next
ReDim a(lba To ti) As String 'goodbye old array
For i = lba To ti 'now copy the unique elements into array
a(i) = t(i)
Next
End Sub
Sub Sort (a() As String, start As Long, finish As Long)
Dim Hi As Long, Lo As Long, Middle As String
Hi = finish: Lo = start
Middle = a((Lo + Hi) / 2) 'find middle of array
Do
Do While a(Lo) < Middle: Lo = Lo + 1: Loop
Do While a(Hi) > Middle: Hi = Hi - 1: Loop
If Lo <= Hi Then
Swap a(Lo), a(Hi)
Lo = Lo + 1: Hi = Hi - 1
End If
Loop Until Lo > Hi
If Hi > start Then Sort a(), start, Hi
If Lo < finish Then Sort a(), Lo, finish
End Sub
Sub Reverse (a() As String)
Dim i As Long, ti As Long
ReDim t(LBound(a) To UBound(a)) As String
ti = LBound(a)
For i = UBound(a) To LBound(a) Step -1 'load t from top to bottom of a
t(ti) = a(i)
ti = ti + 1
Next
For i = LBound(a) To UBound(a) 'reload a from t
a(i) = t(i)
Next
End Sub
'notes: REDIM the a(0) as string to be loaded before calling Split '<<<<<<<<<<<<<<<<<<<<<<< IMPORTANT!!!!
Sub Split (mystr As String, a() As String, delim As String)
' I am hoping strings will cover any number type
' bplus modifications of Galleon fix of Bulrush Split reply #13
' http://www.qb64.net/forum/index.php?topic=1612.0
' this sub further developed and tested here: \test\Strings\Split test.bas
Dim copee As String, p As Long, curpos As Long, arrpos As Long, lc As Long, dpos As Long
copee = mystr 'make copee since we are messing with mystr
'special case if delim is space, probably want to remove all excess space
If delim = " " Then
copee = RTrim$(LTrim$(copee))
p = InStr(copee, " ")
While p > 0
copee = Mid$(copee, 1, p - 1) + Mid$(copee, p + 1)
p = InStr(copee, " ")
Wend
End If
curpos = 1
arrpos = 0
lc = Len(copee)
dpos = InStr(curpos, copee, delim)
Do Until dpos = 0
a(arrpos) = Mid$(copee, curpos, dpos - curpos)
arrpos = arrpos + 1
ReDim _Preserve a(arrpos + 1) As String
curpos = dpos + Len(delim)
dpos = InStr(curpos, copee, delim)
Loop
a(arrpos) = Mid$(copee, curpos)
ReDim _Preserve a(arrpos) As String
End Sub
' tie only a continuous section together
Function Joint$ (a() As String, aStart As Long, aStop As Long, delimiter As String)
Dim i As Long, iStart, iStop, b As String
If aStart < LBound(a) Then iStart = LBound(a) Else iStart = aStart
If aStop > UBound(a) Then iStop = UBound(a) Else iStop = aStop
For i = iStart To iStop
If i = iStop Then
b = b + a(i)
Else
b = b + a(i) + delimiter
End If
Next
Joint$ = b
End Function
'tie it all together
Function Join$ (a() As String, delimiter As String)
Dim i As Long, b As String
For i = LBound(a) To UBound(a)
If i = UBound(a) Then
b = b + a(i)
Else
b = b + a(i) + delimiter
End If
Next
Join$ = b
End Function
Sub Delete (a() As String, deletePlace As Long)
Dim i As Long
If deletePlace >= LBound(a) And deletePlace <= UBound(a) Then
For i = deletePlace To UBound(a) - 1
a(i) = a(i + 1)
Next
ReDim _Preserve a(LBound(a) To UBound(a) - 1) As String
End If
End Sub
Sub Insert (a() As String, insertPlace As Long, insertValue As String)
Dim uba As Long, i As Long
uba = UBound(a)
If insertPlace > uba Then
Addend a(), insertValue
Else
ReDim _Preserve a(LBound(a) To uba + 1) As String
For i = uba To insertPlace Step -1
a(i + 1) = a(i)
Next
a(insertPlace) = insertValue
End If
End Sub
'not append? append is a command word
Sub Addend (a() As String, addon As String)
Dim lba As Long, uba As Long
lba = LBound(a): uba = UBound(a)
ReDim _Preserve a(lba To uba + 1) As String
a(uba + 1) = addon
End Sub
Sub aCopy (a() As String, b() As String)
Dim lba As Long, uba As Long, i As Long
lba = LBound(a): uba = UBound(a)
ReDim b(lba To uba) As String
For i = lba To uba
b(i) = a(i)
Next
End Sub
Sub Show (a() As String)
Dim lba As Long, uba As Long, i As Long
lba = LBound(a): uba = UBound(a)
For i = lba To uba
Print a(i)
Next
End Sub
'replace copy with more versatile tool
'start is assumed to be <= fini but start or fini can be less than lbound and ubound of source
Sub slice (source() As String, start, fini, copy() As String)
Dim copyI As Long, begin As Long, finish As Long, i As Long
If start < LBound(source) Then begin = LBound(source) Else begin = start
If fini > UBound(source) Then finish = UBound(source) Else finish = fini
ReDim copy(0 To finish - begin + 1) As String
copyI = 0
For i = begin To finish
copy(copyI) = source(i)
copyI = copyI + 1
Next
End SubIn all the commented code in main, I was testing each routine and using: Show test(), to show result after each test. Once checked I set up next test and moved the: Show test() line below the next test. That's why there isn't Show test() after each test of a routine.
A shorter version of Split (where space as delimiter is not checked):
Code: (Select All)
' note: I buggered this twice now, FOR base 1 array REDIM MyArray (1 to 1) AS ... the (1 to 1) is not same as (1) which was the Blunder!!!
'notes: REDIM the array(0) to be loaded before calling Split '<<<< IMPORTANT dynamic array and empty, can use any lbound though
'This SUB will take a given N delimited string, and delimiter$ and create an array of N+1 strings using the LBOUND of the given dynamic array to load.
'notes: the loadMeArray() needs to be dynamic string array and will not change the LBOUND of the array it is given. rev 2019-08-27
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End SubAnd as posted elsewhere, a routine for displaying and selecting, like from a menu only the "menu" can go for pages and pages!:
Code: (Select All)
Option _Explicit
_Title "GetArrayItem$ v 2021-02-07" 'b+ NEED dev 1.5
' build from getArrayItemNumber& function 2019-05-18
' Main testing and demo of the FUNCTION getArrayItem$
Const Xmax = 1200, Ymax = 600 'Window Width and Height
Screen _NewImage(Xmax, Ymax, 32)
_Delay .25
_ScreenMove _Middle
Dim As Long lb, ub, i, locRow, locCol, boxWidth, boxHeight, snap
Dim As String selected
'test string array, use indexes in lines for alignment to code for function
lb = 1: ub = 45 ' <<<<<<<<<<<<<< different size arrays
ReDim arr(lb To ub) As String
For i = lb To ub
arr(i) = "This is arr item:" + Str$(i)
Next
'set variables to call display
locRow = 5: locCol = 80: boxWidth = 30: boxHeight = 20 ' character cell units not pixels
Do
Cls
' off by 1 row too height in display
Locate locRow - 2, locCol - 1: Print "*" ' height starts 1 less than spec'd
' this is box that contains the getArrItem box
Line ((locCol - 1) * 8 - 1, (locRow - 2) * 16 - 1)-Step(boxWidth * 8 + 2, boxHeight * 16 + 2), &HFFFFFF00, B
selected = GetArrayItem$(locRow, locCol, boxWidth, boxHeight, arr())
Print "You selected: "; selected; ", press any to continue..."
Sleep
Loop Until _KeyDown(27)
' Help: all this I hope is intuitive so Help not needed
' "Mouse, mouse wheel, and arrow keys should work as expected for item selection."
' "Press spacebar to select a highlighted item or just click it."
' "Use number(s) + enter to select an array item by it's index number,"
' "backspace will remove last number pressed, c will clear a number started. << Change to Delete
' "Numbers started are shown in bottom right PgDn bar."
' "Enter will also select the highlighted item, if no number has been started."
' "Home starts you at lowest array index, End highlights then highest index."
' "Use PgUp and PgDn keys to flip through pages of array items."
'
' Escape to Cancel Return "" else Return the selected string from the array
Function GetArrayItem$ (locateRow, locateColumn, boxWidth, boxHeight, arr() As String)
'This sub needs ScrState to store and restore screen condition before and after this sub does it's thing
'Notes: locateRow, locateColumn for top right corner of selection box on screen in characters for LOCATE.
'boxWidth and boxHeight are in character units, again for locate and print at correct places.
'All displaying is restricted to inside the box, which has PgUP and PgDn as top and bottom lines in the display.
Dim maxWidth As Integer, maxHeight As Integer, page As Integer, hlite As Integer, mx As Integer, my As Integer
Dim lastMX As Integer, lastMY As Integer, row As Integer, mb As Integer
Dim lba As Long, uba As Long, choice As Long, kh As Long, index As Long
Dim clrStr As String, b As String
'save old settings to restore at end ofsub
ScnState 0
maxWidth = boxWidth ' number of characters in box
maxHeight = boxHeight - 2 ' number of lines displayed of array at one time = 1 page
lba = LBound(arr)
uba = UBound(arr)
page = 0
hlite = 0 ' line in display ready for selection by spacebar or if no number is started, enter
clrStr$ = Space$(maxWidth) 'clearing a display line
GoSub update ' show the beginning of the array items for selection
choice = -1719
Do 'until get a selection or demand exit
'handle the key stuff
kh& = _KeyHit
If kh& Then
If kh& > 0 And kh& < 255 Then
If InStr("0123456789", Chr$(kh&)) > 0 Then b$ = b$ + Chr$(kh&): GoSub update
If Chr$(kh&) = "c" Then b$ = "": GoSub update
If kh& = 13 Then 'enter pressed check if number is being entered?
If Len(b$) Then
If Val(b$) >= lba And Val(b$) <= uba Then 'we have number started
choice = Val(b$): Exit Do
Else 'clear b$ to show some response to enter
b$ = "": GoSub update 'clear the value that doesn't work
End If
Else
choice = hlite + page * maxHeight + lba 'must mean to select the highlighted item
End If
End If
If kh& = 27 Then Exit Do 'escape clause offered to Cancel selection process
If kh& = 32 Then choice = hlite + page * maxHeight + lba 'best way to choose highlighted selection
If kh& = 8 Then 'backspace to edit number
If Len(b$) Then b$ = Left$(b$, Len(b$) - 1): GoSub update
End If
Else
Select Case kh& 'choosing sections of array to display and highlighted item
Case 20736 'pg dn
If (page + 1) * maxHeight + lba <= uba Then page = page + 1: GoSub update
Case 18688 'pg up
If (page - 1) * maxHeight + lba >= lba Then page = page - 1: GoSub update
Case 18432 'up
If hlite - 1 < 0 Then
If page > 0 Then
page = page - 1: hlite = maxHeight - 1: GoSub update
End If
Else
hlite = hlite - 1: GoSub update
End If
Case 20480 'down
If (hlite + 1) + page * maxHeight + lba <= uba Then 'ok to move up
If hlite + 1 > maxHeight - 1 Then
page = page + 1: hlite = 0: GoSub update
Else
hlite = hlite + 1: GoSub update
End If
End If
Case 18176 'home
page = 0: hlite = 0: GoSub update
Case 20224 ' end
page = Int((uba - lba) / maxHeight): hlite = maxHeight - 1: GoSub update
End Select
End If
End If
'handle the mouse stuff
While _MouseInput
If _MouseWheel = -1 Then 'up?
If hlite - 1 < 0 Then
If page > 0 Then
page = page - 1: hlite = maxHeight - 1: GoSub update
End If
Else
hlite = hlite - 1: GoSub update
End If
ElseIf _MouseWheel = 1 Then 'down?
If (hlite + 1) + page * maxHeight + lba <= uba Then 'ok to move up
If hlite + 1 > maxHeight - 1 Then
page = page + 1: hlite = 0: GoSub update
Else
hlite = hlite + 1: GoSub update
End If
End If
End If
Wend
mx = Int((_MouseX - locateColumn * 8) / 8) + 2: my = Int((_MouseY - locateRow * 16) / 16) + 2
If _MouseButton(1) Then 'click contols or select array item
'clear mouse clicks
mb = _MouseButton(1)
If mb Then 'clear it
While mb 'OK!
If _MouseInput Then mb = _MouseButton(1)
_Limit 100
Wend
End If
If mx >= 1 And mx <= maxWidth And my >= 1 And my <= maxHeight Then
choice = my + page * maxHeight + lba - 1 'select item clicked
ElseIf mx >= 1 And mx <= maxWidth And my = 0 Then 'page up or exit
If my = 0 And (mx <= maxWidth And mx >= maxWidth - 2) Then 'exit sign
Exit Do 'escape plan for mouse click top right corner of display box
Else 'PgUp bar clicked
If (page - 1) * maxHeight + lba >= lba Then page = page - 1: GoSub update
End If
ElseIf mx >= 1 And mx <= maxWidth And my = maxHeight + 1 Then 'page down bar clicked
If (page + 1) * maxHeight + lba <= uba Then page = page + 1: GoSub update
End If
Else ' mouse over highlighting, only if mouse has moved!
If mx >= 1 And mx <= maxWidth And my >= 1 And my <= maxHeight Then
If mx <> lastMX Or my <> lastMY Then
If my - 1 <> hlite And (my - 1 + page * maxHeight + lba <= uba) Then
hlite = my - 1
lastMX = mx: lastMY = my
GoSub update
End If
End If
End If
End If
_Limit 200
Loop Until choice >= lba And choice <= uba
If choice <> -1719 Then GetArrayItem$ = arr(choice) 'set function and restore screen
ScnState -1 'restore
Exit Function
'display of array sections and controls on screen ====================================================
update:
'fix hlite if it has dropped below last array item
While hlite + page * maxHeight + lba > uba
hlite = hlite - 1
Wend
'main display of array items at page * maxHeight (lines high)
For row = 0 To maxHeight - 1
If hlite = row Then Color _RGB(200, 200, 255), _RGB32(0, 0, 88) Else Color _RGB32(0, 0, 88), _RGB(200, 200, 255)
Locate locateRow + row, locateColumn: Print clrStr$
index = row + page * maxHeight + lba
If index >= lba And index <= uba Then
Locate locateRow + row, locateColumn
Print Left$(LTrim$(Str$(index)) + ") " + arr(index), maxWidth)
End If
Next
'make page up and down bars to click, print PgUp / PgDn if available
Color _RGB32(200, 200, 255), _RGB32(0, 100, 50)
Locate locateRow - 1, locateColumn: Print Space$(maxWidth)
If page <> 0 Then Locate locateRow - 1, locateColumn: Print Left$(" Pg Up" + Space$(maxWidth), maxWidth)
Locate locateRow + maxHeight, locateColumn: Print Space$(maxWidth)
If page <> Int(uba / maxHeight) Then
Locate locateRow + maxHeight, locateColumn: Print Left$(" Pg Dn" + Space$(maxWidth), maxWidth)
End If
'make exit sign for mouse click
Color _RGB32(255, 255, 255), _RGB32(200, 100, 0)
Locate locateRow - 1, locateColumn + maxWidth - 3
Print " X "
'if a number selection has been started show it's build = b$
If Len(b$) Then
Color _RGB(255, 255, 0), _RGB32(0, 0, 0)
Locate locateRow + maxHeight, locateColumn + maxWidth - Len(b$) - 1
Print b$;
End If
_Display
_Limit 100
Return
End Function
' see if this version of screen state is OK because the above one does not play nice with old mBox and InputBox$
Sub ScnState (restoreTF As Long) 'Thanks Steve McNeill
Static As _Unsigned Long defaultColor, backGroundColor
Static As Long font, dest, source, row, col, autodisplay, mb
If restoreTF Then
_Font font
Color defaultColor, backGroundColor
_Dest dest
_Source source
Locate row, col
If autodisplay Then _AutoDisplay Else _Display
_KeyClear
While _MouseInput: Wend 'clear mouse clicks
mb = _MouseButton(1)
If mb Then
Do
While _MouseInput: Wend
mb = _MouseButton(1)
_Limit 100
Loop Until mb = 0
End If
Else
font = _Font: defaultColor = _DefaultColor: backGroundColor = _BackgroundColor
dest = _Dest: source = _Source
row = CsrLin: col = Pos(0): autodisplay = _AutoDisplay
_KeyClear
End If
End Sub
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever


