Message 1 of 3
Runtime Error '13' Type mismatch on GetAttributes Method
Not applicable
01-18-2006
05:17 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
I have a small script that will extract the attributes from a block but I
get a Runtime Error '13' - Type Mismatch when I get to the line:
Set objAttributes = objBlockReference.GetAttributes
Can anyone tell me what I'm doing wrong here? I have a listing of my code
below
Thanks
Dustin
Public Sub TEST()
On Error GoTo ErrorHandler
Dim objSelectionSets As AcadSelectionSets
Dim objSelectionSet As AcadSelectionSet
Dim intSelectionSetType(0) As Integer
Dim objSelectionSetData(0) As Variant
Dim intSelectionSetCounter As Integer
Dim objApplication As AcadApplication
Dim objBlockReference As AcadBlockReference
Dim objAttributes As Variant 'AcadAttribute 'Variant
Dim lngAttributesCounter As Long
Dim lngSelectionSetCounter As Long
Dim strTitleBlock(9) As String
'* Select all Selection Sets within Drawing
Set objSelectionSets = ThisDrawing.SelectionSets
If objSelectionSets.Count > 0 Then
'* Remove all existing selection sets for the drawing
For Each objSelectionSet In objSelectionSets
objSelectionSet.Delete
Next
End If
strBlockName = "CPITITLE"
'* Filter for all Text
intSelectionSetType(0) = 2
objSelectionSetData(0) = Trim(strBlockName)
'* Create a selection set
Set objSelectionSet = objSelectionSets.Add("DrawingTitleBlock")
objSelectionSet.Select acSelectionSetAll, , , intSelectionSetType,
objSelectionSetData
'* Check to ensure the selection set is not null
If objSelectionSet.Count > 0 Then
For lngSelectionSetCounter = 0 To objSelectionSet.Count
Set objBlockReference = objSelectionSet.Item(0)
If objBlockReference.HasAttributes Then
Set objAttributes = objBlockReference.GetAttributes
For lngAttributesCounter = LBound(objAttributes) To
UBound(objAttributes)
Select Case
objAttributes(lngAttributesCounter).TagString
Case "CP_TDWG"
strTitleBlock(0) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TJNO"
strTitleBlock(1) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TREV"
strTitleBlock(2) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TACD"
strTitleBlock(3) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TPNO"
strTitleBlock(4) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TSNO"
strTitleBlock(5) =
objAttributes(lngAttributesCounter).TextString
Case "DRAW"
strTitleBlock(6) =
objAttributes(lngAttributesCounter).TextString
Case "DRAW_DATE"
strTitleBlock(7) =
objAttributes(lngAttributesCounter).TextString
Case "CHECK"
strTitleBlock(8) =
objAttributes(lngAttributesCounter).TextString
Case "CHECK_DATE"
strTitleBlock(9) =
objAttributes(lngAttributesCounter).TextString
Case Else
'* Should not occur
End Select
Next
Set objAttributes = Nothing
End If
Set objBlockReference = Nothing
Next
End If
objSelectionSet.Delete
Set objSelectionSet = Nothing
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub
get a Runtime Error '13' - Type Mismatch when I get to the line:
Set objAttributes = objBlockReference.GetAttributes
Can anyone tell me what I'm doing wrong here? I have a listing of my code
below
Thanks
Dustin
Public Sub TEST()
On Error GoTo ErrorHandler
Dim objSelectionSets As AcadSelectionSets
Dim objSelectionSet As AcadSelectionSet
Dim intSelectionSetType(0) As Integer
Dim objSelectionSetData(0) As Variant
Dim intSelectionSetCounter As Integer
Dim objApplication As AcadApplication
Dim objBlockReference As AcadBlockReference
Dim objAttributes As Variant 'AcadAttribute 'Variant
Dim lngAttributesCounter As Long
Dim lngSelectionSetCounter As Long
Dim strTitleBlock(9) As String
'* Select all Selection Sets within Drawing
Set objSelectionSets = ThisDrawing.SelectionSets
If objSelectionSets.Count > 0 Then
'* Remove all existing selection sets for the drawing
For Each objSelectionSet In objSelectionSets
objSelectionSet.Delete
Next
End If
strBlockName = "CPITITLE"
'* Filter for all Text
intSelectionSetType(0) = 2
objSelectionSetData(0) = Trim(strBlockName)
'* Create a selection set
Set objSelectionSet = objSelectionSets.Add("DrawingTitleBlock")
objSelectionSet.Select acSelectionSetAll, , , intSelectionSetType,
objSelectionSetData
'* Check to ensure the selection set is not null
If objSelectionSet.Count > 0 Then
For lngSelectionSetCounter = 0 To objSelectionSet.Count
Set objBlockReference = objSelectionSet.Item(0)
If objBlockReference.HasAttributes Then
Set objAttributes = objBlockReference.GetAttributes
For lngAttributesCounter = LBound(objAttributes) To
UBound(objAttributes)
Select Case
objAttributes(lngAttributesCounter).TagString
Case "CP_TDWG"
strTitleBlock(0) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TJNO"
strTitleBlock(1) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TREV"
strTitleBlock(2) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TACD"
strTitleBlock(3) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TPNO"
strTitleBlock(4) =
objAttributes(lngAttributesCounter).TextString
Case "CP_TSNO"
strTitleBlock(5) =
objAttributes(lngAttributesCounter).TextString
Case "DRAW"
strTitleBlock(6) =
objAttributes(lngAttributesCounter).TextString
Case "DRAW_DATE"
strTitleBlock(7) =
objAttributes(lngAttributesCounter).TextString
Case "CHECK"
strTitleBlock(8) =
objAttributes(lngAttributesCounter).TextString
Case "CHECK_DATE"
strTitleBlock(9) =
objAttributes(lngAttributesCounter).TextString
Case Else
'* Should not occur
End Select
Next
Set objAttributes = Nothing
End If
Set objBlockReference = Nothing
Next
End If
objSelectionSet.Delete
Set objSelectionSet = Nothing
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & Err.Description
Resume ExitSub
End Sub