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: