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
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Stanley Durham
    replied
    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

    Leave a comment:


  • Stanley Durham
    replied
    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

    Leave a comment:


  • Stanley Durham
    replied
    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

    Leave a comment:


  • Stanley Durham
    replied
    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

    Leave a comment:


  • Stanley Durham
    replied
    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
                @p[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.

    Leave a comment:


  • Stanley Durham
    replied
    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.

    Leave a comment:


  • Stanley Durham
    replied
    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.

    Leave a comment:


  • Stanley Durham
    replied
    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.

    Leave a comment:


  • Stanley Durham
    replied
    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.

    Leave a comment:


  • Stanley Durham
    replied
    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

    Leave a comment:


  • 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.
Working...
X