【类模块】的超级属性，无限扩展，值和对象 通用！ 类的继承封装演示

山中老人

很多老鸟都会写【类模块】，自己来创建【类】。
但是，很多时候很尴尬，经常性的要去修改旧有的类，增加或改变【类】的属性。当程序越写越大的时候，改变一个常用的【类】，将是一个非常巨大的工程。

考虑很久，我给我写的【类模块】加上一个万用的属性，随时可以扩展、修改。
它以一个词典为基础，扩展出一个Develop属性，具备任意扩展性！ 属性值支持任意数据类型或对象。

--------------------代码---------------------------
Private DevelopDic_ As Scripting.Dictionary '扩展属性词典

Public Property Get Develop_Exists(Key As String) As Boolean '验证扩展属性是否存在
    If DevelopDic_ Is Nothing Then Set DevelopDic_ = New Scripting.Dictionary
    Develop_Exists = DevelopDic_.Exists(Key)
End Property

Public Property Get Develop(Key As String) '获取扩展属性
    If Me.Develop_Exists(Key) = False Then GoTo Err1
    On Error GoTo Next1
    Set Develop = DevelopDic_.Item(Key)
    Exit Property
Next1:
    On Error GoTo Next2
    Develop = DevelopDic_.Item(Key)
    Exit Property
Next2:
    On Error GoTo Err1
    Develop = Null
Err1:
End Property

Public Property Let Develop(Key As String, Val As Variant) '属性赋值
    If DevelopDic_ Is Nothing Then Set DevelopDic_ = New Scripting.Dictionary
    DevelopDic_.Item(Key) = Val
End Property

Public Property Set Develop(Key As String, Obj As Object) '设置对象引用
    If DevelopDic_ Is Nothing Then Set DevelopDic_ = New Scripting.Dictionary
    Set DevelopDic_.Item(Key) = Obj
End Property

--------------------代码--------------------------- END

在2楼有将Develop属性封装好的类模块文件（包括事件触发），以及 给其他类模块，添加Develop属性的代码
，9楼有Develop类的 主要代码说明。


-------------------------------------------------------------------------------

哦！顺便说两句，其实事件处理，还可以通过添加回调对象，而不是标准的WithEvents，来实现事件触发、处理！

如果要给Develop的子属性添加事件处理机制，由于无法预知子属性的类型，只能通过这个办法来实现！

山中老人

给【类模块】添加一个超级属性，能任意扩展、改变！
一次添加，一次爽！
这次添加，无穷爽！

下面是将Develop属性封装成一个类模块（DevelopDictionary[url=]DevelopDictionary.rar[/url]），添加事件触发。
-------------添加 Develop属性 代码-----------
Private WithEvents DDic As DevelopDictionary '扩展属性词典
'----扩展属性----
Public Property Get Develop() As DevelopDictionary
    If DDic Is Nothing Then Set DDic = New DevelopDictionary
    Set Develop = DDic
End Property

'----Develop事件----
Private Sub DDic_GetParent(Parent As Object)'Develop内部引用
    Set Parent = Me
End Sub
Private Sub DDic_EventS(Me_ As DevelopDictionary, EventInfo As DevelopDictionary, ReturnVal As Variant)'Develop事件 处理
    '向上传递事件 代码 ........
End Sub

wggx4

看不懂样。顶一个

yang央

好像就是属性...没看懂有啥用?给个使用场景啊,或例子也行啊

风筝那根线

我写的类都很小的

山中老人

yang央 发表于 2020-7-6 10:47
好像就是属性...没看懂有啥用?给个使用场景啊,或例子也行啊

可以无限向里面添加属性或者对象！
例如：

'赋值
Obj.Develop("姓名")="张三"
Obj.Develop("性别")="男"
Obj.Develop("出生日期")=Cdate("1990-01-05")'日期赋值
Obj.Develop("年龄")=30
Obj.Develop("考试记录")=Sz '数组赋值

'对象
Set  Obj.Develop("Worksheet")=New Excel.Worksheet
Set  Obj.Develop("RS")=New ADODB.Recordset
Set  Obj.Develop("Dic")=New Scripting.Dictionary

justdoit2003

好东西，好好学习。

山中老人

justdoit2003 发表于 2020-7-7 10:54
好东西，好好学习。

2楼，我直接将它封装成类模块了，还添加了事件触发机制。

山中老人

为实现Develop属性功能，继承、封装Scripting.Dictionary类的类模块代码

《DevelopDictionary.cls》
Option Compare Database
Implements Scripting.Dictionary '继承类
Private Dic_ As Scripting.Dictionary '继承对象

'--添加变量--
Public EventS_Off As Boolean '关闭EventS事件触发
Public Event GetParent(ByRef Parent As Object) '通过事件，获取父对象
Public Event EventS(ByRef Source As DevelopDictionary, ByRef EventInfo As DevelopDictionary, ByRef ReturnVal As Variant) '事件调用入口

Public Name As String '对象命名
Public NotItem_IsRet As Boolean  '未找到Item时，是否返回值
Public NotItem_RetValue As Variant '未找到Item时，将返回的值
'--添加变量--End

'--类 基本事件--
Private Sub Class_Initialize() '类初始化
    Set Dic_ = New Scripting.Dictionary
End Sub

Private Sub Class_Terminate() '类结束
    If Not Dic_ Is Nothing Then
        Dic_.RemoveAll
        Set Dic_ = Nothing
    End If
End Sub

Public Property Get ClassTypeName()  '类型名称
    Class_TypeName = "DevelopDictionary"
End Property

'----添加属性、方法----
Public Property Get Parent() As Object '父对象(通过事件，获取当前实例的创建者)
    Dim Obj As Object
    RaiseEvent GetParent(Obj)
    Set Parent = Obj
End Property

Private Function toEventS(ByRef EventName As String, Optional ByRef Key As Variant = Null, Optional ByRef EventInfo As DevelopDictionary = Nothing) As Variant '事件调用方法
    'EventName=事件名
    'Key=主键
    'EventInfo=事件信息词典
    If EventS_Off Then '关闭EventS事件触发
        toEventS = ""
        Exit Function
    End If
    On Error GoTo Err1
    If EventInfo Is Nothing Then
        Set EventInfo = New DevelopDictionary'新建事件描述词典
        EventInfo.EventS_Off = True '关闭词典的EventS事件触发
    End If
    If VBA.IsNull(Key) = False Then EventInfo.Item("ItemName") = Key '添加触发事件的项目名
    EventInfo.Item("EventName") = EventName'添加事件名
    Dim ReturnVal As Variant: ReturnVal = ""
    RaiseEvent EventS(Me, EventInfo, ReturnVal)
    toEventS = ReturnVal
    Exit Function
Err1:
    ERR.Raise -1, Me.Name & "[DevelopDictionary].EventS", "项目[" & Nz(Key, "Null") & "].[" & EventName & "]事件 调用错误！"
End Function

Public Property Get EventString() As String '事件名EventName串（公开全部事件名EventName）
    EventString = "Add,GetItem,NotItem,RemoveBefore,RemoveAfter"
End Property
'----添加属性、方法----End


'----复制属性、方法----
Public Sub Add(Key As Variant, Item As Variant)
    On Error GoTo Err1
    Call Dic_.Add(Key, Item)
    Call toEventS("Add", Key) '触发【新建】事件
    Exit Sub
Err1:
End Sub

Public Property Let CompareMode(ByVal RHS As Scripting.CompareMethod)
    Dic_.CompareMode = RHS
End Property

Public Property Get CompareMode() As Scripting.CompareMethod
    CompareMode = Dic_.CompareMode
End Property

Public Property Get Count() As Long
    Count = Dic_.Count
End Property

Public Function Exists(Key As Variant) As Boolean
    Exists = Dic_.Exists(Key)
End Function

Public Property Get HashVal(Key As Variant) As Variant
    HashVal = Dic_.HashVal(Key)
End Property

Public Property Get Item(Key As Variant) As Variant
    If Dic_.Exists(Key) = False Then
        If Me.NotItem_IsRet = False Then GoTo Not2 '未找到Item时，是否返回值
        On Error GoTo Not1
        Set Item = Me.NotItem_RetValue '未找到Item时，返回的对象
        GoTo Not2
Not1:
        On Error GoTo Not2
        Item = Me.NotItem_RetValue '未找到Item时，返回的值
Not2:
        Call toEventS("NotItem", Key) '触发【未找到】事件
        Exit Property
    End If

    On Error GoTo Next1
    Set Item = Dic_.Item(Key)
    GoTo Exit1
Next1:
    On Error GoTo Exit1
    Item = Dic_.Item(Key)
Exit1:
    Call toEventS("GetItem", Key)'触发【获取】事件
End Property

Public Property Set Item(Key As Variant, RHS As Variant)
    If Dic_.Exists(Key) Then
        Set Dic_.Item(Key) = RHS
    Else
        Me.Add Key, RHS
    End If
End Property

Public Property Let Item(Key As Variant, RHS As Variant)
    If Dic_.Exists(Key) Then
        Dic_.Item(Key) = RHS
    Else
        Me.Add Key, RHS
    End If
End Property

Public Function Items() As Variant
    Items = Dic_.Items
End Function

Public Property Let Key(Key As Variant, RHS As Variant)
    Dic_.Item(Key) = RHS
End Property

Public Function Keys() As Variant
    Keys = Dic_.Keys
End Function

Public Function Remove(Key As Variant) As Boolean
    If Me.EventS_Off Then '关闭EventS事件触发 执行办法
        Call Dic_.Remove(Key)
        Remove = True
        Exit Function
    End If
    If Dic_.Exists(Key) = False Then '项目不存在
        Call toEventS("NotItem", Key)  '触发【未找到】事件
        Exit Function
    End If

    '【移除项目前】事件
    On Error GoTo ReturnValErr1
    Dim ReturnVal As Variant
    ReturnVal = toEventS("RemoveBefore", Key) '触发【移除项目-前】事件    '(返回值 ReturnVal=0 或 False,取消移除操作)
    '检查返回值
    If ReturnVal = "" Then GoTo Next1
    If VBA.IsNumeric(ReutrnVal) Then
        If CLng(ReutrnVal) = 0 Then Exit Function '取消移除
    End If
    If ReturnVal = "False" Then Exit Function '取消移除
    If CBool(ReutrnVal) = False Then Exit Function '取消移除
    GoTo Next1
ReturnValErr1: '返回值错误
    ERR.Raise -1, Me.Name & "[DevelopDictionary].EventS", "项目[" & Nz(Key, "Null") & "].[" & RemoveBefore & "]事件 返回值 错误！（期待Boolean或Integer值）"

Next1:
    On Error GoTo Err1
    Call Dic_.Remove(Key)'执行移除
    Remove = True
    Call toEventS("RemoveAfter", Key)'触发【移除项目-后】事件
Err1:
End Function

Public Function RemoveAll(Optional Off_EventS As Boolean = False) As Boolean
    If Off_EventS Then '静默执行（无事件触发）
        Dic_.RemoveAll
        Exit Function
    End If
    Dim i As Long
    For i = Dic_.Count - 1 To 0 Step -1 '遍历 移除
        If Me.Remove(Dic_.Keys(i)) = False Then Exit Function
    Next i
    RemoveAll = True
End Function
'----复制属性、方法----End


................................
'后面是些继承Scripting.Dictionary的代码就不贴了！

zhangmi

标记一下，有空还是要学习一下类模块