ArrayMacros are a set of powerful tools; ArrayMacros can be programmed to carry out these operations efficiently. 📊💻
Unleash the potential of your Excel spreadsheets with ArrayMacros! 🔍✨
#ExcelTips #Productivity #DataManagement #Automation #ArrayMacros #TechTips 🚀🤖📈🖥�🔢
'ArrayMacros.inc
'Public domain, use at own risk. SDurham
'These macros add functionality to PB arrays.
'Supports standard types; number, string, UDT, and object arrays.
'Object:
' supports insert and sort which isn't supported by PB
' in some cases the object macros are different (anything requiring insert)
'Add, Insert and Delete macros
' these macros automatically ReDim array
' array stays size of items
'Binary Search, Binary Insert, Binary Insert Unique, Binary Delete
' supported for all types
' if these macros are used to add and remove items then array will always be sorted
' binary search for first and last instance, and count, also supported
' at some point Array Scan will become slow, it's sequential search
'CSV string array, UDT array, Object array
' these can act as an in-memory databases
' changing the compare macro allows them to be sorted and binary searched on any arrangement of the fields
'Only object arrays require the provided quick sort macro, it might be useful for CSV string and UDT arrays.
#If Not %Def(%ArrayMacros231207)
%ArrayMacros231207 = 1
'Array Macros for One-Based Index Arrays
'macros should be on independent line of code to allow them to expand
'append VALUE to end of array
'ReDim automatic
Macro ArrayAdd(ARR,VALUE)
ReDim Preserve ARR(1 To Max&(1, UBound(ARR) + 1))
ARR(UBound(ARR)) = VALUE
End Macro
'insert value at one-based index
'ReDim automatic
Macro ArrayInsert(ARR,INDEX,VALUE)
If INDEX > 0 And INDEX <= UBound(ARR) Then
ReDim Preserve ARR(1 To UBound(ARR) + 1)
Array Insert ARR(INDEX), VALUE
End If
End Macro
'insert new instance at one-based index
'set class name : CLASSNAME must be in quotes
'ReDim automatic
Macro ObjectArrayInsert(ARR,INDEX,VALUE)
MacroTemp a
Local a() As Long
If INDEX > 0 And INDEX <= UBound(ARR) Then
ReDim Preserve ARR(1 To UBound(ARR) + 1)
ReDim a(1 To UBound(ARR)) At VarPtr(ARR(1))
Array Insert a(INDEX), 0
ARR(INDEX) = VALUE
End If
End Macro
'delete value at one-based index
'ReDim automatic
Macro ArrayDelete(ARR,INDEX)
If INDEX > 0 And INDEX <= UBound(ARR) Then
Array Delete ARR(INDEX)
If UBound(ARR) > 1 Then
ReDim Preserve ARR(1 To UBound(ARR) - 1)
Else
Erase ARR()
End If
End If
End Macro
'this compare macro will handle number and string types
'need to write a custom macro for objects and UDTs
'string comparison will be case sensitive
'need to write a custom for anything else
' A < B : return < 0
' A = B : return = 0
' A > B : return > 0
Macro Function ArraySimpleCompare(A,B)
MacroTemp result
Local result As Long
If A < B Then
result = -1
ElseIf A > B Then
result = 1
Else
result = 0
End If
End Macro = result
'a fraction faster
Macro ArrayMoreSimpleCompare(A,B) = Switch&(A < B, -1, A > B, 1)
'non-recursive quick sort
'VALUETYPE = array value type
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ArraySort(ARR,VALUETYPE,COMPAREMACRO)
MacroTemp i, j, leftIndex, rightIndex, counter, compare, value, temp
Register i As Long : Register j As Long : Local leftIndex, rightIndex, counter, compare As Long : Local value, temp As VALUETYPE
If UBound(ARR) > 1 Then
leftIndex = 1 : rightIndex = UBound(ARR) : counter = 1
!PUSH leftIndex
!PUSH rightIndex
While counter
Decr counter
!POP rightIndex
!POP leftIndex
i = leftIndex : j = rightIndex : value = ARR((i + j) \ 2)
While i <= j
compare = COMPAREMACRO(ARR(i),value)
While compare < 0
Incr i
compare = COMPAREMACRO(ARR(i),value)
Wend
compare = COMPAREMACRO(ARR(j),value)
While compare > 0
Decr j
compare = COMPAREMACRO(ARR(j),value)
Wend
If i <= j Then
If i <> j Then
temp = ARR(i) : ARR(i) = ARR(j) : ARR(j) = temp
End If
Incr i : Decr j
End If
Wend
If leftIndex < j Then
!PUSH leftIndex
!PUSH j
Incr counter
End If
If i < rightIndex Then
!PUSH i
!PUSH rightIndex
Incr counter
End If
Wend
End If
End Macro
'this is mainly for the other macros to call
'binary search for VALUE's position
'array must be sorted or empty
'if IsTrue FOUND then
' VALUE in array
' INDEX = VALUE's position
' INDEX = insert position to maintain sort order
' INDEX = delete position
'if INDEX > 0
' INDEX = insert position to maintain sort order
'if INDEX = 0 then
' VALUE not in array or greater than array
' append to maintain sort order
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ArrayBinaryPosition(ARR,VALUE,FOUND,INDEX,COMPAREMACRO)
MacroTemp i, bot, top, compare
Register i As Long : Local bot, top, compare As Long
FOUND = 0 : INDEX = 0
bot = 1: top = UBound(ARR)
While top >= bot
i = bot + top : Shift Right i, 1
compare = COMPAREMACRO(VALUE, ARR(i))
If compare > 0 Then
bot = i + 1
ElseIf compare < 0 Then
top = i - 1
Else
FOUND = 1 : INDEX = i : Exit Macro
End If
Wend
If compare < 0 Then
INDEX = i
ElseIf i < UBound(ARR) Then
INDEX = i + 1
Else
INDEX = 0
End If
End Macro
'binary search for VALUE
'array must be sorted
'return index position
'zero if not found
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro Function ArrayBinarySearch(ARR,VALUE,COMPAREMACRO)
MacroTemp found, index
Local found, index As Long
ArrayBinaryPosition(ARR,VALUE,found,index,COMPAREMACRO)
If IsFalse found Then index = 0
End Macro = index
'get index position first instance of VALUE
'array must be sorted
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro Function ArrayBinaryFirst(ARR,VALUE,COMPAREMACRO)
MacroTemp i, index, compare
Local i, index, compare As Long
index = ArrayBinarySearch(ARR,VALUE,COMPAREMACRO)
If index >= LBound(ARR) Then
For i = index - 1 To LBound(ARR) Step -1
compare = COMPAREMACRO(VALUE, ARR(i))
If compare = 0 Then 'match
index = i
Else
Exit For
End If
Next i
End If
End Macro = index
'get index position last instance of VALUE
'array must be sorted
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro Function ArrayBinaryLast(ARR,VALUE,COMPAREMACRO)
MacroTemp i, index, compare
Local i, index, compare As Long
index = ArrayBinarySearch(ARR,VALUE,COMPAREMACRO)
If index >= LBound(ARR) Then
For i = index + 1 To UBound(ARR)
compare = COMPAREMACRO(VALUE, ARR(i))
If compare = 0 Then 'match
index = i
Else
Exit For
End If
Next i
End If
End Macro = index
'get number of instances of VALUE
'array must be sorted
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro Function ArrayBinaryCount(ARR,VALUE,COMPAREMACRO)
MacroTemp firstinstance, lastinstances, items
Local firstinstance, lastinstances, items As Long
firstinstance = ArrayBinaryFirst(ARR,VALUE,COMPAREMACRO)
lastinstances = ArrayBinaryLast(ARR,VALUE,COMPAREMACRO)
If firstinstance And lastinstances Then
items = lastinstances - firstinstance + 1
Else
items = 0
End If
End Macro = items
'insert VALUE at one-based sort position
'ReDim automatic
'array must be sorted or empty
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ArrayBinaryInsert(ARR,VALUE,COMPAREMACRO)
MacroTemp found, index
Local found, index As Long
ArrayBinaryPosition(ARR,VALUE,found,index,COMPAREMACRO)
If index Then
ArrayInsert(ARR,index,VALUE)
Else
ArrayAdd(ARR,VALUE)
End If
End Macro
'insert OBJECT VALUE at one-based sort position
'ReDim automatic
'array must be sorted or empty
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ObjectArrayBinaryInsert(ARR,VALUE,COMPAREMACRO)
MacroTemp found, index
Local found, index As Long
ArrayBinaryPosition(ARR,VALUE,found,index,COMPAREMACRO)
If index Then
ObjectArrayInsert(ARR,index,VALUE)
Else
ArrayAdd(ARR,VALUE)
End If
End Macro
'insert VALUE at one-based sort position if not in array
'ReDim automatic
'array must be sorted or empty
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ArrayBinaryInsertUnique(ARR,VALUE,COMPAREMACRO)
MacroTemp found, index
Local found, index As Long
ArrayBinaryPosition(ARR,VALUE,found,index,COMPAREMACRO)
If IsFalse found Then
If index Then
ArrayInsert(ARR,index,VALUE)
Else
ArrayAdd(ARR,VALUE)
End If
End If
End Macro
'insert OBJECT VALUE at one-based sort position if not in array
'ReDim automatic
'array must be sorted or empty
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ObjectArrayBinaryInsertUnique(ARR,VALUE,COMPAREMACRO)
MacroTemp found, index
Local found, index As Long
ArrayBinaryPosition(ARR,VALUE,found,index,COMPAREMACRO)
If IsFalse found Then
If index Then
ObjectArrayInsert(ARR,index,VALUE)
Else
ArrayAdd(ARR,VALUE)
End If
End If
End Macro
'binary search for VALUE and delete one instance if found
'ReDim automatic
'array must be sorted
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ArrayBinaryDelete(ARR,VALUE,COMPAREMACRO)
MacroTemp found, index
Local found, index As Long
ArrayBinaryPosition(ARR,VALUE,found,index,COMPAREMACRO)
If found Then
ArrayDelete(ARR,index)
End If
End Macro
'delete all duplicates in number, string or UDT array
'sorted when done
'VALUETYPE = array value type
'compare macro must be provided
'ArraySimpleCompare for simple comparison
Macro ArrayUnique(ARR,VALUETYPE,COMPAREMACRO)
MacroTemp i, compare
Local i, compare As Long
If UBound(ARR) > 1 Then
ArraySort(ARR,VALUETYPE,COMPAREMACRO)
For i = UBound(ARR) - 1 To 1 Step -1
compare = COMPAREMACRO(ARR(i),ARR(i + 1))
If compare = 0 Then
ArrayDelete(ARR,i)
End If
Next i
End If
End Macro
'reverse array
'VALUETYPE = array value type
Macro ArrayReverse(ARR,VALUETYPE)
MacroTemp i, j, temp
Register i As Long : Register j As Long : Local temp As VALUETYPE
If UBound(ARR) > 1 Then
i = 1 : j = UBound(ARR)
While i < j
temp = ARR(i) : ARR(i) = ARR(j) : ARR(j) = temp
Incr i : Decr j
Wend
End If
End Macro
#EndIf '%ArrayMacros231207
'ObjectArray.bas
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "ArrayMacros.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Class TestC
Instance X_ As Long
Interface TestI : Inherit IUnknown
Property Get X() As Long
Property = X_
End Property
Property Set X(ByVal value As Long)
X_ = value
End Property
End Interface
End Class
Macro testcount = 100000
Macro Function TestCompare(a,b)
'compare two object
MacroTemp compare
Local compare As Long
If IsObject(a) And IsObject(b) Then
If a.X < b.X Then
compare = -1
ElseIf a.X > b.X Then
compare = 1
Else
compare = 0 'macth
End If
End If
End Macro = compare
Sub SampleCode()
Register i As Long
Local arr() As TestI
Local value As Long
Local x As Long
Local obj As TestI
Local a() As Long
Local d As Double
Randomize
Control Set Text gDlg, %TextBox, ""
SS ""
SS "Macro ArrayAdd(ARR,VALUE)"
For i = 1 To 5
obj = Class "TestC" : obj.X = i
ArrayAdd(arr,obj)
Next i
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ObjectArrayInsert(ARR,INDEX,VALUE)"
SS " insert new instance at index 4"
obj = Class "TestC" : obj.X = 4444
ObjectArrayInsert(arr,4,obj)
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ArrayDelete(ARR,INDEX)"
SS " delete object at index 4"
ArrayDelete(arr,4)
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ArraySort(ARR,VALUETYPE,COMPAREMACRO)"
SS " erase array and add random values and sort"
Erase arr()
For i = 1 To 8
value = Rnd(1, 7)
obj = Class "TestC" : obj.X = value
ArrayAdd(arr,obj)
Next i
ArraySort(arr,TestI,TestCompare)
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro Function ArrayBinarySearch(ARR,VALUE,COMPAREMACRO)"
SS "Macro Function ArrayBinaryFirst(ARR,VALUE,COMPAREMACRO)"
SS "Macro Function ArrayBinaryLast(ARR,VALUE,COMPAREMACRO)"
SS "Macro Function ArrayBinaryCount(ARR,VALUE,COMPAREMACRO)"
obj = Class "TestC"
For i = 1 To 8
SS "-------"
obj.X = i
x = ArrayBinarySearch(arr,obj,TestCompare)
SS "binary search for object value "+Format$(obj.X)+" = " + Format$(x)
x = ArrayBinaryFirst(arr,obj,TestCompare)
SS "first instance = " + Format$(x)
x = ArrayBinaryLast(arr,obj,TestCompare)
SS "last instance = " + Format$(x)
x = ArrayBinaryCount(arr,obj,TestCompare)
SS "instance count = " + Format$(x)
Next i
obj = Nothing
SS ""
SS "Macro ObjectArrayBinaryInsert(ARR,VALUE,COMPAREMACRO)"
SS " binary insert 3, 2, 1"
obj = Class "TestC" : obj.X = 3
ObjectArrayBinaryInsert(arr,obj,TestCompare)
obj = Class "TestC" : obj.X = 2
ObjectArrayBinaryInsert(arr,obj,TestCompare)
obj = Class "TestC" : obj.X = 1
ObjectArrayBinaryInsert(arr,obj,TestCompare)
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ObjectArrayBinaryInsertUnique(ARR,VALUE,COMPAREMACRO)"
SS " binary insert unique 1, 2, 3, 4, 5, 6, 7, 8"
For i = 1 To 8
obj = Class "TestC" : obj.X = i
ObjectArrayBinaryInsertUnique(arr,obj,TestCompare)
Next i
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ArrayBinaryDelete(ARR,VALUE,COMPAREMACRO)"
SS " binary delete 1, 2, 3"
SS " binary delete 1, 2, 3"
obj = Class "TestC"
For i = 1 To 3
obj.X = i
ArrayBinaryDelete(arr,obj,TestCompare)
Next i
obj = Nothing
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ArrayUnique(ARR,VALUETYPE,COMPAREMACRO)"
SS " delete all duplicates"
ArrayUnique(arr,TestI,TestCompare)
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
SS ""
SS "Macro ArrayReverse(ARR,VALUETYPE)"
ArrayReverse(arr,TestI)
SS "-------"
For i = 1 To UBound(arr)
SS Format$(i) +" = "+ Format$(arr(i).X)
Next i
ReDim a(1 To testcount)
For i = 1 To testcount
a(i) = Rnd(1, 22222222)
Next i
SS ""
SS "add "+Format$(testcount,"#,")+" simple random objects"
Erase arr()
d = Timer
For i = 1 To testcount
obj = Class "TestC" : obj.X = a(i)
ArrayAdd(arr,obj)
Next i
SS "Time = " + Format$(Timer - d,"000.000")
SS "Count = " + Format$(UBound(arr),"#,")
SS ""
SS "sort array of "+Format$(testcount,"#,")+" random objects"
d = Timer
ArraySort(arr,TestI,TestCompare)
SS "Time = " + Format$(Timer - d,"000.000")
SS ""
SS "binary search for "+Format$(testcount,"#,")+" random objects"
obj = Class "TestC"
d = Timer
For i = 1 To testcount
obj.X = a(i)
x = ArrayBinarySearch(arr,obj,TestCompare)
If x = 0 Then
? "ArrayBinarySearch() fail" : Exit For
End If
Next i
SS "Time = " + Format$(Timer - d,"000.000")
obj = Nothing
SS ""
SS ""
Control Send gDlg, %TextBox, %EM_SETSEL, 1, 1
Control Send gDlg, %TextBox, %EM_SCROLLCARET, 0, 0
End Sub
Sub SS(ByVal value As WString)
'appends without the overhead of getting the text
Local characterCount As Long
Local hWin As Long : hWin = GetDlgItem(gDlg, %TextBox)
value += $CrLf
characterCount = SendMessageW(hWin, %WM_GETTEXTLENGTH, 0, 0)
SendMessageW(hWin, %EM_SETSEL, characterCount, characterCount)
SendMessageW(hWin, %EM_REPLACESEL, 1, StrPtr(value))
End Sub
Function PBMain()
Local clientW, clientH As Long
Desktop Get Client To clientW, clientH
Dialog Default Font "consolas", 13, 0, 0
Dialog New 0, Exe.Name$, 0, 0, clientW \ 7, clientH \ 4, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame Or %DS_Center, %WS_Ex_AppWindow To gDlg
Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0
Control Add Button, gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
SendMessageW(GetDlgItem(gDlg, %TextBox), %EM_SETLIMITTEXT, 4000000, 0)
Dialog Show Modeless gDlg, Call DlgCB
Do
Dialog DoEvents
Loop While IsWin(gDlg)
End Function
CallBack Function DlgCB()
Select Case As Long Cb.Msg
Case %WM_Size
WM_Size()
Case %WM_Command
Select Case As Long Cb.Ctl
Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
End Select
End Select
End Function
Sub WM_Size()
Local clientW, clientH As Long
Local marg As Long
Local buttonW, buttonH As Long
Local txtWidth, txtHeight As Long
Local fromLeft, fromBottom As Long
Dialog Get Client gDlg To clientW, clientH
marg = 3 : buttonW = 25 : buttonH = 10
fromLeft = clientW - marg - buttonW
fromBottom = clientH - marg - buttonH
Control Set Size gDlg, %BtnID, buttonW, buttonH
Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
txtWidth = clientW - marg - marg
txtHeight = clientH - marg - buttonH - marg - marg
Control Set Size gDlg, %TextBox, txtWidth, txtHeight
Control Set Loc gDlg, %TextBox, marg, marg
End Sub
'UdtArray.bas
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "ArrayMacros.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Type TestT
X As Long
Y As Long
End Type
Macro Function TestCompareX(a,b)
MacroTemp result
Local result As Long
result = Switch&(a.X < b.X, -1, a.X > b.X, 1) 'else match
End Macro = result
Macro Function TestCompareY(a,b)
MacroTemp result
Local result As Long
result = Switch&(a.Y < b.Y, -1, a.Y > b.Y, 1) 'else match
End Macro = result
Sub SampleCode()
Register i As Long
Local j As Long
Local arr() As TestT
Local t As TestT
Randomize
Control Set Text gDlg, %TextBox, ""
SS ""
SS "Macro ArrayAdd(ARR,VALUE)"
SS " arr random values"
For i = 1 To 8
t.X = Rnd(1, 7)
t.Y = Rnd(1, 7)
ArrayAdd(arr,t)
Next i
SS "-------"
For i = 1 To UBound(arr)
SS "at " + Format$(i) + " X = " + Format$(arr(i).X) + " Y = " + Format$(arr(i).Y)
Next i
SS ""
SS "Macro ArraySort(ARR,VALUETYPE,COMPAREMACRO)"
SS " sort on Y"
ArraySort(arr,TestT,TestCompareY)
SS "-------"
For i = 1 To UBound(arr)
SS "at " + Format$(i) + " X = " + Format$(arr(i).X) + " Y = " + Format$(arr(i).Y)
Next i
SS ""
SS "Macro ArraySort(ARR,VALUETYPE,COMPAREMACRO)"
SS " sort on X"
ArraySort(arr,TestT,TestCompareX)
SS "-------"
For i = 1 To UBound(arr)
SS "at " + Format$(i) + " X = " + Format$(arr(i).X) + " Y = " + Format$(arr(i).Y)
Next i
SS ""
SS "Macro Function ArrayBinarySearch(ARR,VALUE,COMPAREMACRO)"
SS "Macro Function ArrayBinaryFirst(ARR,VALUE,COMPAREMACRO)"
SS "Macro Function ArrayBinaryLast(ARR,VALUE,COMPAREMACRO)"
SS "Macro Function ArrayBinaryCount(ARR,VALUE,COMPAREMACRO)"
For i = 1 To 8
SS "-------"
t.X = i
j = ArrayBinarySearch(arr,t,TestCompareX)
SS "binary search for X = "+Format$(t.X)+" = " + Format$(j)
j = ArrayBinaryFirst(arr,t,TestCompareX)
SS "first instance = " + Format$(j)
j = ArrayBinaryLast(arr,t,TestCompareX)
SS "last instance = " + Format$(j)
j = ArrayBinaryCount(arr,t,TestCompareX)
SS "quantity = " + Format$(j)
Next i
SS ""
SS ""
Control Send gDlg, %TextBox, %EM_SETSEL, 1, 1
Control Send gDlg, %TextBox, %EM_SCROLLCARET, 0, 0
End Sub
Sub SS(ByVal value As WString)
'appends without the overhead of getting the text
Local characterCount As Long
Local hWin As Long : hWin = GetDlgItem(gDlg, %TextBox)
value += $CrLf
characterCount = SendMessageW(hWin, %WM_GETTEXTLENGTH, 0, 0)
SendMessageW(hWin, %EM_SETSEL, characterCount, characterCount)
SendMessageW(hWin, %EM_REPLACESEL, 1, StrPtr(value))
End Sub
Function PBMain()
Local clientW, clientH As Long
Desktop Get Client To clientW, clientH
Dialog Default Font "consolas", 13, 0, 0
Dialog New 0, Exe.Name$, 0, 0, clientW \ 7, clientH \ 4, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame Or %DS_Center, %WS_Ex_AppWindow To gDlg
Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0
Control Add Button, gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
SendMessageW(GetDlgItem(gDlg, %TextBox), %EM_SETLIMITTEXT, 4000000, 0)
Dialog Show Modeless gDlg, Call DlgCB
Do
Dialog DoEvents
Loop While IsWin(gDlg)
End Function
CallBack Function DlgCB()
Select Case As Long Cb.Msg
Case %WM_Size
WM_Size()
Case %WM_Command
Select Case As Long Cb.Ctl
Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
End Select
End Select
End Function
Sub WM_Size()
Local clientW, clientH As Long
Local marg As Long
Local buttonW, buttonH As Long
Local txtWidth, txtHeight As Long
Local fromLeft, fromBottom As Long
Dialog Get Client gDlg To clientW, clientH
marg = 3 : buttonW = 25 : buttonH = 10
fromLeft = clientW - marg - buttonW
fromBottom = clientH - marg - buttonH
Control Set Size gDlg, %BtnID, buttonW, buttonH
Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
txtWidth = clientW - marg - marg
txtHeight = clientH - marg - buttonH - marg - marg
Control Set Size gDlg, %TextBox, txtWidth, txtHeight
Control Set Loc gDlg, %TextBox, marg, marg
End Sub
'ArrayBinaryPosition Test2.bas
#Compile Exe
#Include Once "ArrayMacros.inc"
'test Macro ArrayBinaryPosition
Function PBMain() As Long
Local i, j, k, r, a(), b() As Long
Local testloops, itemcount, maxcount As Long
Local VALUE, FOUND, INDEX As Long
Randomize
testloops = 100
maxcount = 100
For i = 1 To testloops
For j = 1 To maxcount
itemcount = j
ReDim a(1 To itemcount)
ReDim b(1 To itemcount)
'add test data
For k = 1 To itemcount
r = Rnd(-10000000, 10000000)
a(k) = r
b(k) = r
Next i
'sort array
ArraySort(a,Long,ArrayMoreSimpleCompare)
'binary search array a for values in array b
For k = 1 To itemcount
VALUE = b(k)
ArrayBinaryPosition(a,VALUE,FOUND,INDEX,ArrayMoreSimpleCompare)
If IsFalse FOUND Then
? "FAIL!!!!!!!!!!!!!!!!!!!!!!!!!!"
End If
Next k
Next i
Next i
? "done ..."
End Function
Updated (https://forum.powerbasic.com/forum/user-to-user-discussions/programming/829080-arraymacros-comments)