时间戳

首页 > 解决方案 > 如何将 Excel VBA 类集合合并到接口/工厂方法中？

excel - 如何将 Excel VBA 类集合合并到接口/工厂方法中？

问题描述

我已经使用类模块快一年了，现在我对它们感到很舒服。现在我正在尝试将工厂方法合并到从工作簿表中提取数据中。我在此处、此处和此处找到了有关该主题的一些很棒的指南，但是我不确定在哪里合并该课程的集合。

到目前为止，我已经使用这种格式的自包含集合设置了我的类模块：

类模块 OrigClass

Option Explicit

'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
    icrName = 2
    icrCost = 4
End Enum

'UDT mirrors class properties
Private Type TTestClass
    Name                                As String
    Cost                                As Long
End Type

Const WS_NAME                           As String = "Sheet1"
Const NR_TBL                            As String = "Table1"

Private msTestClass                     As Collection
Private TestClass                       As TTestClass


Private Sub Class_Initialize()
    Set msTestClass = New Collection
End Sub

Public Sub Add(Item As OrigClass)
    msTestClass.Add _
        Item:=Item, _
        Key:=Item.Name
End Sub

Public Function Extract() As OrigClass
    Dim tblInputs                       As ListObject
    Dim i                               As Integer
    Dim Item                            As OrigClass

    Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)

    For i = 1 To tblInputs.DataBodyRange.Rows.Count
        Set Item = New OrigClass
        
        With Item
            .Name = tblInputs.DataBodyRange(i, icrName).Value
            .Cost = tblInputs.DataBodyRange(i, icrCost).Value
        End With

        msTestClass.Add Item
    Next i
End Function

Public Function Item(i As Variant) As OrigClass
    Set Item = msTestClass.Item(i)
End Function

Public Function Count() As Integer
    Count = msTestClass.Count
End Function


Friend Property Let Name(Val As String)
    TestClass.Name = Val
End Property

Public Property Get Name() As String
    Name = TestClass.Name
End Property

Friend Property Let Cost(Val As Long)
    TestClass.Cost = Val
End Property

Public Property Get Cost() As Long
    Cost = TestClass.Cost
End Property

当我构建传递范围/表、遍历行并为每个属性分配列值的函数时，这种结构效果很好。地址几乎总是不变的，只有值和记录数会发生变化。

我刚刚开始为一个类构建一个接口，同时还试图保留集合组件，但我遇到了运行时错误......我可能会创建一个单独的集合类，但我认为我的问题更多是关于范围管理不善而不是封装：

类模块 CTestClass

Option Explicit

'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
    icrName = 2
    icrCost = 4
End Enum

''UDT mirrors class properties
Private Type TTestClass
    Name                                As String
    Cost                                As Long
End Type

Const WS_NAME                           As String = "Sheet1"
Const NR_TBL                            As String = "Table1"

Private msTestClass                     As Collection
Private TestClass                       As TTestClass

Implements ITestClass
Implements FTestClass


Private Sub Class_Initialize()
    Set msTestClass = New Collection
End Sub

Public Sub Add(Item As CTestClass)
    msTestClass.Add _
        Item:=Item, _
        Key:=Item.Name
End Sub

Public Function Create() As ITestClass
    With New CTestClass
        .Extract
' 2) now in Locals window, Me.msTestClass is <No Variables>
        Set Create = .Self
' 4) Me.msTestClass is again <No Variables>, and
'       Create (as Type ITextClass) is Nothing
'       Create (as Type ITextClass/ITextClass) lists property values as
'           <Object doesn't support this property or method>, aka runtime error 438
    End With
End Function

Private Function FTestClass_Create() As ITestClass
    Set FTestClass_Create = Create
End Function

Public Function Extract() As ITestClass
    Dim tblInputs                       As ListObject
    Dim i                               As Integer
    Dim Item                            As CTestClass

    Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)

    For i = 1 To tblInputs.DataBodyRange.Rows.Count
        Set Item = New CTestClass
        
        With Item
            .Name = tblInputs.DataBodyRange(i, icrName).Value
            .Cost = tblInputs.DataBodyRange(i, icrCost).Value
        End With

        msTestClass.Add Item
    Next i
' 1) in Locals window, Me.msTestClass is populated with all table records
End Function

Public Function ITestClass_Item(i As Variant) As ITestClass
    Set ITestClass_Item = msTestClass.Item(i)
End Function

Public Function ITestClass_Count() As Integer
    ITestClass_Count = msTestClass.Count
End Function


Friend Property Let Name(Val As String)
    TestClass.Name = Val
End Property

Public Property Get Name() As String
    Name = TestClass.Name
End Property

Friend Property Let Cost(Val As Long)
    TestClass.Cost = Val
End Property

Public Property Get Cost() As Long
    Cost = TestClass.Cost
End Property


Public Property Get Self() As ITestClass
    Set Self = Me
' 3) Me.msTestClass is again populated with all table records (scope shift?), but
'       Self is set to Nothing
End Property

Private Property Get ITestClass_Name() As String
    ITestClass_Name = Name
End Property

Private Property Get ITestClass_Cost() As Long
    ITestClass_Cost = Cost
End Property

接口模块 ITestClass

'Attribute VB_PredeclaredId = False     <-- revised in text editor
Option Explicit


Public Function Item(i As Variant) As ITestClass
End Function

Public Function Count() As Integer
End Function


Public Property Get Name() As String
End Property

Public Property Get Cost() As Long
End Property

工厂模块 FTestClass

'Attribute VB_PredeclaredId = False     <-- revised in text editor
Option Explicit


Public Function Create() As ITestClass
End Function

标准模块

Sub TestFactory()
    Dim i                               As ITestClass
    Dim oTest                           As FTestClass
    
    Set oTest = CTestClass.Create
' 5) oTest is <No Variables>, no properties are present
'       as if the variable was never set
    
    For Each i In oTest     ' <-- Runtime error 438, Object doesn't support this property or method
        Debug.Print
        Debug.Print i.Name
        Debug.Print i.Cost
    Next i
End Sub

我在这里做错了什么？

编辑：

@freeflow 指出我没有说明引入界面的意图。

我的办公室使用多个工作簿“模型”将定价数据编译为单个输出表，然后将其交付给下游客户以导入数据库。

我的目标是使用这些不同的模型标准化计算。附带目标是了解如何正确实现工厂方法。

每个模型都有一个或多个输入表，每个表包含 10-30 个字段/列的唯一集合。输出数据计算不同，以及对各种输入字段的依赖关系。但是，输出数据的格式全部相同，并且始终包含相同的十几个字段。

我展示的示例旨在成为ITestClass将数据写入输出表的单一接口。实现它的类CTestClass可以被认为只是包含输入数据的几个表（在几个模型中）之一。我计划对更多类对象建模，每个输入表一个。

标签： excelvbacollectionsinterfacefactory

解决方案

基于：

Sub TestFactory()
    Dim i                               As ITestClass
    Dim oTest                           As FTestClass
    
    Set oTest = CTestClass.Create
' 5) oTest is <No Variables>, no properties are present
'       as if the variable was never set
    
    For Each i In oTest     ' <-- Runtime error 438, Object doesn't support this property or method
        Debug.Print
        Debug.Print i.Name
        Debug.Print i.Cost
    Next i
End Sub

您似乎有兴趣使您的类像集合一样可迭代。我会指出你这个 SO question。缺点是……很难。

关于错误：语句的结果Set oTest = CTestClass.Create是获取了一个暴露单个方法的FTestClass接口：Public Function Create() As ITestClass. 其中，没有提供任何迭代并导致错误。

其他观察：

在提供的代码中，不需要声明工厂接口。

（边栏：接口类通常以字母“I”开头。在这种情况下，更好的接口名称FTestClass是“ITestClassFactory”）

由于 CTestClass 的 VB_PredeclaredId 属性设置为“True”，因此在其中Public声明的任何方法（或字段）CTestClass都会被公开......并被视为其默认接口。 CTestClass.Create() 是您感兴趣的工厂方法。

创建工厂方法（在 VBA 中）的一个目的是支持类实例的参数化创建。由于该Create函数当前没有参数，因此在创建过程中除了Set tClass = new CTestClass. 但是，有一些参数可以指示Create.

Public Function Create(ByVal tblInputs As ListObject, OPtional ByVal nameColumn As Long = 2, Optional ByVal costColumn As Long = 4) As ITestClass

换句话说，CTestClass依赖于 aListObject才能成为 a 的有效实例CTestClass。工厂方法的签名通常包含类的依赖项。使用上述工厂方法，不再需要具有Extract功能 -Public或其他。还要注意（在下面的代码中）ThisWorkbook引用不再是对象的一部分。现在，tblInputs ListObject可以来自任何地方。并且可以轻松修改重要的列号。此参数列表允许您使用带有假数据的工作表来测试此类。

重组：

CTestClass包含一个Collection实例CTestClass。TestClassContainer声明一个公开上述Create函数的类似乎更清楚。然后容器类可以公开一个NameCostPairs简单地公开msTestClass Collection. 创建容器类将 TestClass 本质上简化为一个数据对象（所有属性，无方法），从而实现有用的关注点分离。让调用对象处理集合的迭代。

测试类容器

Option Explicit

Private Type TTestClassContainer
    msTestClass As Collection
End Type

Private this                       As TTestClassContainer

'TestContainer Factory method
Public Function Create(ByVal tblInputs As ListObject, Optional ByVal nameCol As Long = 2, Optional ByVal costCol As Long = 4) As TestClassContainer
    Dim i As Integer
    Dim nameCostPair As CTestClass
    
    Dim newInstance As TestClassContainer

    With New TestClassContainer
        Set newInstance = .Self
        For i = 1 To tblInputs.DataBodyRange.Rows.Count
            Set nameCostPair = New CTestClass
            nameCostPair.Name = tblInputs.DataBodyRange(i, nameCol).Value
            nameCostPair.Cost = tblInputs.DataBodyRange(i, costCol).Value
            
            newInstance.AddTestClass nameCostPair
        Next i
    End With
    
    Set Create = newInstance
    
End Function

Public Sub AddTestClass(ByVal tstClass As CTestClass)
    this.msTestClass.Add tstClass
End Sub

Public Property Get Self() As CTestClass
    Set Self = Me
End Property

Public Property Get NameCostPairs() As Collection
    Set NameCostPairs = this.msTestClass
End Property

CTestClass（不再需要 VB_PredeclaredId 设置为 'True'）

Option Explicit

Implements ITestClass

''UDT mirrors class properties
Private Type TTestClass
    Name As String
    Cost As Long
End Type

Private this As TTestClass

Public Property Let Name(Val As String)
    this.Name = Val
End Property

Public Property Get Name() As String
    Name = this.Name
End Property

Public Property Let Cost(Val As Long)
    this.Cost = Val
End Property

Public Property Get Cost() As Long
    Cost = this.Cost
End Property

Private Property Get ITestClass_Name() As String
    ITestClass_Name = Name
End Property

Private Property Get ITestClass_Cost() As Long
    ITestClass_Cost = Cost
End Property

最后：

Option Explicit

Sub TestFactory()
    Const WS_NAME As String = "Sheet1"
    Const NR_TBL As String = "Table1"
    
    Dim tblInputs As ListObject

    Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)

    Dim container As TestClassContainer
    Set container = TestClassContainer.Create(tblInputs)
    
    Dim nameCostPair As ITestClass
    Dim containerItem As Variant
    For Each containerItem In container.NameCostPairs
        Set nameCostPair = containerItem
        Debug.Print
        Debug.Print nameCostPair.Name
        Debug.Print nameCostPair.Cost
    Next
End Sub

推荐阅读