Array Macros inclusiv Objects-Array and UDT-Array

[Theo Gottwald]

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 🚀🤖📈🖥�🔢

Code Select Expand

'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


Code Select Expand

'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


Code Select Expand

'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


Code Select Expand

'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