Dear Users/Experts,
I have a VBA code that exports AutoCAD polygon and inside text details to Excel. However, some text details are not being exported, and I am not sure why. Please review the code and let me know if any corrections are needed.
I have a VBA code that exports AutoCAD polygon and inside text details to Excel. However, some text details are not being exported, and I am not sure why. Please review the code and let me know if any corrections are needed.
Code:
Option Explicit
Sub PickLwPolysAndGetData()
' For Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range
' For AutoCAD application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim textObj As AcadText
Dim mtextObj As AcadMText
Dim coord As Variant
' For selection set purposes
Dim ssetPolys As AcadSelectionSet
Dim ssetText As AcadSelectionSet
Dim ssetMText As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
' For general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWPerimeter As Double, LWLayer As String
Dim textString As String, textCoordX As Double, textCoordY As Double, coordinates As String
Dim textHeight As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' Managing potential selection set existence
On Error Resume Next
Set ssetPolys = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetPolys = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetPolys.Clear
On Error Resume Next
Set ssetText = ThisDrawing.SelectionSets.Item("TextSSET")
If Err Then Set ssetText = ThisDrawing.SelectionSets.Add("TextSSET")
On Error GoTo 0
ssetText.Clear
On Error Resume Next
Set ssetMText = ThisDrawing.SelectionSets.Item("MTextSSET")
If Err Then Set ssetMText = ThisDrawing.SelectionSets.Add("MTextSSET")
On Error GoTo 0
ssetMText.Clear
' Selecting LWPolylines
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
ssetPolys.SelectOnScreen gpCode, dataValue
' Selecting Text
gpCode(0) = 0
dataValue(0) = "TEXT"
ssetText.SelectOnScreen gpCode, dataValue
' Selecting MText
gpCode(0) = 0
dataValue(0) = "MTEXT"
ssetMText.SelectOnScreen gpCode, dataValue
' Check if any objects are selected
If ssetPolys.Count = 0 Then
MsgBox "No polylines selected. Please select at least one closed polyline."
Exit Sub
End If
If ssetText.Count = 0 And ssetMText.Count = 0 Then
MsgBox "No text selected. Please select at least one text object."
Exit Sub
End If
' Writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(1, 1)
With MyCell
.Offset(0, 0).Value = "Polygon nr"
.Offset(0, 1).Value = "Layer"
.Offset(0, 2).Value = "Area (sq.m)"
.Offset(0, 3).Value = "Length"
.Offset(0, 4).Value = "Inside Text"
.Offset(0, 5).Value = "Text Coord X"
.Offset(0, 6).Value = "Text Coord Y"
.Offset(0, 7).Value = "Text Height"
.Offset(0, 8).Value = "Polygon Coordinates"
End With
' Clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 9).Clear
' Retrieving LWPolys and Text data and writing them on worksheet
iRow = 1
For Each LWPoly In ssetPolys
If TypeOf LWPoly Is AcadLWPolyline And LWPoly.Closed Then
' Retrieving LWPoly data
With LWPoly
LWArea = .Area
LWPerimeter = .Length
LWLayer = .Layer
coordinates = ""
For Each coord In .Coordinates
coordinates = coordinates & coord & ", "
Next coord
coordinates = Left(coordinates, Len(coordinates) - 2)
End With
' Retrieving associated text data
textString = ""
textCoordX = 0
textCoordY = 0
textHeight = 0
For Each textObj In ssetText
If TypeOf textObj Is AcadText Then
If IsTextInsidePolygon(CDbl(textObj.InsertionPoint(0)), CDbl(textObj.InsertionPoint(1)), LWPoly) Then
textString = textString & textObj.TextString & " "
textCoordX = textObj.InsertionPoint(0)
textCoordY = textObj.InsertionPoint(1)
textHeight = textObj.Height
End If
End If
Next textObj
For Each mtextObj In ssetMText
If TypeOf mtextObj Is AcadMText Then
If IsTextInsidePolygon(CDbl(mtextObj.InsertionPoint(0)), CDbl(mtextObj.InsertionPoint(1)), LWPoly) Then
textString = textString & mtextObj.TextString & " "
textCoordX = mtextObj.InsertionPoint(0)
textCoordY = mtextObj.InsertionPoint(1)
textHeight = mtextObj.TextHeight
End If
End If
Next mtextObj
' Debugging output
Debug.Print "Polygon nr." & iRow
Debug.Print "Text String: " & textString
Debug.Print "Text Coord X: " & textCoordX
Debug.Print "Text Coord Y: " & textCoordY
Debug.Print "Text Height: " & textHeight
' Writing LWPoly data
With MyCell
.Offset(iRow, 0).Value = "Polygon nr." & iRow
.Offset(iRow, 1).Value = LWLayer
.Offset(iRow, 2).Value = LWArea
.Offset(iRow, 3).Value = LWPerimeter
.Offset(iRow, 4).Value = Trim(textString)
.Offset(iRow, 5).Value = textCoordX
.Offset(iRow, 6).Value = textCoordY
.Offset(iRow, 7).Value = textHeight
.Offset(iRow, 8).Value = coordinates
End With
iRow = iRow + 1
End If
Next LWPoly
' Cleaning up before ending
ssetPolys.Delete
ssetText.Delete
ssetMText.Delete
Set ssetPolys = Nothing
Set ssetText = Nothing
Set ssetMText = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
Function IsTextInsidePolygon(x As Double, y As Double, LWPoly As AcadLWPolyline) As Boolean
Dim i As Integer
Dim j As Integer
Dim polyCoords As Variant
Dim n As Integer
Dim inside As Boolean
polyCoords = LWPoly.Coordinates
n = UBound(polyCoords) / 2
inside = False
j = n - 1
For i = 0 To n - 1
If ((polyCoords(2 * i + 1) > y) <> (polyCoords(2 * j + 1) > y)) And _
(x < (polyCoords(2 * j) - polyCoords(2 * i)) * (y - polyCoords(2 * i + 1)) / (polyCoords(2 * j + 1) - polyCoords(2 * i + 1)) + polyCoords(2 * i)) Then
inside = Not inside
End If
j = i
Next i
IsTextInsidePolygon = inside
End Function