added test-form for weak ptr, added assignswap, improved ptrtoobject

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"

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

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

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

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

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

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  ' ^ ############################## ^ '
 
 

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"