Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

UDT Dynamic Arrays and Strings – Lite Objects

Collapse
X
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
  • #1

    PBWin/PBCC UDT Dynamic Arrays and Strings – Lite Objects

    Lot of discussion about arrays in UDTs.

    These are some simple Lite Object arrays that may be stored in a UDT, or any LONG.

    Also, dynamic string: StrBuff.inc
    String stored in buffer – hold any value

    Lite Object = allocated UDT referenced with pointer or LONG handle.

    You must allocate a new instance before use: h = …Alloc()
    Free handle before it goes out of scope: h = …Free(h)

    Added: arrays ReDim automatically. Arrays grow on Add() and Insert().
    Arrays shrink on Delete()

    Public domain – use at own risk
    Last edited by Stanley Durham; 23 Jul 2009, 12:29 PM.
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes
    Tags: None
  • #2
    Code:
    'GMem1.inc
'used by all files
    'allocate global memory
%GMemGMEM_FIXED    = &H0
%GMemGMEM_ZEROINIT = &H40
%GMemGMEM_MOVEABLE = &H2
%GMemGPTR = %GMemGMEM_FIXED Or %GMemGMEM_ZEROINIT
#If Not %Def(%WINAPI)
    Declare Function GlobalAlloc Lib "KERNEL32.DLL" Alias "GlobalAlloc" (ByVal wFlags As Dword, ByVal dwBytes As Dword) As Long
    Declare Function GlobalFree Lib "KERNEL32.DLL" Alias "GlobalFree" (ByVal hMem As Dword) As Long
    Declare Function GlobalReAlloc Lib "KERNEL32.DLL" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword
    Declare Sub MoveMemory Lib "KERNEL32.DLL" Alias "RtlMoveMemory" (pDestination As Any, pSource As Any, ByVal cbLength As Long)
#EndIf
'if %WINAPI isn't included, won't have %TRUE, %FALSE, %NULL
Macro boolTrue = 1
Macro boolFalse = 0
Macro boolNull = 0
Macro boolExitIfFalse(test, SubOrFun, msg)
    If test Then
    Else
        #Debug Print FuncName$ +": "+ msg
        Exit SubOrFun
    End If
End Macro
Macro boolExitIfTrue(test, SubOrFun, msg)
    If test Then
        #Debug Print FuncName$ +": "+ msg
        Exit SubOrFun
    End If
End Macro
Macro boolGoToIfFalse(test, marker, msg)
    If test Then
    Else
        #Debug Print FuncName$ +": "+ msg
        GoTo marker
    End If
End Macro
Macro boolGoToIfTrue(test, marker, msg)
    If test Then
        #Debug Print FuncName$ +": "+ msg
        GoTo marker
    End If
End Macro
Function GMemAlloc(ByVal memSize As Long) As Long
    'allocate memory
    Function = GlobalAlloc(ByVal %GMemGPTR, ByVal memSize)
End Function
Function GMemFree(ByRef hMem As Long) As Long
    'free allocated memory
    If hMem Then GlobalFree(ByVal hMem)
    Function = boolNull
End Function
Function GMemReAlloc(ByVal hMem As Long, ByVal newSize As Long) As Long
    'reallocate block of memory
    'USE: hMem = GMemReAlloc(hMem, newSize)
    If newSize = 0 Then
        If hMem Then GlobalFree(ByVal hMem)
        Function = boolNull
    Else
        If hMem Then
            Function = GlobalReAlloc(ByVal hMem, ByVal newSize, ByVal %GMemGMEM_MOVEABLE Or %GMemGMEM_ZEROINIT)
        Else
            Function = GlobalAlloc(ByVal %GMemGPTR, ByVal newSize)
        End If
    End If
End Function
Sub GMemCopy(ByVal copyTo As Long, ByVal copyFrom As Long, ByVal byteCount As Long)
    'copy/move block of memory
    MoveMemory(ByVal copyTo, ByVal copyFrom, ByVal byteCount)
End Sub
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

    Comment

    • #3
      Code:
       'LArr.inc
#Include Once "GMem1.inc"
' ------------------------------------------------------------------------
Macro McLArrType = Long
Macro McLArrSize = 4
' ------------------------------------------------------------------------
    '
    'Dynamic Long Array lite Obj
    '   access array with Long Handle - store in UDT
    '   ZERO based index
    '
    '   ReDim automatic
    '       insert, add ~ array automatically grows
    '       delete      ~ array automatically shrinks
    '
' ------------------------------------------------------------------------
Type LArrT
    Count As Long
    pa As McLArrType Ptr
End Type
' ------------------------------------------------------------------------
 
Function LArrAlloc() As Long
    'allocate new array - return handle
    '   MUST be freed: LArrFree()
    Function = GMemAlloc(SizeOf(LArrT))
End Function
Function LArrFree(ByVal p As LArrT Ptr) As Long
    'free allocated array
    '   h = LArrFree(h)
    If p Then
        LArrClear p
        GMemFree(p)
    End If
    Function = 0
End Function
Sub LArrClear(ByVal p As LArrT Ptr)
    'delete all data
    If p Then
        If @p.count Then @p.pa = GMemFree(@p.pa)
        @p.pa = boolNull
        @p.count = 0
    End If
End Sub
Function LArrCount(ByVal p As LArrT Ptr) As Long
    'get item count
    If p Then
        Function = @p.count
    End If
End Function
Sub LArrReDim(ByVal p As LArrT Ptr, ByVal Count As Long)
    'ReDim array - data preserved
    If p Then
        If Count = 0 Then
            LArrClear p
        ElseIf Count <> @p.count Then
            @p.pa = GMemReAlloc(@p.pa, Count * McLArrSize)
            @p.count = IIf&(@p.pa, Count, 0)
        End If
    End If
End Sub
Sub LArrAdd(ByVal p As LArrT Ptr, ByVal item As McLArrType)
    'append item to end of array
    '   ReDim automatic
    If p Then
        LArrReDim p, @p.count + 1
        If @p.count Then @[email protected][@p.count - 1] = item
    End If
End Sub
Sub LArrInsert(ByVal p As LArrT Ptr, ByVal index As Long, ByVal item As McLArrType)
    'insert item before index
    '   ReDim automatic
    If p Then
        If index >= 0 And index < @p.count Then
            LArrReDim p, @p.count + 1
            If @p.count Then
                LArrMove(p, index + 1, index, @p.count - index - 1)
                @[email protected][index] = item
            End If
        End If
    End If
End Sub
Sub LArrDelete(ByVal p As LArrT Ptr, ByVal index As Long)
    'delete item at index
    '   ReDim automatic
    If p Then
        If index >= 0 And index < @p.count Then
            If @p.count = 1 Then
                LArrClear p
            Else
                If index < @p.count - 1 Then LArrMove(p, index, index + 1, @p.count - index - 1)
                LArrReDim p, @p.count - 1
            End If
        End If
    End If
End Sub
Sub LArrSet(ByVal p As LArrT Ptr, ByVal index As Long, ByVal item As McLArrType)
    'set item at index
    If p Then
        If index >= 0 And index < @p.count Then
            @[email protected][index] = item
        End If
    End If
End Sub
Function LArrGet(ByVal p As LArrT Ptr, ByVal index As Long) As McLArrType
    'get item
    If p Then
        If index >= 0 And index < @p.count Then
            Function = @[email protected][index]
        End If
    End If
End Function
' ------------------------------------------------------------------------
    'stack functions
' ------------------------------------------------------------------------
Sub LArrPush(ByVal p As LArrT Ptr, ByVal item As McLArrType)
    'push item on stack
    If p Then
        LArrReDim p, @p.count + 1
        If @p.count Then @[email protected][@p.count - 1] = item
    End If
End Sub
Function LArrPeek(ByVal p As LArrT Ptr) As McLArrType
    'get item on top of stack
    If p Then
        If @p.count Then
            Function = @[email protected][@p.count - 1]
        End If
    End If
End Function
Function LArrPop(ByVal p As LArrT Ptr) As McLArrType
    'pop item off top of stack
    If p Then
        If @p.count Then
            Function = @[email protected][@p.count - 1]
            LArrReDim p, @p.count - 1
        End If
    End If
End Function
Sub LArrMove(ByVal p As LArrT Ptr, ByVal toIndex As Long, ByVal fromIndex As Long, ByVal Count As Long)
    'internal - move block of elements
    GMemCopy @p.pa + (toIndex * McLArrSize), @p.pa + (fromIndex * McLArrSize), Count * McLArrSize
End Sub
      Last edited by Stanley Durham; 23 Jul 2009, 12:02 PM.
      stanthemanstan~gmail
      Dead Theory Walking
      Range Trie Tree
      HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

      Comment

      • #4
        Code:
        'BArr.inc
#Include Once "GMem1.inc"
' ------------------------------------------------------------------------
Macro McBArrType = Byte
Macro McBArrSize = 1
' ------------------------------------------------------------------------
    '
    'Dynamic Byte Array lite Obj
    '   access array with Long Handle
    '   ZERO based index
    '
    '   ReDim automatic
    '       insert, add ~ array automatically grows
    '       delete      ~ array automatically shrinks
    '
' ------------------------------------------------------------------------
Type BArrT
    Count As Long
    pa As McBArrType Ptr
End Type
' ------------------------------------------------------------------------
 
Function BArrAlloc() As Long
    'allocate new array - return handle
    '   MUST be freed: BArrFree()
    Function = GMemAlloc(SizeOf(BArrT))
End Function
Function BArrFree(ByVal p As BArrT Ptr) As Long
    'free allocated array
    '   h = BArrFree(h)
    If p Then
        BArrClear p
        GMemFree(p)
    End If
    Function = 0
End Function
Sub BArrClear(ByVal p As BArrT Ptr)
    'delete all data
    If p Then
        If @p.count Then @p.pa = GMemFree(@p.pa)
        @p.pa = boolNull
        @p.count = 0
    End If
End Sub
Function BArrCount(ByVal p As BArrT Ptr) As Long
    'get item count
    If p Then
        Function = @p.count
    End If
End Function
Sub BArrReDim(ByVal p As BArrT Ptr, ByVal Count As Long)
    'ReDim array - data preserved
    If p Then
        If Count = 0 Then
            BArrClear p
        ElseIf Count <> @p.count Then
            @p.pa = GMemReAlloc(@p.pa, Count * McBArrSize)
            @p.count = IIf&(@p.pa, Count, 0)
        End If
    End If
End Sub
Sub BArrAdd(ByVal p As BArrT Ptr, ByVal item As McBArrType)
    'append item to end of array
    '   ReDim automatic
    If p Then
        BArrReDim p, @p.count + 1
        If @p.count Then @[email protected][@p.count - 1] = item
    End If
End Sub
Sub BArrInsert(ByVal p As BArrT Ptr, ByVal index As Long, ByVal item As McBArrType)
    'insert item before index
    '   ReDim automatic
    If p Then
        If index >= 0 And index < @p.count Then
            BArrReDim p, @p.count + 1
            If @p.count Then
                BArrMove(p, index + 1, index, @p.count - index - 1)
                @[email protected][index] = item
            End If
        End If
    End If
End Sub
Sub BArrDelete(ByVal p As BArrT Ptr, ByVal index As Long)
    'delete item at index
    '   ReDim automatic
    If p Then
        If index >= 0 And index < @p.count Then
            If @p.count = 1 Then
                BArrClear p
            Else
                If index < @p.count - 1 Then BArrMove(p, index, index + 1, @p.count - index - 1)
                BArrReDim p, @p.count - 1
            End If
        End If
    End If
End Sub
Sub BArrSet(ByVal p As BArrT Ptr, ByVal index As Long, ByVal item As McBArrType)
    'set item at index
    If p Then
        If index >= 0 And index < @p.count Then
            @[email protected][index] = item
        End If
    End If
End Sub
Function BArrGet(ByVal p As BArrT Ptr, ByVal index As Long) As McBArrType
    'get item
    If p Then
        If index >= 0 And index < @p.count Then
            Function = @[email protected][index]
        End If
    End If
End Function
' ------------------------------------------------------------------------
    'stack functions
' ------------------------------------------------------------------------
Sub BArrPush(ByVal p As BArrT Ptr, ByVal item As McBArrType)
    'push item on stack
    If p Then
        BArrReDim p, @p.count + 1
        If @p.count Then @[email protected][@p.count - 1] = item
    End If
End Sub
Function BArrPeek(ByVal p As BArrT Ptr) As McBArrType
    'get item on top of stack
    If p Then
        If @p.count Then
            Function = @[email protected][@p.count - 1]
        End If
    End If
End Function
Function BArrPop(ByVal p As BArrT Ptr) As McBArrType
    'pop item off top of stack
    If p Then
        If @p.count Then
            Function = @[email protected][@p.count - 1]
            BArrReDim p, @p.count - 1
        End If
    End If
End Function
Sub BArrMove(ByVal p As BArrT Ptr, ByVal toIndex As Long, ByVal fromIndex As Long, ByVal Count As Long)
    'internal - move block of elements
    GMemCopy @p.pa + (toIndex * McBArrSize), @p.pa + (fromIndex * McBArrSize), Count * McBArrSize
End Sub
        Last edited by Stanley Durham; 23 Jul 2009, 12:03 PM.
        stanthemanstan~gmail
        Dead Theory Walking
        Range Trie Tree
        HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

        Comment

        • #5
          Code:
          'StrBuff.inc
 
    'Dynamic String lite obj
    '   store dynamic strings in UDTs
    '
    '   strings stored in buffer - hold any kind of data
    '
    '   uses Byte array to hold characters
 
#Include Once "GMem1.inc"
#Include Once "BArr.inc"
'inherit Byte array :)
Macro StrBuffT = BArrT
Function StrBuffAlloc() As Long
    'allocate new string - return handle
    Function = BArrAlloc()
End Function
Function StrBuffFree(ByVal p As StrBuffT Ptr) As Long
    'close string - free resources
    Function = BArrFree(p)
End Function
Function StrBuffLen(ByVal p As StrBuffT Ptr) As Long
    'get string length
    If p Then Function = @p.count
End Function
Sub StrBuffSet(ByVal p As StrBuffT Ptr, ByRef s As String)
    'store string
    If p Then
        BArrReDim p, Len(s)
        If @p.count Then Poke$ @p.pa, s
    End If
End Sub
Function StrBuffGet(ByVal p As StrBuffT Ptr) As String
    'get stored string
    If p And @p.count Then Function = Peek$(@p.pa, @p.count)
End Function
Function StrBuffAllocSet(ByRef s As String) As Long
    'allocate new string buffer
    '   set string
    '   return handle
    Local h As Long
    h = StrBuffAlloc()
    StrBuffSet h, s
    Function = h
End Function
          Last edited by Stanley Durham; 23 Jul 2009, 12:04 PM.
          stanthemanstan~gmail
          Dead Theory Walking
          Range Trie Tree
          HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

          Comment

          • #6
            Code:
             
'SArr.inc
 
    'Dynamic String Array lite obj
    '   access array with Long Handle - store in UDT
    '   ZERO based index
    '
    '   strings stored in buffer - hold any kind of data
    '
    '   ReDim automatic
    '       insert, add ~ array automatically grows
    '       delete      ~ array automatically shrinks
    '
    '   String Array = Long Array of Byte Arrays
 
' ------------------------------------------------------------------------
#Include Once "GMem1.inc"
#Include Once "LArr.inc"
#Include Once "BArr.inc"
#Include Once "StrBuff.inc"
' ------------------------------------------------------------------------
'inherit Long Array :)
Macro SArrT = LArrT
' ------------------------------------------------------------------------
 
Function SArrAlloc() As Long
    'allocate new array - return handle
    '   MUST be freed: SArrFree()
    Function = LArrAlloc()
End Function
Function SArrFree(ByVal p As SArrT Ptr) As Long
    'free allocated array
    '   h = SArrFree(h)
    If p Then
        SArrClear p
        p = LArrFree(p)
    End If
    Function = 0
End Function
Sub SArrClear(ByVal p As SArrT Ptr)
    'delete all data
    If p Then
        If @p.count Then
            Local i As Long
            For i = 0 To @p.count - 1
                StrBuffFree(@[email protected][i]) 'free strings
            Next i
            @p.pa = GMemFree(@p.pa)
        End If
        @p.pa = boolNull
        @p.count = 0
    End If
End Sub
Function SArrCount(ByVal p As SArrT Ptr) As Long
    'get item count
    If p Then Function = @p.count
End Function
Sub SArrAdd(ByVal p As SArrT Ptr, ByRef item As String)
    'append item to end of array
    '   ReDim automatic
    LArrAdd p, StrBuffAllocSet(item)
End Sub
Sub SArrInsert(ByVal p As SArrT Ptr, ByVal index As Long, ByRef item As String)
    'insert item before index
    '   ReDim automatic
    LArrInsert p, index, StrBuffAllocSet(item)
End Sub
Sub SArrDelete(ByVal p As SArrT Ptr, ByVal index As Long)
    'delete item at index
    '   ReDim automatic
    StrBuffFree(LArrGet(p, index))
    LArrDelete p, index
End Sub
Sub SArrSet(ByVal p As SArrT Ptr, ByVal index As Long, ByRef item As String)
    'set item at index
    StrBuffSet LArrGet(p, index), item
End Sub
Function SArrGet(ByVal p As SArrT Ptr, ByVal index As Long) As String
    'get item
    Function = StrBuffGet(LArrGet(p, index))
End Function
' ------------------------------------------------------------------------
    'stack functions
' ------------------------------------------------------------------------
Sub SArrPush(ByVal p As SArrT Ptr, ByRef item As String)
    'push item on stack
    SArrAdd p, item
End Sub
Function SArrPeek(ByVal p As SArrT Ptr) As String
    'get item on top of stack
    Function = StrBuffGet(LArrPeek(p))
End Function
Function SArrPop(ByVal p As SArrT Ptr) As String
    'pop item off top of stack
    Function = StrBuffGet(LArrPeek(p))
    StrBuffFree(LArrPop(p))
End Function
            Last edited by Stanley Durham; 23 Jul 2009, 12:04 PM.
            stanthemanstan~gmail
            Dead Theory Walking
            Range Trie Tree
            HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

            Comment

            • #7
              Code:
              'DArr.inc
 
#Include Once "GMem1.inc"
' ------------------------------------------------------------------------
Macro McDArrType = Double
Macro McDArrSize = 8
' ------------------------------------------------------------------------
    '
    'Dynamic Double Array lite Obj
    '   access array with Long Handle - store in UDT
    '   ZERO based index
    '
    '   ReDim automatic
    '       insert, add ~ array automatically grows
    '       delete      ~ array automatically shrinks
    '
' ------------------------------------------------------------------------
Type DArrT
    Count As Long
    pa As McDArrType Ptr
End Type
' ------------------------------------------------------------------------
 
Function DArrAlloc() As Long
    'allocate new array - return handle
    '   MUST be freed: DArrFree()
    Function = GMemAlloc(SizeOf(DArrT))
End Function
Function DArrFree(ByVal p As DArrT Ptr) As Long
    'free allocated array
    '   h = DArrFree(h)
    If p Then
        DArrClear p
        GMemFree(p)
    End If
    Function = 0
End Function
Sub DArrClear(ByVal p As DArrT Ptr)
    'delete all data
    If p Then
        If @p.count Then @p.pa = GMemFree(@p.pa)
        @p.pa = boolNull
        @p.count = 0
    End If
End Sub
Function DArrCount(ByVal p As DArrT Ptr) As Long
    'get item count
    If p Then
        Function = @p.count
    End If
End Function
Sub DArrReDim(ByVal p As DArrT Ptr, ByVal Count As Long)
    'ReDim array - data preserved
    If p Then
        If Count = 0 Then
            DArrClear p
        ElseIf Count <> @p.count Then
            @p.pa = GMemReAlloc(@p.pa, Count * McDArrSize)
            @p.count = IIf&(@p.pa, Count, 0)
        End If
    End If
End Sub
Sub DArrAdd(ByVal p As DArrT Ptr, ByVal item As McDArrType)
    'append item to end of array
    '   ReDim automatic
    If p Then
        DArrReDim p, @p.count + 1
        If @p.count Then @[email protected][@p.count - 1] = item
    End If
End Sub
Sub DArrInsert(ByVal p As DArrT Ptr, ByVal index As Long, ByVal item As McDArrType)
    'insert item before index
    '   ReDim automatic
    If p Then
        If index >= 0 And index < @p.count Then
            DArrReDim p, @p.count + 1
            If @p.count Then
                DArrMove(p, index + 1, index, @p.count - index - 1)
                @[email protected][index] = item
            End If
        End If
    End If
End Sub
Sub DArrDelete(ByVal p As DArrT Ptr, ByVal index As Long)
    'delete item at index
    '   ReDim automatic
    If p Then
        If index >= 0 And index < @p.count Then
            If @p.count = 1 Then
                DArrClear p
            Else
                If index < @p.count - 1 Then DArrMove(p, index, index + 1, @p.count - index - 1)
                DArrReDim p, @p.count - 1
            End If
        End If
    End If
End Sub
Sub DArrSet(ByVal p As DArrT Ptr, ByVal index As Long, ByVal item As McDArrType)
    'set item at index
    If p Then
        If index >= 0 And index < @p.count Then
            @[email protected][index] = item
        End If
    End If
End Sub
Function DArrGet(ByVal p As DArrT Ptr, ByVal index As Long) As McDArrType
    'get item
    If p Then
        If index >= 0 And index < @p.count Then
            Function = @[email protected][index]
        End If
    End If
End Function
' ------------------------------------------------------------------------
    'stack functions
' ------------------------------------------------------------------------
Sub DArrPush(ByVal p As DArrT Ptr, ByVal item As McDArrType)
    'push item on stack
    If p Then
        DArrReDim p, @p.count + 1
        If @p.count Then @[email protected][@p.count - 1] = item
    End If
End Sub
Function DArrPeek(ByVal p As DArrT Ptr) As McDArrType
    'get item on top of stack
    If p Then
        If @p.count Then
            Function = @[email protected][@p.count - 1]
        End If
    End If
End Function
Function DArrPop(ByVal p As DArrT Ptr) As McDArrType
    'pop item off top of stack
    If p Then
        If @p.count Then
            Function = @[email protected][@p.count - 1]
            DArrReDim p, @p.count - 1
        End If
    End If
End Function
Sub DArrMove(ByVal p As DArrT Ptr, ByVal toIndex As Long, ByVal fromIndex As Long, ByVal Count As Long)
    'internal - move block of elements
    GMemCopy @p.pa + (toIndex * McDArrSize), @p.pa + (fromIndex * McDArrSize), Count * McDArrSize
End Sub
              Last edited by Stanley Durham; 23 Jul 2009, 12:05 PM.
              stanthemanstan~gmail
              Dead Theory Walking
              Range Trie Tree
              HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

              Comment

              • #8
                Code:
                #PBForms CREATED V1.51
'pbwin 9
$TestSource = "LArrTest.bas"
$TestTitle = "Dynamic UDT Long Array Test"
#Compile Exe "LArrTest.exe"
#Dim All
#Optimize Speed
#Include Once "LArr.inc"
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
Type MyUDT
    h1 As Long 'array handles
    h2 As Long
    h3 As Long
End Type
Sub BtnTest(ByVal hDlg As Long)
    Local i, Count, top As Long
    lbx.Clear(2)
    'store arrays handles in UDT
    Local t As MyUDT
    'allocate new array instance
    t.h1 = LArrAlloc()
    t.h2 = LArrAlloc()
    t.h3 = LArrAlloc()
    Count = 1000000
    top = Count - 1
    lbx.Add("ReDim array "+Format$(Count,"#,"))
    LArrReDim t.h1, Count
    lbx.Add("fill array")
    tmr.Start()
    For i = 0 To top
        LArrSet(t.h1, i, i)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("make sure values are in array")
    tmr.Start()
    For i = 0 To top
        If LArrGet(t.h1, i) <> i Then
            lbx.Add("   !!! failed ad "+Format$(i)+" !!!")
        End If
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("clear array - delete all data")
    LArrClear t.h1
    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
    Count = 10000
    top = Count - 1
    lbx.Add("")
    lbx.Add("append "+Format$(Count,"#,")+" items to empty array")
    lbx.Add("    ReDim automatic")
    tmr.Start()
    For i = 0 To top
        LArrAdd(t.h1, i)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("delete every odd index in array")
    lbx.Add("    ReDim always automatic")
    tmr.Start()
    For i = top To 0 Step - 1
        If i Mod 2 Then LArrDelete(t.h1, i)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("Count = " + Format$(LArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("use array #2 and #3")
    For i = 0 To 5
        LArrAdd t.h2, i + 100
        LArrAdd t.h3, i + 100000
    Next i
    For i = 0 To 5
        lbx.Add( "array #2 = " + Format$(LArrGet(t.h2, i)) + " | array #3 = " +  Format$(LArrGet(t.h3, i)) )
    Next i
    lbx.Add("")
    lbx.Add("stack functions")
    LArrClear t.h1
    For i = 100 To 300 Step 50
        LArrPush t.h1, i
    Next i
    While LArrCount(t.h1)
        lbx.Add( "peek = " + Format$(LArrPeek(t.h1)) + " | pop = " + Format$(LArrPop(t.h1)) )
    Wend
    'free array handle before it goes out of scope
    t.h1 = LArrFree(t.h1)
    t.h2 = LArrFree(t.h2)
    t.h3 = LArrFree(t.h3)
    lbx.Add("")
    lbx.Add("done...")
End Sub
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(1000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance meTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            meTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(Timer - meTime, "###.###############")
        End Method
    End Interface
End Class
                stanthemanstan~gmail
                Dead Theory Walking
                Range Trie Tree
                HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

                Comment

                • #9
                  Code:
                   
#PBForms CREATED V1.51
'pbwin 9
$TestSource = "StrBuffTest.bas"
$TestTitle = "Dynamic String Buffer Test"
#Compile Exe "StrBuffTest.exe"
#Dim All
#Optimize Speed
#Include Once "StrBuff.inc"
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
Type MyUDT
    h1 As Long 'string handles
    h2 As Long
    h3 As Long
End Type
Sub BtnTest(ByVal hDlg As Long)
    lbx.Clear(2)
    'store string handles in UDT
    Local t As MyUDT
    'allocate new instance
    t.h1 = StrBuffAlloc()
    t.h2 = StrBuffAlloc()
    t.h3 = StrBuffAlloc()
    StrBuffSet t.h1, "testing 123"
    StrBuffSet t.h2, "testing 456"
    StrBuffSet t.h3, "testing 789"
    lbx.Add(StrBuffGet(t.h1))
    lbx.Add(StrBuffGet(t.h2))
    lbx.Add(StrBuffGet(t.h3))
    lbx.Add("")
    lbx.Add("modify strings")
    StrBuffSet t.h1, StrBuffGet(t.h1) + ", " + StrBuffGet(t.h1)
    StrBuffSet t.h2, StrBuffGet(t.h2) + ", " + StrBuffGet(t.h2)
    StrBuffSet t.h3, StrBuffGet(t.h3) + ", " + StrBuffGet(t.h3)
    lbx.Add("")
    lbx.Add(StrBuffGet(t.h1))
    lbx.Add(StrBuffGet(t.h2))
    lbx.Add(StrBuffGet(t.h3))

    'free string handle before it goes out of scope
    t.h1 = StrBuffFree(t.h1)
    t.h2 = StrBuffFree(t.h2)
    t.h3 = StrBuffFree(t.h3)
    lbx.Add("")
    lbx.Add("done...")
End Sub
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(1000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance meTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            meTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(Timer - meTime, "###.###############")
        End Method
    End Interface
End Class
                  stanthemanstan~gmail
                  Dead Theory Walking
                  Range Trie Tree
                  HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

                  Comment

                  • #10
                    Code:
                     
#PBForms CREATED V1.51
'pbwin 9
$TestSource = "SArrTest.bas"
$TestTitle = "Dynamic UDT String Array Test"
#Compile Exe "SArrTest.exe"
#Dim All
#Optimize Speed
#Include Once "SArr.inc"
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
Type MyUDT
    h1 As Long 'array handles
    h2 As Long
    h3 As Long
End Type
Sub BtnTest(ByVal hDlg As Long)
    Local i, Count, top As Long
    lbx.Clear(2)
    'store arrays handles in UDT
    Local t As MyUDT
    'allocate new array instance
    t.h1 = SArrAlloc()
    t.h2 = SArrAlloc()
    t.h3 = SArrAlloc()
    Count = 10000
    top = Count - 1
    lbx.Add("")
    lbx.Add("append "+Format$(Count,"#,")+" items to empty array")
    lbx.Add("    ReDim automatic")
    tmr.Start()
    For i = 0 To top
        SArrAdd(t.h1, Format$(i))
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("Count = " + Format$(SArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("make sure values are in array")
    tmr.Start()
    For i = 0 To top
        If SArrGet(t.h1, i) <> Format$(i) Then
            lbx.Add("   !!! failed ad "+Format$(i)+" !!!")
        End If
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("delete every odd index in array")
    lbx.Add("    ReDim always automatic")
    tmr.Start()
    For i = top To 0 Step - 1
        If i Mod 2 Then SArrDelete(t.h1, i)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("Count = " + Format$(SArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("use array #2 and #3")
    For i = 0 To 5
        SArrAdd t.h2, Format$(i, "000")
        SArrAdd t.h3, Format$(i * 1000, "00000000")
    Next i
    For i = 0 To 5
        lbx.Add( "array #2 = " + SArrGet(t.h2, i) + " | array #3 = " +  SArrGet(t.h3, i) )
    Next i
    lbx.Add("")
    lbx.Add("stack functions")
    SArrClear t.h1
    For i = 100 To 300 Step 50
        SArrPush t.h1, Format$(i, "0000000000")
    Next i
    While SArrCount(t.h1)
        lbx.Add( "peek = " + SArrPeek(t.h1) + " | pop = " + SArrPop(t.h1) )
    Wend
    'free array handle before it goes out of scope
    t.h1 = SArrFree(t.h1)
    t.h2 = SArrFree(t.h2)
    t.h3 = SArrFree(t.h3)
    lbx.Add("")
    lbx.Add("done...")
End Sub
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(1000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance meTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            meTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(Timer - meTime, "###.###############")
        End Method
    End Interface
End Class
                    stanthemanstan~gmail
                    Dead Theory Walking
                    Range Trie Tree
                    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

                    Comment

                    • #11
                      Code:
                      #PBForms CREATED V1.51
'pbwin 9
$TestSource = "DArrTest.bas"
$TestTitle = "Dynamic UDT Double Array Test"
#Compile Exe "DArrTest.exe"
#Dim All
#Optimize Speed
#Include Once "DArr.inc"
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
Type MyUDT
    h1 As Long 'array handles
    h2 As Long
    h3 As Long
End Type
Sub BtnTest(ByVal hDlg As Long)
    Local i, Count, top As Long
    Local d As Double
    lbx.Clear(2)
    'store arrays handles in UDT
    Local t As MyUDT
    'allocate new array instance
    t.h1 = DArrAlloc()
    t.h2 = DArrAlloc()
    t.h3 = DArrAlloc()
    Count = 100000
    top = Count - 1
    lbx.Add("ReDim array "+Format$(Count,"#,"))
    DArrReDim t.h1, Count
    lbx.Add("fill array")
    tmr.Start()
    For i = 0 To top
        d = i * 1.33
        DArrSet(t.h1, i, d)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("Count = " + Format$(DArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("make sure values are in array")
    tmr.Start()
    For i = 0 To top
        If DArrGet(t.h1, i) <> i * 1.33 Then
            lbx.Add("   !!! failed ad "+Format$(i)+" !!!")
        End If
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("clear array - delete all data")
    DArrClear t.h1
    lbx.Add("Count = " + Format$(DArrCount(t.h1)))
    Count = 10000
    top = Count - 1
    lbx.Add("")
    lbx.Add("append "+Format$(Count,"#,")+" items to empty array")
    lbx.Add("    ReDim automatic")
    tmr.Start()
    For i = 0 To top
        d = i * 1.33
        DArrAdd(t.h1, d)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("Count = " + Format$(DArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("delete every odd index in array")
    lbx.Add("    ReDim always automatic")
    tmr.Start()
    For i = top To 0 Step - 1
        If i Mod 2 Then DArrDelete(t.h1, i)
    Next i
    lbx.Add(tmr.Get())
    lbx.Add("")
    lbx.Add("Count = " + Format$(DArrCount(t.h1)))
    lbx.Add("")
    lbx.Add("use array #2 and #3")
    For i = 0 To 5
        DArrAdd t.h2, (1 * 100) / .33
        DArrAdd t.h3, (i * 10000) / 1.66
    Next i
    For i = 0 To 5
        lbx.Add( "array #2 = " + Format$(DArrGet(t.h2, i)) + " | array #3 = " +  Format$(DArrGet(t.h3, i)) )
    Next i
    lbx.Add("")
    lbx.Add("stack functions")
    DArrClear t.h1
    For i = 100 To 300 Step 50
        d = i * 1.33
        DArrPush t.h1, d
    Next i
    While DArrCount(t.h1)
        lbx.Add( "peek = " + Format$(DArrPeek(t.h1)) + " | pop = " + Format$(DArrPop(t.h1)) )
    Wend
    'free array handle before it goes out of scope
    t.h1 = DArrFree(t.h1)
    t.h2 = DArrFree(t.h2)
    t.h3 = DArrFree(t.h3)
    lbx.Add("")
    lbx.Add("done...")
End Sub
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(1000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance meTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            meTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(Timer - meTime, "###.###############")
        End Method
    End Interface
End Class
                      stanthemanstan~gmail
                      Dead Theory Walking
                      Range Trie Tree
                      HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

                      Comment

                      Previous template Next
                      Working...
                      X

                      We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

                      By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

                      I Agree