将 class 作为 Variant 参数传递时出现运行时错误

Question

当我这样做时：

Dim data_set As DataSet
Set data_set = New DataSet
'some meaningless operations here    
list.Add CVar(data_set)

在 list.Add 行，我收到 run-time 错误 13，认为类型不匹配。

这是添加子的header：

Public Sub Add(ByRef vItem As Variant, Optional index As Long)

我在这里错过了什么？

编辑：刚刚启用了所有错误，它在这段代码上失败了，现在出现 Run-Time 错误 9:

Private Function GetListCount() As Long
    ClearError
    On Error GoTo Err
    GetListCount = UBound(mList) - LBound(mList) + 1
    Exit Function
Err:
    GetListCount = 0
End Function

下面是 mList 定义：

Private mList() As Variant

EDIT2：这是构造函数：

'==============================
'Constructor
'==============================
Public Sub Initialize()
    Disposed = False
    ReDim mList(0)
End Sub

Public Function CreateInstance() As ListClass
     Dim oNew As New ListClass
     oNew.Initialize
     Set CreateInstance = oNew
End Function

EDIT3：根据要求，这里是整个模块......首先是 ListClass

Private mList() As Variant
Private mError As Error
Private mDisposed As Boolean

'==============================
'Constructor
'==============================
Public Sub Initialize()
    Disposed = False
    ReDim mList(0)
End Sub

Public Function CreateInstance() As ListClass
    Dim oNew As New ListClass
    oNew.Initialize
    Set CreateInstance = oNew
End Function

'==============================
'Properties
'==============================
Public Property Get Items(ByRef index As Long) As Variant
    Items = GetItemAtIndex(index)
End Property
    Public Property Get Count() As Long
    Count = GetListCount()
End Property

Public Property Get GotError() As Boolean
    If ListError Is Nothing Then GotError = False Else GotError = True
End Property

Public Property Get ListItems() As Variant()
    ClearError
    On Error GoTo Err
    ListItems = mList
    Exit Property
Err:
        ListError = Err
End Property

Public Property Get ListError() As Error
    ListError = mError
End Property

Private Property Let ListError(ByRef vError As Error)
    Set mError = vError
End Property

Public Property Get Disposed() As Boolean
    Disposed = mDisposed
End Property

Private Property Let Disposed(ByRef vValue As Boolean)
    mDisposed = vValue
End Property

Public Property Get ToArray()
    ToArray = mList
End Property

'==============================
'Public Methods
'==============================

Public Sub Remove(ByRef vItem As Variant)
    DeleteElement (vItem)
End Sub

Public Sub RemoveAtIndex(ByRef index As Long)
    DeleteElementAt (index)
End Sub

Public Sub Sort()
    BubbleSort (mList)
End Sub

Public Sub Clear()
    Erase mList
End Sub

Public Function Find(ByRef vItem As Variant) As Long
    Find = FindItem(vItem)
End Function

Public Sub Dispose()
    ResetError
    Clear
    Disposed = True
End Sub

Public Sub ResetError()
    ClearError
End Sub

Public Function LastIndexOf(ByRef vItem As Variant)
    LastIndexOf = GetLastIndexOf(vItem)
End Function

Public Function IndexOf(ByRef vItem As Variant)
    IndexOf = FindItem(vItem)
End Function

Public Sub Reverse()
    ReverseList
End Sub

Public Function Exists(vItem As Variant)
    Exists = ItemExists(vItem)
End Function

Public Sub Add(ByRef vItem As Variant, Optional index As Long)
    If index > 0 Then
        AddItemAt index, vItem
    Else
        AddItem vItem
    End If
End Sub

Public Function Contains(ByRef vItem As Variant)
    Contains = Exists(vItem)
End Function

Public Function Copy() As ListClass
    Set Copy = GetCopy
End Function

Public Sub RemoveAll()
    Clear
End Sub

'==============================
'Private Methods
'==============================

Private Sub ClearError()
    Set mError = Nothing
End Sub

Private Function GetListCount() As Long
    ClearError
    On Error GoTo Err
    GetListCount = UBound(mList) - LBound(mList) + 1 'and error happens here
    Exit Function
Err:
        GetListCount = 0
End Function

Private Function GetItemAtIndex(ByRef index As Long) As Variant
    ClearError
    On Error GoTo Err
    GetItemAtIndex = mList(index)
    Exit Function
Err:
        ListError = Err
    GetItemAtIndex = Nothing
End Function

Private Sub AddItemAt(index As Long, vItem As Variant)
    ClearError
    On Error GoTo Err

    Dim ar() As Variant
    Dim i As Integer

    i = Count
    ReDim ar(i)

    For a = 0 To index - 1
        ar(a) = mList(a)
    Next

    ar(index) = vItem

    For a = index + 1 To i
        ar(a) = mList(a - 1)
    Next

    mList = ar
    Exit Sub
Err:
        ListError = Err
End Sub

Private Sub BubbleSort(ByVal vArray As Variant)
    ClearError
    On Error GoTo Err

    Dim i As Long
    Dim iMin As Long
    Dim iMax As Long
    Dim vSwap As Variant
    Dim swapped As Boolean

    iMin = LBound(vArray)
    iMax = UBound(vArray) - 1

    Do
        swapped = False
    For i = iMin To iMax
        If vArray(i) > vArray(i + 1) Then
            vSwap = vArray(i)
            vArray(i) = vArray(i + 1)
            vArray(i + 1) = vSwap
            swapped = True
        End If
    Next
    iMax = iMax - 1
    Loop Until Not swapped
    mList = vArray
    Erase vArray
    Exit Sub
Err:
        ListError = Err
End Sub

Private Sub DeleteElementAt(index As Integer)
    ClearError
    On Error GoTo Err

    Dim i As Integer
    For i = index + 1 To Count - 1
        mList(i - 1) = mList(i)
    Next
    ReDim Preserve mList(Count - 2)
    Exit Sub
Err:
        ListError = Err
End Sub

Private Sub DeleteElement(ByRef vItem As Variant)
    ClearError
    On Error GoTo Err

    DeleteElementAt (FindItem(vItem))
    Exit Sub
Err:
        ListError = Err
End Sub

Private Sub AddItem(vItem As Variant)
    ClearError
    On Error GoTo Err

    Dim i As Long
    i = Count
    ReDim Preserve mList(i)
    mList(i) = vItem
    Exit Sub
Err:
        ListError = Err
End Sub

Private Function FindItem(vItem As Variant) As Long
    ClearError
    On Error GoTo Err

    FindItem = -1

    For i = 0 To Count - 1
        If mList(i) = vItem Then
        FindItem = i
        Exit For
        End If
    Next i
    Exit Function
Err:
        ListError = Err
        FindItem = -1
End Function

Private Function GetLastIndexOf(vItem As Variant) As Long
    ClearError
    On Error GoTo Err

    GetLastIndexOf = -1
    Dim i As Long

    For i = Count - 1 To 0 Step -1
        If mList(i) = vItem Then
            GetLastIndexOf = i
        Exit Function
        End If
    Next i
    Exit Function
Err:
        ListError = Err
        GetLastIndexOf = -1
End Function

Private Sub ReverseList()
    ClearError
    On Error GoTo Err

    Dim ar() As Variant
    Dim i As Long
    Dim j As Long

    If Count = 0 Then Exit Sub
    i = Count - 1
    j = i
    ReDim ar(i)

    For a = 0 To i
        ar(a) = mList(j)
        j = j - 1
    Next a

    mList = ar
    Erase ar
    Exit Sub
Err:
        ListError = Err
End Sub

Private Function ItemExists(vItem As Variant) As Boolean
    If FindItem(vItem) > -1 Then
        ItemExists = True
    Else
        ItemExists = False
    End If
End Function

Private Function GetCopy() As ListClass
    Dim list As New ListClass
    Set list = list.CreateInstance

    For i = 0 To Count - 1
        list.Add mList(i)
    Next i
    Set GetCopy = list
    i = GetCopy.Count
End Function

现在是发生错误的函数...

Function ReadData() As ListClass

    'instanteate list
    Dim list As ListClass
    Set list = New ListClass


    'get sheets
    Dim sheet As Worksheet
    Set sheet = Sheets("Data")
    Dim dataSheet As Worksheet
    Set dataSheet = Sheets("DataSet")

    'read lines and store them on list
    Dim i As Integer
    i = 2
    Do While sheet.Cells(i, 1) <> ""
        Dim data_set As DataSet
        Set data_set = New DataSet

        data_set.entry_spread = CSng(dataSheet.Cells(i, 7).Value)
        data_set.result = CSng(dataSheet.Cells(i, 12).Value)
        data_set.lot = CInt(dataSheet.Cells(i, 13).Value)
        data_set.win = IIf(UCase(dataSheet.Cells(i, 15).Value) = "YES", True, False)
        data_set.group = CInt(dataSheet.Cells(i, 20).Value)
        data_set.atr = CSng(dataSheet.Cells(i, 21).Value)
        data_set.pdr = CSng(dataSheet.Cells(i, 22).Value)
        data_set.ir = CSng(dataSheet.Cells(i, 23).Value)
        data_set.fib = dataSheet.Cells(i, 24).Value
        data_set.slipage = CSng(dataSheet.Cells(i, 25).Value)
        data_set.slipread = CSng(dataSheet.Cells(i, 26).Value)
        list.Add CVar(data_set) 'error happens here...
        i = i + 1
    Loop

    ReadData = list

End Function

Answer 1

您不需要创建自己的构造函数，因为您没有传递任何参数 - 因此您可以只使用 Class_Initialize 事件。替换为：

'==============================
'Constructor
'==============================
Public Sub Initialize()
    Disposed = False
    ReDim mList(0)
End Sub

Public Function CreateInstance() As ListClass
    Dim oNew As New ListClass
    oNew.Initialize
    Set CreateInstance = oNew
End Function

有了这个：

Private Sub Class_Initialize()
    Disposed = False
    ReDim mList(0)
End Sub

并记得从 GetCopy 函数中删除这一行：

Set list = list.CreateInstance

编辑：忘了说，因为你传递的是对象，所以在将它们分配给数组 mList.

时需要使用 Set

将 class 作为 Variant 参数传递时出现运行时错误

Runtime error when passing a class as a Variant argument

excel

vba

types

mismatch