Run-time Error '9' Subscript out of Range

[Anonymous]

I created VBA code to extract Dynamic Block Property, but occur error  "Run-time Error '9' Subscript out of Range". Please help me fix it. Tks All.

Sub EXtract_Table()

Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oBlk As AcadBlockReference
Dim varPt As Variant
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim k, bName As String
Dim xStr As String
Dim yStr As String
Dim i As Integer, j As Integer
Dim l As Integer
Dim aName As Variant
ftype(0) = 0: fdata(0) = "INSERT"
Dim dxfCode, dxfValue
dxfCode = ftype: dxfValue = fdata

With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set oSset = .Add("$Blocks$")
End With

ThisDrawing.ActiveSpace = acModelSpace

oSset.SelectOnScreen dxfCode, dxfValue

ThisDrawing.ActiveSpace = acModelSpace

Dim paSpace As AcadModelSpace
Set paSpace = ThisDrawing.ModelSpace

varPt = ThisDrawing.Utility.GetPoint(, "Specify insertion point: ")
Dim oTable As AcadTable
Set oTable = paSpace.AddTable(varPt, oSset.Count + 2, 5, 0.3, 1.5)
ZoomExtents
With oTable
.RegenerateTableSuppressed = True

.SetCellTextHeight i, j, 0.09375
.SetCellAlignment i, j, acMiddleCenter
.SetCellType i, j, acTextCell
.SetText 0, j, "HG"
.SetCellTextHeight i, j + 2, 0.09375
.SetText 0, j + 2, "ID"
.SetCellTextHeight i, j + 4, 0.09375
.SetText 0, j + 4, "ID"

.SetText 1, j + 1, "X"
.SetCellTextHeight 1, j + 1, 0.09375
.SetText 1, j + 2, "Y"
.SetCellTextHeight 1, j + 2, 0.09375
.SetText 1, j + 3, "Z"
.SetCellTextHeight 1, j + 3, 0.09375
l = oSset.Count - 1
ReDim aName(0 To l) As Variant

For i = 0 To oSset.Count - 1

Set oEnt = oSset.Item(i)
Set oBlk = oEnt
If oBlk.IsDynamicBlock Then
bName = oBlk.EffectiveName
Else
bName = oBlk.Name
End If
aName = oBlk.GetAttributes
k = aName(i).TextString
xStr = Format(CStr(Round(oBlk.InsertionPoint(1), 3)), "#0.000")
yStr = Format(CStr(Round(oBlk.InsertionPoint(0), 3)), "#0.000")
.SetCellTextHeight i, j, 0.09375
.SetCellAlignment i, j, acMiddleCenter
.SetText i + 2, j, k
.SetCellTextHeight i + 2, j, 0.09375
.SetText i + 2, j + 1, xStr
.SetCellTextHeight i + 2, j + 1, 0.09375
.SetText i + 2, j + 2, yStr
.SetCellTextHeight i + 2, j + 2, 0.09375
Next i
.RegenerateTableSuppressed = False
.Update
End With

End Sub

[norman.yuan]

See your code here:

For i = 0 To oSset.Count - 1

    ...

    aName = oBlk.GetAttributes

    k = aName(i).TextString

     ...

Next

As you can see, the enumerator i only related to how many block references are selected. let assume there is 10 selected, so, i would be from 0 to 9

aName is an array of AcadAttributeReference, its length depends on how many attribute the block reference has, and has nothing to do with the SelectionSet's count. The error you got is when i becomes greater than the attribute array's length. Even you did not get the error (when i is small enough), the attribute value you retrieved into k is probably not what you wanted, because for first loop, you get the first attribute, and the next loop you get the second attribute, and then the third... until the error comes out.

Also, AcadBlockReference.GetAttributes() does not guarantee attributes being placed in the array in certain order. You need to loop through the attributes array and get their values based on tag (usually) or maybe even other conditions, if necessary. Something like:

Dim j As Interger

Dim att As AcadAttributeReference

....

For i = 0 to oSset.Count -1

    ....

    aName = oBlk.GetAttributes

    For j = 0 To Ubound(aName)

        Set att= aName(j)

        Select Case att.TagString

            Case "XXXX"

                k=att.TextString

             Case ....

                  .....

        End Select

    Next

    ....

Next

[Anonymous]

I tried, but it not working.

[Ed__Jobe]

---

@Anonymous wrote:

I tried, but it not working.

---

Sorry, but that's not enough information to help you. What did you change? What's "not working"? Show your code since you changed it and explain what's not working.