diff --git a/Forms/FMain.frm b/Forms/FMain.frm index d080a54..7701ba3 100644 --- a/Forms/FMain.frm +++ b/Forms/FMain.frm @@ -1,27 +1,35 @@ VERSION 5.00 Begin VB.Form FMain Caption = "VBPointers" - ClientHeight = 3015 + ClientHeight = 3255 ClientLeft = 120 ClientTop = 465 ClientWidth = 4560 + BeginProperty Font + Name = "Segoe UI" + Size = 8.25 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty Icon = "FMain.frx":0000 LinkTopic = "FMain" - ScaleHeight = 201 + ScaleHeight = 217 ScaleMode = 3 'Pixel ScaleWidth = 304 StartUpPosition = 3 'Windows-Standard + Begin VB.CommandButton BtnTestObjPtr + Caption = "Test ObjPtr" + Height = 375 + Left = 240 + TabIndex = 4 + Top = 2640 + Width = 1935 + End Begin VB.CommandButton BtnTSafeArrayPtr Caption = "Test SafeArrayPtr" - BeginProperty Font - Name = "Tahoma" - Size = 8.25 - Charset = 0 - Weight = 400 - Underline = 0 'False - Italic = 0 'False - Strikethrough = 0 'False - EndProperty Height = 375 Left = 240 TabIndex = 3 @@ -30,15 +38,6 @@ Begin VB.Form FMain End Begin VB.CommandButton BtnTestSAPtr Caption = "Test SAPtr" - BeginProperty Font - Name = "Tahoma" - Size = 8.25 - Charset = 0 - Weight = 400 - Underline = 0 'False - Italic = 0 'False - Strikethrough = 0 'False - EndProperty Height = 375 Left = 240 TabIndex = 2 @@ -47,15 +46,6 @@ Begin VB.Form FMain End Begin VB.CommandButton BtnTestArrayPointer Caption = "Test Array-Pointer" - BeginProperty Font - Name = "Tahoma" - Size = 8.25 - Charset = 0 - Weight = 400 - Underline = 0 'False - Italic = 0 'False - Strikethrough = 0 'False - EndProperty Height = 375 Left = 240 TabIndex = 1 @@ -64,15 +54,6 @@ Begin VB.Form FMain End Begin VB.CommandButton BtnTestCharArray Caption = "Test Char-Pointer" - BeginProperty Font - Name = "Tahoma" - Size = 8.25 - Charset = 0 - Weight = 400 - Underline = 0 'False - Italic = 0 'False - Strikethrough = 0 'False - EndProperty Height = 375 Left = 240 TabIndex = 0 @@ -87,6 +68,10 @@ Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit +Private Sub BtnTestObjPtr_Click() + Form4.Show +End Sub + Private Sub BtnTestSAPtr_Click() ReDim sa(0 To 10) As String sa(0) = "one" diff --git a/Forms/Form1.frm b/Forms/Form1.frm index 705c4de..339baa0 100644 --- a/Forms/Form1.frm +++ b/Forms/Form1.frm @@ -6,6 +6,15 @@ Begin VB.Form Form1 ClientLeft = 45 ClientTop = 435 ClientWidth = 3990 + BeginProperty Font + Name = "Segoe UI" + Size = 8.25 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty Icon = "Form1.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False @@ -47,6 +56,15 @@ Begin VB.Form Form1 Width = 3735 End Begin VB.Frame FrmBuildString + BeginProperty Font + Name = "MS Sans Serif" + Size = 8.25 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty Height = 615 Left = 120 TabIndex = 0 diff --git a/Forms/Form2.frm b/Forms/Form2.frm index dc2eb1c..d720c37 100644 --- a/Forms/Form2.frm +++ b/Forms/Form2.frm @@ -5,6 +5,15 @@ Begin VB.Form Form2 ClientLeft = 120 ClientTop = 465 ClientWidth = 8070 + BeginProperty Font + Name = "Segoe UI" + Size = 8.25 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty LinkTopic = "Form2" ScaleHeight = 4215 ScaleWidth = 8070 diff --git a/Forms/Form3.frm b/Forms/Form3.frm index 073767f..f99c2a3 100644 --- a/Forms/Form3.frm +++ b/Forms/Form3.frm @@ -5,6 +5,15 @@ Begin VB.Form Form3 ClientLeft = 60 ClientTop = 450 ClientWidth = 4680 + BeginProperty Font + Name = "Segoe UI" + Size = 8.25 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty Icon = "Form3.frx":0000 LinkTopic = "Form3" ScaleHeight = 3090 diff --git a/Modules/Form4.frm b/Modules/Form4.frm new file mode 100644 index 0000000..fe71211 --- /dev/null +++ b/Modules/Form4.frm @@ -0,0 +1,91 @@ +VERSION 5.00 +Begin VB.Form Form4 + Caption = "Form4" + ClientHeight = 3015 + ClientLeft = 120 + ClientTop = 465 + ClientWidth = 4560 + BeginProperty Font + Name = "Segoe UI" + Size = 8.25 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + LinkTopic = "Form4" + ScaleHeight = 3015 + ScaleWidth = 4560 + StartUpPosition = 3 'Windows-Standard + Begin VB.CommandButton BtnWeakObjPtrTestAssignSwap + Caption = "Weak ObjPtr Test AssignSwap" + Height = 375 + Left = 120 + TabIndex = 1 + Top = 600 + Width = 3135 + End + Begin VB.CommandButton BtnWeakObjPtrTest1 + Caption = "Weak ObjPtr Test1" + Height = 375 + Left = 120 + TabIndex = 0 + Top = 120 + Width = 3135 + End +End +Attribute VB_Name = "Form4" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit +Private m_Obj1 As Class1 +' + +Private Sub BtnWeakObjPtrTest1_Click() + + Set m_Obj1 = MNew.Class1(123.456) + MsgBox "Creating a new object m_Obj1 of Class1 with value: " & m_Obj1.ToStr + + Dim pObj1 As LongPtr: pObj1 = ObjPtr(m_Obj1) + + MsgBox "The ObjPtr of m_Obj1 is pObj1, it's value is: " & pObj1 + + MPtr.ZeroObject m_Obj1 + MsgBox "ZeroObject m_Obj1, now m_Obj1 is: ..." + + If m_Obj1 Is Nothing Then + MsgBox "m_Obj1 is nothing" + Else + MsgBox "m_Obj1 is*not* nothing, the value of m_Obj1 is: " & m_Obj1.ToStr + End If + + Set m_Obj1 = MPtr.PtrToObject(pObj1) + MsgBox "Now we write pObj1, remember pObj1 is: " & pObj1 & vbCrLf & _ + "back to the object m_Obj1, now m_Obj1 is: ..." + + If m_Obj1 Is Nothing Then + MsgBox "m_Obj1 is nothing" + Else + MsgBox "m_Obj1 is*not* nothing, the value of m_Obj1 is: " & m_Obj1.ToStr + End If + +End Sub + +Private Sub BtnWeakObjPtrTestAssignSwap_Click() + + Dim Obj1 As Class1: Set Obj1 = MNew.Class1(123.456) + Dim Obj2 As Class1: Set Obj2 = MNew.Class1(456.789) + + MsgBox "We created 2 objects Obj1 and Obj2: " & vbCrLf & _ + "Obj1.Value = " & Obj1.Value & vbCrLf & _ + "Obj2.Value = " & Obj2.Value + + MPtr.AssignSwap Obj1, Obj2 + + MsgBox "After AssignSwap Obj1, Obj2: " & vbCrLf & _ + "Obj1.Value = " & Obj1.Value & vbCrLf & _ + "Obj2.Value = " & Obj2.Value +End Sub diff --git a/Modules/MNew.bas b/Modules/MNew.bas new file mode 100644 index 0000000..5d9ac83 --- /dev/null +++ b/Modules/MNew.bas @@ -0,0 +1,6 @@ +Attribute VB_Name = "MNew" +Option Explicit + +Public Function Class1(ByVal Value As Double) As Class1 + Set Class1 = New Class1: Class1.Value = Value +End Function diff --git a/Modules/MPtr.bas b/Modules/MPtr.bas index 1e42fa2..1f23ade 100644 --- a/Modules/MPtr.bas +++ b/Modules/MPtr.bas @@ -202,8 +202,8 @@ End Sub ' ^ ############################## ^ ' Array-Ptr Functions ' ^ ############################## ^ ' 'retrieve the pointer to a function by using FncPtr(Addressof myfunction) -Public Function FncPtr(ByVal pfn As LongPtr) As LongPtr - FncPtr = pfn +Public Function FncPtr(ByVal PFN As LongPtr) As LongPtr + FncPtr = PFN End Function ' v ############################## v ' Collection Functions ' v ############################## v ' @@ -231,11 +231,11 @@ Public Sub Col_SwapItems(col As Collection, ByVal i1 As Long, i2 As Long) If i1 <= 0 Or col.Count <= i1 Then Exit Sub If i2 <= 0 Or col.Count < i2 Then Exit Sub If i1 = i2 Then Exit Sub - Dim obj1, obj2 - If IsObject(col.Item(i1)) Then Set obj1 = col.Item(i1) Else obj1 = col.Item(i1) - If IsObject(col.Item(i2)) Then Set obj2 = col.Item(i2) Else obj2 = col.Item(i2) - col.Remove i1: col.Add obj2, , i1: col.Remove i2 - If i2 < c Then col.Add obj1, , i2 Else col.Add obj1 + Dim Obj1, Obj2 + If IsObject(col.Item(i1)) Then Set Obj1 = col.Item(i1) Else Obj1 = col.Item(i1) + If IsObject(col.Item(i2)) Then Set Obj2 = col.Item(i2) Else Obj2 = col.Item(i2) + col.Remove i1: col.Add Obj2, , i1: col.Remove i2 + If i2 < c Then col.Add Obj1, , i2 Else col.Add Obj1 End Sub Public Sub Col_MoveUp(col As Collection, ByVal i As Long) @@ -349,13 +349,21 @@ End Function ' v ############################## v ' Object-WeakPtr Funcs ' v ############################## v ' Public Function PtrToObject(ByVal p As LongPtr) As Object - RtlMoveMemory ByVal VarPtr(PtrToObject), p, MPtr.SizeOf_LongPtr + Dim obj As Object: RtlMoveMemory obj, p, MPtr.SizeOf_LongPtr + Set PtrToObject = obj: ZeroObject obj End Function Public Sub ZeroObject(obj As Object) - RtlZeroMemory ByVal VarPtr(obj), MPtr.SizeOf_LongPtr + 'RtlZeroMemory ByVal VarPtr(obj), MPtr.SizeOf_LongPtr + RtlZeroMemory obj, MPtr.SizeOf_LongPtr End Sub +Public Sub AssignSwap(Obj1 As Object, Obj2 As Object) + Dim pObj1 As LongPtr: pObj1 = ObjPtr(Obj1) + Dim pObj2 As LongPtr: pObj2 = ObjPtr(Obj2) + RtlMoveMemory Obj1, pObj2, MPtr.SizeOf_LongPtr + RtlMoveMemory Obj2, pObj1, MPtr.SizeOf_LongPtr +End Sub ' ^ ############################## ^ ' Object-WeakPtr Funcs ' ^ ############################## ^ ' diff --git a/PVBPointers.vbp b/PVBPointers.vbp index 712d960..8765da8 100644 --- a/PVBPointers.vbp +++ b/PVBPointers.vbp @@ -9,6 +9,8 @@ Class=Class1; Classes\Class1.cls Class=StopWatch; ..\Sys_StopWatch\Classes\StopWatch.cls Form=Forms\Form2.frm ResFile32="Resources\MyRes.res" +Form=Modules\Form4.frm +Module=MNew; Modules\MNew.bas IconForm="Form1" Startup="FMain" HelpFile="" @@ -18,9 +20,9 @@ Command32="" Name="PVBPointers" HelpContextID="0" CompatibleMode="0" -MajorVer=2022 -MinorVer=12 -RevisionVer=25 +MajorVer=2023 +MinorVer=4 +RevisionVer=9 AutoIncrementVer=0 ServerSupportFiles=0 VersionCompanyName="MBO-Ing.com"