sorting collection

OlimilO1402 · Jun 16, 2024 · 04889e3 · 04889e3
1 parent c52667f
commit 04889e3
Show file tree

Hide file tree

Showing 11 changed files with 247 additions and 73 deletions.
diff --git a/Classes/Class1.cls b/Classes/Class1.cls
@@ -14,8 +14,28 @@ Attribute VB_Exposed = False
 Option Explicit
 
 'just a dummy-class
-Public Value As Double
+Private m_Value As Double
 
-Public Function ToStr()
-    ToStr = CStr(Value)
+Friend Sub New_(ByVal Value As Double)
+    m_Value = Value
+End Sub
+
+Public Property Get Value() As Double
+    Value = m_Value
+End Property
+
+Public Property Get Ptr() As LongPtr
+    Ptr = ObjPtr(Me)
+End Property
+
+Public Property Get Key() As String
+    Key = Ptr
+End Property
+
+Public Function ToStr() As String
+    ToStr = Format(m_Value, "###,###,###,##0.000")
+End Function
+
+Public Function Compare(other As Class1) As Long
+    Compare = Me.Value - other.Value
 End Function
diff --git a/Forms/FMain.frm b/Forms/FMain.frm
@@ -7,7 +7,7 @@ Begin VB.Form FMain
    ClientWidth     =   4560
    BeginProperty Font 
       Name            =   "Segoe UI"
-      Size            =   8.25
+      Size            =   9
       Charset         =   0
       Weight          =   400
       Underline       =   0   'False
@@ -20,52 +20,52 @@ Begin VB.Form FMain
    ScaleMode       =   3  'Pixel
    ScaleWidth      =   304
    StartUpPosition =   3  'Windows-Standard
-   Begin VB.CommandButton Command1 
+   Begin VB.CommandButton BtnTestVBCollection 
       Caption         =   "Test VB.Collection"
       Height          =   375
-      Left            =   240
+      Left            =   120
       TabIndex        =   5
-      Top             =   2640
+      Top             =   2520
       Width           =   1935
    End
    Begin VB.CommandButton BtnTestObjPtr 
       Caption         =   "Test ObjPtr"
       Height          =   375
-      Left            =   240
+      Left            =   120
       TabIndex        =   4
-      Top             =   1680
+      Top             =   1560
       Width           =   1935
    End
    Begin VB.CommandButton BtnTSafeArrayPtr 
       Caption         =   "Test SafeArrayPtr"
       Height          =   375
-      Left            =   240
+      Left            =   120
       TabIndex        =   3
-      Top             =   720
+      Top             =   600
       Width           =   1935
    End
    Begin VB.CommandButton BtnTestSAPtr 
       Caption         =   "Test SAPtr"
       Height          =   375
-      Left            =   240
+      Left            =   120
       TabIndex        =   2
-      Top             =   2160
+      Top             =   2040
       Width           =   1935
    End
    Begin VB.CommandButton BtnTestArrayPointer 
       Caption         =   "Test Array-Pointer"
       Height          =   375
-      Left            =   240
+      Left            =   120
       TabIndex        =   1
-      Top             =   1200
+      Top             =   1080
       Width           =   1935
    End
    Begin VB.CommandButton BtnTestCharArray 
       Caption         =   "Test Char-Pointer"
       Height          =   375
-      Left            =   240
+      Left            =   120
       TabIndex        =   0
-      Top             =   240
+      Top             =   120
       Width           =   1935
    End
 End
@@ -109,3 +109,9 @@ Private Sub BtnTestSAPtr_Click()
 
     ZeroSAPtr StrArrPtr(saX)
 End Sub
+
+Private Sub BtnTestVBCollection_Click()
+    Form5.Show vbModal, Me
+End Sub
+
+
diff --git a/Forms/Form1.frm b/Forms/Form1.frm
@@ -252,13 +252,13 @@ Private Sub BtnCharPtrWalk_Click()
 
     Dim i As Long
     Dim c As Integer
-    Dim cp As TCharPointer: Call New_CharPointer(cp, mStrVal)
+    Dim cp As MPtr.TCharPointer: MPtr.New_CharPointer cp, mStrVal
     For i = 1 To Len(mStrVal)
         c = cp.Chars(i)
     Next
-    Call DeleteCharPointer(cp)
+    DeleteCharPointer cp
 
-    Call MessStop(mp)
+    MessStop mp
 
 End Sub
 
@@ -267,7 +267,7 @@ Private Sub BtnWalkBArrAnsi_Click()
     If LenB(mStrVal) = 0 Then Call BuildString
 
     Dim mp As MousePointerConstants
-    Call Start(mp)
+    Start mp
 
     Dim i As Long
     Dim c As Byte
@@ -277,16 +277,16 @@ Private Sub BtnWalkBArrAnsi_Click()
         c = bArray(i)
     Next
 
-    Call MessStop(mp)
+    MessStop mp
 
 End Sub
 
 Private Sub BtnWalkBArrUnic_Click()
 
-    If LenB(mStrVal) = 0 Then Call BuildString
+    If LenB(mStrVal) = 0 Then BuildString
 
     Dim mp As MousePointerConstants
-    Call Start(mp)
+    Start mp
 
     Dim i As Long
     Dim c As Byte
@@ -296,7 +296,7 @@ Private Sub BtnWalkBArrUnic_Click()
         c = bArray(i)
     Next
 
-    Call MessStop(mp)
+    MessStop mp
 
 End Sub
 

diff --git a/Forms/Form3.frm b/Forms/Form3.frm
@@ -66,19 +66,19 @@ Private Type TAnyType
 End Type
 
 Private Sub Command1_Click()
-    Call TestLongArray
+    TestLongArray
 End Sub
 
 Private Sub Command2_Click()
-    Call TestStringArray
+    TestStringArray
 End Sub
 
 Private Sub Command3_Click()
-    Call TestUDTypeArray
+    TestUDTypeArray
 End Sub
 
 Private Sub Command4_Click()
-    Call TestObjectArray
+    TestObjectArray
 End Sub
 
 Private Sub TestLongArray()
@@ -100,7 +100,7 @@ Private Sub TestLongArray()
     'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
     'entweder wieder über das Property, oder mit einer Nuller-Funktion
     'SAPtr(ArrPtr(lngArr2)) = 0
-    Call ZeroSAPtr(ArrPtr(lngArr2))
+    ZeroSAPtr ArrPtr(lngArr2)
 End Sub
 
 Private Sub TestStringArray()
@@ -122,7 +122,7 @@ Private Sub TestStringArray()
     'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
     'entweder wieder über das Property, oder mit einer Nuller-Funktion
     'SAPtr(StrArrPtr(strArr2)) = 0
-    Call ZeroSAPtr(StrArrPtr(strArr2))
+    ZeroSAPtr StrArrPtr(strArr2)
 End Sub
 
 Private Sub TestUDTypeArray()
@@ -150,7 +150,7 @@ Private Sub TestUDTypeArray()
     'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
     'entweder wieder über das Property, oder mit einer Nuller-Funktion
     'SAPtr(StrArrPtr(strArr2)) = 0
-    Call ZeroSAPtr(ArrPtr(udtArr2))
+    ZeroSAPtr ArrPtr(udtArr2)
 End Sub
 
 Private Function TAnyTypeToStr(A As TAnyType) As String
@@ -164,8 +164,8 @@ End Function
 
 Private Sub TestObjectArray()
     ReDim objArr1(0 To 1) As Class1
-    Set objArr1(0) = New_Class1(123456789.123456)
-    Set objArr1(1) = New_Class1(987654321.987654)
+    Set objArr1(0) = MNew.Class1(123456789.123456)
+    Set objArr1(1) = MNew.Class1(987654321.987654)
 
     'der Zeiger wird von objArr1 ausgelesen und in objArr2 hineinkopiert,
     'das manipulierte Array ist objArr2
@@ -183,10 +183,10 @@ Private Sub TestObjectArray()
     'beide Arrays zu löschen, bzw den Speicher wieder frei zu geben.
     'entweder wieder über das Property, oder mit einer Nuller-Funktion
     'SAPtr(StrArrPtr(strArr2)) = 0
-    Call ZeroSAPtr(ArrPtr(objArr2))
+    ZeroSAPtr ArrPtr(objArr2)
 
 End Sub
-
-Public Function New_Class1(ByVal aValue As Double) As Class1
-    Set New_Class1 = New Class1: New_Class1.Value = aValue
-End Function
+'
+'Public Function New_Class1(ByVal aValue As Double) As Class1
+'    Set New_Class1 = New Class1: New_Class1.Value = aValue
+'End Function