此AutoCAD VBA代码将无法编译-将TYPE传递为VARIANT

Question

我有以下VBA代码，正在AutoCAD 2014（64位）中编译和执行：

Option Explicit

Type HatchData
    iTag As Integer
    iType As Integer
    strPattern As String
    dScale As Double
    strLayer As String
End Type

Public Sub UpdateHatches()
    Dim mapHatches As Collection

    Call ReadHatchINI(mapHatches)

    MsgBox "Finished"
End Sub

Private Function ReadHatchINI(ByRef mapHatches As Collection)
    Dim vPath          As Variant

    vPath = m_cREG.QueryValue("Software\PathXXX", "HatchesPathINI")
    With m_cINI
        .path = vPath
        .Section = "Hatches"
        .Key = "NumHatches"
        .Default = 0

        Dim iHatch As Integer, iNumHatches As Integer
        Dim strHatchData As String
        Dim aryStrTokens() As String
        iNumHatches = .Value

        .Default = ""
        For iHatch = 1 To iNumHatches
            .Key = "Hatch" & CStr(iHatch)

            strHatchData = .Value
            If (strHatchData <> "") Then
                aryStrTokens = Split(strHatchData, " ", , vbTextCompare)

                ' TODO: Is it OK to declare the variable here ?
                Dim oHatchData As HatchData
                oHatchData.iTag = aryStrTokens(0)
                oHatchData.iType = aryStrTokens(1)
                oHatchData.strPattern = aryStrTokens(2)
                oHatchData.dScale = aryStrTokens(3)
                oHatchData.strLayer = aryStrTokens(4)

                ' TODO: Can't pass this HatchData object
                Call cSet(mapHatches, CStr(oHatchData.iTag), oHatchData)
            End If
        Next
    End With
End Function

Private Sub cSet(ByRef Col As Collection, Key As String, Item As Variant)
    If (cHas(Col, Key)) Then Col.Remove Key
    Col.Add Array(Key, Item), Key
End Sub

Private Function cGet(ByRef Col As Collection, Key As String) As Variant
    If Not cHas(Col, Key) Then Exit Function
    On Error Resume Next
        Err.Clear
        Set cGet = Col(Key)(1)
        If Err.Number = 13 Then
            Err.Clear
            cGet = Col(Key)(1)
        End If
    On Error GoTo 0
    If Err.Number <> 0 Then Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
End Function

Public Function cHas(Col As Collection, Key As String) As Boolean
    cHas = True
    On Error Resume Next
        Err.Clear
        Col (Key)
        If Err.Number <> 0 Then
            cHas = False
            Err.Clear
        End If
    On Error GoTo 0
End Function

Private Sub cRemove(ByRef Col As Collection, Key As String)
    If cHas(Col, Key) Then Col.Remove Key
End Sub

Private Function cKeys(ByRef Col As Collection) As String()
    Dim Initialized As Boolean
    Dim Keys() As String

    For Each Item In Col
        If Not Initialized Then
            ReDim Preserve Keys(0)
            Keys(UBound(Keys)) = Item(0)
            Initialized = True
        Else
            ReDim Preserve Keys(UBound(Keys) + 1)
            Keys(UBound(Keys)) = Item(0)
        End If
    Next Item

    cKeys = Keys
End Function

我有与此代码相关的特定问题：

' TODO: Can't pass this HatchData object
Call cSet(mapHatches, CStr(oHatchData.iTag), oHatchData)

这是我尝试运行它时显示的VBA错误消息：

如何更改代码，以便可以填充我的收藏集？

谢谢 ！

安德鲁

Answer 1

遇到此相关问题：

用户定义类型（UDT）作为类模块（VB6）中公共Sub中的参数

我决定改变自己的逻辑。 现在，我有一个简单的HatchData对象列表，并且Collection只是从标记到列表中索引的映射。

这样可以编译并正常运行。 因此，当我从地图获取索引时，可以使用该查找地图索引从列表中快速获取HatchData。

Option Explicit

Type HatchData
    iTag As Integer
    iType As Integer
    strPattern As String
    dScale As Double
    strLayer As String
End Type

Public Sub UpdateHatches()
    Dim aryHatches() As HatchData
    Dim mapHatches As Collection

    Set mapHatches = New Collection

    Call ReadHatchINI(aryHatches, mapHatches)

    MsgBox "Finished"
End Sub

Private Function ReadHatchINI(ByRef aryHatches() As HatchData, ByRef mapHatches As Collection)
    Dim vPath As Variant

    vPath = m_cREG.QueryValue("Software\PathXXXXX", "HatchesPathINI")
    With m_cINI
        .path = vPath
        .Section = "Hatches"
        .Key = "NumHatches"
        .Default = 0

        Erase aryHatches

        Dim iHatch As Integer, iNumHatches As Integer
        Dim strHatchData As String
        Dim aryStrTokens() As String
        iNumHatches = .Value

        .Default = ""
        For iHatch = 0 To iNumHatches - 1
            .Key = "Hatch" & CStr(iHatch + 1)

            strHatchData = .Value
            If (strHatchData <> "") Then
                aryStrTokens = Split(strHatchData, " ", , vbTextCompare)

                ReDim Preserve aryHatches(0 To iHatch)

                With aryHatches(iHatch)
                    .iTag = aryStrTokens(0)
                    .iType = aryStrTokens(1)
                    .strPattern = aryStrTokens(2)
                    .dScale = aryStrTokens(3)
                    .strLayer = aryStrTokens(4)
                End With

                ' TODO: Can't pass this HatchData object
                Call cSet(mapHatches, CStr(aryHatches(iHatch).iTag), iHatch)
            End If
        Next
    End With
    ' By the end we have a list of HatchData objects
    ' and a lookup map of tag id to HatchData index positions
End Function

Private Sub cSet(ByRef Col As Collection, Key As String, Item As Variant)
    If (cHas(Col, Key)) Then Col.Remove Key
    Call Col.Add(Item, Key)
End Sub

Private Function cGet(ByRef Col As Collection, Key As String) As Variant
    If Not cHas(Col, Key) Then Exit Function
    On Error Resume Next
        Err.Clear
        Set cGet = Col(Key)(1)
        If Err.Number = 13 Then
            Err.Clear
            cGet = Col(Key)(1)
        End If
    On Error GoTo 0
    If Err.Number <> 0 Then Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)
End Function

Public Function cHas(Col As Collection, Key As String) As Boolean
    cHas = True
    On Error Resume Next
        Err.Clear
        Col (Key)
        If Err.Number <> 0 Then
            cHas = False
            Err.Clear
        End If
    On Error GoTo 0
End Function

Private Sub cRemove(ByRef Col As Collection, Key As String)
    If cHas(Col, Key) Then Col.Remove Key
End Sub