• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Subscript out of range.

C

cad1996

New Member
Dear Experts,
When I use a large number of texts with this code, I encounter the error: "Subscript out of range."

This code is specifically for extracting details from AutoCAD text and polylines.

Code: 
Option Explicit

Sub ExtractAutoCADData()
    ' Declare AutoCAD variables
    Dim acadApp As Object
    Dim acadDoc As Object
    Dim acadEnt As Object
    Dim acadTxt As Object
    Dim acadPline As Object
    Dim textCoord As Variant
    Dim polylineCoords As Variant
    Dim numVertices As Long
    Dim i As Long
    Dim closestPoint As Variant
    Dim minDist As Double
    Dim chainage As Double
    Dim perpDist As Double
    Dim direction As String
    
    ' Declare Excel variables
    Dim ws As Worksheet
    Dim data() As Variant
    Dim dataCount As Long
    Dim textName As String
    
    ' Initialize AutoCAD application
    Set acadApp = GetObject(, "AutoCAD.Application")
    Set acadDoc = acadApp.ActiveDocument
    
    ' Select polyline
    Set acadPline = SelectPolyline(acadDoc)
    If acadPline Is Nothing Then
        MsgBox "No polyline selected!", vbExclamation
        Exit Sub
    End If
    
    ' Get polyline coordinates
    polylineCoords = acadPline.Coordinates
    numVertices = UBound(polylineCoords) \ 2
    
    ' Initialize data array
    dataCount = 0
    ReDim data(1 To 100, 1 To 6) ' Initial size, will resize if needed
    
    ' Iterate through entities in the model space for text
    For Each acadEnt In acadDoc.ModelSpace
        ' Check for text objects
        If acadEnt.ObjectName = "AcDbText" Then
            Set acadTxt = acadEnt
            textName = acadTxt.TextString
            textCoord = acadTxt.InsertionPoint
            closestPoint = GetClosestPointOnPolyline(polylineCoords, textCoord, minDist, chainage)
            perpDist = minDist
            direction = GetTextDirection(polylineCoords, textCoord, closestPoint)
            If direction = "Left" Then
                perpDist = -perpDist
            End If
            
            ' Store data in array
            dataCount = dataCount + 1
            If dataCount > UBound(data, 1) Then
                ReDim Preserve data(1 To dataCount + 100, 1 To 6)
            End If
            data(dataCount, 1) = textName
            data(dataCount, 2) = textCoord(0)
            data(dataCount, 3) = textCoord(1)
            data(dataCount, 4) = perpDist
            data(dataCount, 5) = chainage
            data(dataCount, 6) = direction
        End If
    Next acadEnt
    
    ' Trim the array to the actual size
    If dataCount > 0 Then
        On Error Resume Next
        ReDim Preserve data(1 To dataCount, 1 To 6)
        On Error GoTo 0
    Else
        MsgBox "No text objects found!", vbExclamation
        Exit Sub
    End If
    
    ' Initialize Excel worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ws.Cells.Clear ' Clear existing data
    ws.Range("A1:F1").Value = Array("Text Name", "X Coord", "Y Coord", "Perpendicular Distance", "Chainage", "Direction")
    
    ' Output data to Excel
    Dim row As Long
    row = 2
    For i = 1 To dataCount
        ws.Cells(row, 1).Value = data(i, 1)
        ws.Cells(row, 2).Value = data(i, 2)
        ws.Cells(row, 3).Value = data(i, 3)
        ws.Cells(row, 4).Value = data(i, 4)
        ws.Cells(row, 5).Value = data(i, 5)
        ws.Cells(row, 6).Value = data(i, 6)
        row = row + 1
    Next i
    
    ' Clean up
    Set acadApp = Nothing
    Set acadDoc = Nothing
    Set acadEnt = Nothing
    Set acadTxt = Nothing
    Set acadPline = Nothing
End Sub

Function SelectPolyline(acadDoc As Object) As Object
    Dim acadSelSet As Object
    Dim polyline As Object
    
    On Error Resume Next
    Set acadSelSet = acadDoc.SelectionSets.item("MySelection")
    If Err.Number <> 0 Then
        Set acadSelSet = acadDoc.SelectionSets.Add("MySelection")
    Else
        acadSelSet.Clear
    End If
    On Error GoTo 0
    
    acadDoc.Utility.Prompt "Select a polyline: "
    acadSelSet.SelectOnScreen
    
    If acadSelSet.Count > 0 Then
        Set polyline = acadSelSet.item(0)
        If polyline.ObjectName = "AcDbPolyline" Then
            Set SelectPolyline = polyline
        End If
    End If
    acadSelSet.Delete
End Function

Function GetClosestPointOnPolyline(polylineCoords As Variant, textCoord As Variant, ByRef minDist As Double, ByRef chainage As Double) As Variant
    Dim i As Long
    Dim segmentStart As Variant
    Dim segmentEnd As Variant
    Dim testPoint As Variant
    Dim dist As Double
    Dim totalLength As Double
    Dim segmentLength As Double
    Dim param As Double
    
    minDist = 1E+30
    chainage = 0
    totalLength = 0
    
    For i = 0 To UBound(polylineCoords) - 2 Step 2
        segmentStart = Array(polylineCoords(i), polylineCoords(i + 1))
        segmentEnd = Array(polylineCoords(i + 2), polylineCoords(i + 3))
        
        ' Get perpendicular distance from text to line segment
        testPoint = GetPerpendicularPoint(segmentStart, segmentEnd, textCoord, param)
        dist = Sqr((testPoint(0) - textCoord(0)) ^ 2 + (testPoint(1) - textCoord(1)) ^ 2)
        
        ' Update minimum distance and chainage
        If dist < minDist Then
            minDist = dist
            GetClosestPointOnPolyline = testPoint
            chainage = totalLength + param * Sqr((segmentEnd(0) - segmentStart(0)) ^ 2 + (segmentEnd(1) - segmentStart(1)) ^ 2)
        End If
        
        ' Update total length of polyline
        segmentLength = Sqr((segmentEnd(0) - segmentStart(0)) ^ 2 + (segmentEnd(1) - segmentStart(1)) ^ 2)
        totalLength = totalLength + segmentLength
    Next i
End Function

Function GetPerpendicularPoint(segmentStart As Variant, segmentEnd As Variant, textCoord As Variant, ByRef param As Double) As Variant
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim px As Double, py As Double
    Dim dotProduct As Double
    Dim segmentLengthSq As Double
    
    x1 = segmentStart(0)
    y1 = segmentStart(1)
    x2 = segmentEnd(0)
    y2 = segmentEnd(1)
    px = textCoord(0)
    py = textCoord(1)
    
    segmentLengthSq = (x2 - x1) ^ 2 + (y2 - y1) ^ 2
    If segmentLengthSq = 0 Then
        GetPerpendicularPoint = segmentStart
        param = 0
        Exit Function
    End If
    
    dotProduct = ((px - x1) * (x2 - x1) + (py - y1) * (y2 - y1)) / segmentLengthSq
    param = dotProduct
    
    If param < 0 Then
        GetPerpendicularPoint = segmentStart
        param = 0
    ElseIf param > 1 Then
        GetPerpendicularPoint = segmentEnd
        param = 1
    Else
        GetPerpendicularPoint = Array(x1 + param * (x2 - x1), y1 + param * (y2 - y1))
    End If
End Function

Function GetTextDirection(polylineCoords As Variant, textCoord As Variant, closestPoint As Variant) As String
    Dim segmentStart As Variant
    Dim segmentEnd As Variant
    Dim i As Long
    
    For i = 0 To UBound(polylineCoords) - 2 Step 2
        segmentStart = Array(polylineCoords(i), polylineCoords(i + 1))
        segmentEnd = Array(polylineCoords(i + 2), polylineCoords(i + 3))
        
        If (closestPoint(0) >= segmentStart(0) And closestPoint(0) <= segmentEnd(0)) Or (closestPoint(0) <= segmentStart(0) And closestPoint(0) >= segmentEnd(0)) Then
            If (closestPoint(1) >= segmentStart(1) And closestPoint(1) <= segmentEnd(1)) Or (closestPoint(1) <= segmentStart(1) And closestPoint(1) >= segmentEnd(1)) Then
                If ((segmentEnd(0) - segmentStart(0)) * (textCoord(1) - segmentStart(1)) - (segmentEnd(1) - segmentStart(1)) * (textCoord(0) - segmentStart(0))) > 0 Then
                    GetTextDirection = "Left"
                Else
                    GetTextDirection = "Right"
                End If
                Exit Function
            End If
        End If
    Next i
End Function
 
... seems to write something to my 2nd question ...
You can only redim the last dimension of a 2-D array when using Preserve
... and You try to do it with ... which one?
 
You'll need to make the last dimension the one you change, so some re-writing necessary:
Code: 
ReDim Data(1 To 100, 1 To 6) ' Initial size, will resize if needed
becomes:
Code: 
ReDim Data(1 To 6, 1 To 100) ' Initial size, will resize if needed

Code: 
If dataCount > UBound(Data, 1) Then
  ReDim Preserve Data(1 To dataCount + 100, 1 To 6)
End If
becomes:
Code: 
If dataCount > UBound(Data, 2) Then
  ReDim Preserve Data(1 To 6, 1 To dataCount + 100)
End If

Code: 
Data(dataCount, 1) = textName
Data(dataCount, 2) = textCoord(0)
Data(dataCount, 3) = textCoord(1)
Data(dataCount, 4) = perpDist
Data(dataCount, 5) = chainage
Data(dataCount, 6) = Direction
becomes:
Code: 
Data(1, dataCount) = textName
Data(2, dataCount) = textCoord(0)
Data(3, dataCount) = textCoord(1)
Data(4, dataCount) = perpDist
Data(5, dataCount) = chainage
Data(6, dataCount) = Direction

Code: 
ReDim Preserve Data(1 To dataCount, 1 To 6)
becomes:
Code: 
ReDim Preserve Data(1 To 6, 1 To dataCount)
(although there's no real need to do this).

This:
Code: 
For i = 1 To dataCount
  ws.Cells(Row, 1).Value = Data(i, 1)
  ws.Cells(Row, 2).Value = Data(i, 2)
  ws.Cells(Row, 3).Value = Data(i, 3)
  ws.Cells(Row, 4).Value = Data(i, 4)
  ws.Cells(Row, 5).Value = Data(i, 5)
  ws.Cells(Row, 6).Value = Data(i, 6)
  Row = Row + 1
Next i
becomes:
Code: 
For i = 1 To dataCount
  ws.Cells(Row, 1).Value = Data(1, i)
  ws.Cells(Row, 2).Value = Data(2, i)
  ws.Cells(Row, 3).Value = Data(3, i)
  ws.Cells(Row, 4).Value = Data(4, i)
  ws.Cells(Row, 5).Value = Data(5, i)
  ws.Cells(Row, 6).Value = Data(6, i)
  Row = Row + 1
Next i
although it could be shortened to:
Code: 
For i = 1 To dataCount
  For c = 1 To 6
    ws.Cells(i + 1, c).Value = Data(c, i)
  Next c
Next i
(you'll need to Dim C as long somewhere, but there's no need for a Row variable).

Obviously, this is difficult for me to test.
 
You must log in or register to reply here.
Back
Top