diff --git a/Classes/Class1.cls b/Classes/Class1.cls index 0cd6311..950e9ac 100644 --- 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 index eba3bbb..1383212 100644 --- 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 index 339baa0..e9e6677 100644 --- 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 index 9d7f322..7b01479 100644 --- 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 diff --git a/Forms/Form5.frm b/Forms/Form5.frm index a3b4210..f3357e9 100644 --- a/Forms/Form5.frm +++ b/Forms/Form5.frm @@ -1,14 +1,92 @@ VERSION 5.00 Begin VB.Form Form5 - Caption = "Form5" - ClientHeight = 6060 + Caption = "Test VB.Collection" + ClientHeight = 11820 ClientLeft = 120 ClientTop = 465 - ClientWidth = 11955 + ClientWidth = 5790 + BeginProperty Font + Name = "Segoe UI" + Size = 9.75 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Icon = "Form5.frx":0000 LinkTopic = "Form5" - ScaleHeight = 6060 - ScaleWidth = 11955 + ScaleHeight = 11820 + ScaleWidth = 5790 StartUpPosition = 3 'Windows-Standard + Begin VB.CommandButton BtnSort + Caption = "Sort" + BeginProperty Font + Name = "Segoe UI" + Size = 9 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 375 + Left = 1200 + TabIndex = 3 + Top = 360 + Width = 1215 + End + Begin VB.ComboBox CmbVarType + BeginProperty Font + Name = "Consolas" + Size = 9.75 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 345 + Left = 0 + TabIndex = 2 + Text = "Combo1" + Top = 0 + Width = 2415 + End + Begin VB.CommandButton BtnCreate + Caption = "Create" + BeginProperty Font + Name = "Segoe UI" + Size = 9 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 375 + Left = 0 + TabIndex = 1 + Top = 360 + Width = 1215 + End + Begin VB.ListBox List1 + Appearance = 0 '2D + BeginProperty Font + Name = "Consolas" + Size = 9 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 11580 + Left = 2520 + TabIndex = 0 + Top = 120 + Width = 3135 + End End Attribute VB_Name = "Form5" Attribute VB_GlobalNameSpace = False @@ -16,4 +94,69 @@ Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit +Private m_Col As Collection + +Private Sub Form_Load() + Randomize Timer + InitCmbVarType +End Sub + +Sub InitCmbVarType() + Dim i As Integer + With CmbVarType + .Clear + .AddItem "Byte (uint8) ": .ItemData(i) = VbVarType.vbByte: i = i + 1 + .AddItem "Integer (sint16) ": .ItemData(i) = VbVarType.vbInteger: i = i + 1 + .AddItem "Long (sint32) ": .ItemData(i) = VbVarType.vbLong: i = i + 1 + .AddItem "Single (flt32) ": .ItemData(i) = VbVarType.vbSingle: i = i + 1 + .AddItem "Double (flt64) ": .ItemData(i) = VbVarType.vbDouble: i = i + 1 + .AddItem "Currency (sint64) ": .ItemData(i) = VbVarType.vbCurrency: i = i + 1 + .AddItem "Decimal (sint128)": .ItemData(i) = VbVarType.vbDecimal: i = i + 1 + .AddItem "Date ": .ItemData(i) = VbVarType.vbDate: i = i + 1 + .AddItem "String ": .ItemData(i) = VbVarType.vbString: i = i + 1 + .AddItem "Object ": .ItemData(i) = VbVarType.vbObject: i = i + 1 + .ListIndex = 0 + End With +End Sub + +Private Sub BtnCreate_Click() + Set m_Col = New Collection + Dim i As Long: i = CmbVarType.ListIndex + If i < 0 Then Exit Sub + Dim y As Integer: y = Year(Now) + Dim vt As VbVarType: vt = CmbVarType.ItemData(i) + Dim n As Long: n = CLng(20 + Rnd() * 100) + Select Case vt + Case VbVarType.vbByte: For i = 0 To n: m_Col.Add CByte(Rnd * 255): Next + Case VbVarType.vbInteger: For i = 0 To n: m_Col.Add CInt(Rnd * 32767): Next + Case VbVarType.vbLong: For i = 0 To n: m_Col.Add CLng(Rnd * 1000000): Next + Case VbVarType.vbSingle: For i = 0 To n: m_Col.Add CSng(Rnd * 1000000!): Next + Case VbVarType.vbDouble: For i = 0 To n: m_Col.Add CDbl(Rnd * 2147484000#): Next + Case VbVarType.vbCurrency: For i = 0 To n: m_Col.Add CCur(Rnd * 2147484000@): Next + Case VbVarType.vbDecimal: For i = 0 To n: m_Col.Add CDec(Rnd * 2147484000#): Next + Case VbVarType.vbDate: For i = 0 To n: m_Col.Add DateSerial(CInt(Rnd * y), CInt(1 + Rnd * 11), CInt(1 + Rnd * 31)): Next + Case VbVarType.vbString: For i = 0 To n: m_Col.Add GetRndName(5 + Rnd * 22): Next + Case VbVarType.vbObject: For i = 0 To n: m_Col.Add MNew.Class1(Rnd * 10000000#): Next + End Select + UpdateView +End Sub + +Private Sub BtnSort_Click() + If m_Col Is Nothing Then Exit Sub + MPtr.Col_Sort m_Col + UpdateView +End Sub + +Private Function GetRndName(ByVal length As Byte) As String + Dim s As String: s = ChrW(65 + Rnd * 25) + Dim i As Long + For i = 2 To length + s = s & ChrW(97 + Rnd * 25) + Next + GetRndName = s +End Function + +Private Sub UpdateView() + MPtr.Col_ToListBox m_Col, Me.List1 +End Sub diff --git a/Forms/Form5.frx b/Forms/Form5.frx new file mode 100644 index 0000000..48fa1ce Binary files /dev/null and b/Forms/Form5.frx differ diff --git a/Modules/MCharPtr.bas b/Modules/MCharPtr.bas index f3eaf91..f20686b 100644 --- a/Modules/MCharPtr.bas +++ b/Modules/MCharPtr.bas @@ -1,22 +1,22 @@ Attribute VB_Name = "MCharPtr" Option Explicit -Public Type TCharPointer - pudt As TUDTPtr - Chars() As Integer -End Type - -Public Sub New_CharPointer(ByRef this As TCharPointer, ByRef StrVal As String) - With this - New_UDTPtr .pudt, FADF_AUTO Or FADF_FIXEDSIZE, 2, Len(StrVal), 1 - With .pudt - .pvData = StrPtr(StrVal) - End With - RtlMoveMemory ByVal ArrPtr(.Chars), ByVal VarPtr(.pudt), 4 - End With -End Sub - -Public Sub DeleteCharPointer(ByRef this As TCharPointer) - With this - RtlZeroMemory ByVal ArrPtr(.Chars), 4 - End With -End Sub +'Public Type TCharPointer +' pudt As TUDTPtr +' Chars() As Integer +'End Type +' +'Public Sub New_CharPointer(ByRef this As TCharPointer, ByRef StrVal As String) +' With this +' New_UDTPtr .pudt, FADF_AUTO Or FADF_FIXEDSIZE, 2, Len(StrVal), 1 +' With .pudt +' .pvData = StrPtr(StrVal) +' End With +' RtlMoveMemory ByVal ArrPtr(.Chars), ByVal VarPtr(.pudt), 4 +' End With +'End Sub +' +'Public Sub DeleteCharPointer(ByRef this As TCharPointer) +' With this +' RtlZeroMemory ByVal ArrPtr(.Chars), 4 +' End With +'End Sub diff --git a/Modules/MNew.bas b/Modules/MNew.bas index 5d9ac83..68ae814 100644 --- a/Modules/MNew.bas +++ b/Modules/MNew.bas @@ -2,5 +2,5 @@ Attribute VB_Name = "MNew" Option Explicit Public Function Class1(ByVal Value As Double) As Class1 - Set Class1 = New Class1: Class1.Value = Value + Set Class1 = New Class1: Class1.New_ Value End Function diff --git a/Modules/MPtr.bas b/Modules/MPtr.bas index 698a0d7..fbc253b 100644 --- a/Modules/MPtr.bas +++ b/Modules/MPtr.bas @@ -248,6 +248,11 @@ Public Function Col_Add(Col As Collection, Obj As Object) As Object Set Col_Add = Obj: Col.Add Obj End Function +'Public Function Col_Add(Col As Collection, Value) +' 'Nope just use eiter "Col.Add Value" or Col.Add Value, CStr(Value) +' Col_AddV = Value: Col.Add Value +'End Function + Public Function Col_AddKey(Col As Collection, Obj As Object) As Object Set Col_AddKey = Obj: Col.Add Obj, Obj.Key ' the object needs to have a Public Function Key As String End Function @@ -272,8 +277,8 @@ End Function Public Sub Col_Remove(Col As Collection, Obj As Object) Dim o As Object For Each o In Col - If o.IsSame(Obj) Then 'Object needs Public Function IsSame(other) As Boolean - If Col_Contains(Col, Obj.Key) Then Col.Remove Obj.Key 'Object needs Public Property Key As String + If o.IsSame(Obj) Then 'Obj needs Public Function IsSame(other) As Boolean + If Col_Contains(Col, Obj.Key) Then Col.Remove Obj.Key 'Obj needs Public Property Key As String End If Next End Sub @@ -469,7 +474,7 @@ End Function Private Function Col_CompareObj(ByVal i1 As Long, ByVal i2 As Long) As Long Dim Obj1 As Object: Set Obj1 = m_Col.Item(i1) Dim Obj2 As Object: Set Obj2 = m_Col.Item(i2) - Col_CompareObj = Obj1.compare(Obj2) + Col_CompareObj = Obj1.Compare(Obj2) End Function Private Sub Col_SwapObj(ByVal i1 As Long, ByVal i2 As Long) diff --git a/PVBPointers.vbp b/PVBPointers.vbp index 37aaf2d..b5419b3 100644 --- a/PVBPointers.vbp +++ b/PVBPointers.vbp @@ -23,9 +23,9 @@ Command32="" Name="PVBPointers" HelpContextID="0" CompatibleMode="0" -MajorVer=2023 -MinorVer=10 -RevisionVer=2 +MajorVer=2024 +MinorVer=6 +RevisionVer=16 AutoIncrementVer=0 ServerSupportFiles=0 VersionCompanyName="MBO-Ing.com" diff --git a/README.md b/README.md index 6bdcf3a..525bc9a 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![GitHub](https://img.shields.io/github/license/OlimilO1402/Ptr_Pointers?style=plastic)](https://github.com/OlimilO1402/Ptr_Pointers/blob/master/LICENSE) [![GitHub release (latest by date)](https://img.shields.io/github/v/release/OlimilO1402/Ptr_Pointers?style=plastic)](https://github.com/OlimilO1402/Ptr_Pointers/releases/latest) -[![Github All Releases](https://img.shields.io/github/downloads/OlimilO1402/Ptr_Pointers/total.svg)](https://github.com/OlimilO1402/Ptr_Pointers/releases/download/v2023.4.9/VBPointers_v2023.4.9.zip) +[![Github All Releases](https://img.shields.io/github/downloads/OlimilO1402/Ptr_Pointers/total.svg)](https://github.com/OlimilO1402/Ptr_Pointers/releases/download/v2024.06.16/VBPointers_v2024.06.16.zip) ![GitHub followers](https://img.shields.io/github/followers/OlimilO1402?style=social) Project started around mid 2006. @@ -13,7 +13,7 @@ The Module MPtr is used in many repos. It contains * the TSafeArrayPtr-structure * all GetMem/PutMem declarations * every function for working with SafeArray-pointers -* Collection-functions +* Collection-functions including collection sorting * the TByteSwapper-structure all byteswapping-and SwapByteOrder-functions * weak obj-pointer functions