此 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 错误消息：

如何更改代码以便填充我的 collection？

谢谢！

安德鲁

Answer 1

遇到这个相关问题：

User Defined Type (UDT) as parameter in public Sub in class module (VB6)

我决定改变我的逻辑。现在我有一个 HatchData 对象的简单列表，Collection 只是从 tag 到列表中的 index。

编译并运行良好。因此，当我从地图中获取索引时，我可以使用该查找地图索引从我的列表中快速获取 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

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

This AutoCAD VBA code will not compile - passing a TYPE as a VARIANT

vba

autocad-plugin