Dears,
One user requested me a Excel VBA to list all polylines, inner texts and dimensions.
I checked on search and could not find a solution.
I attached a AutoCAD example.
There are several polylines and I know I need to make a loop to get all polylines and check one by one if there is a text inside it and after that make a way to link the dimension to the polyline.
Thank you
I'm testing but I found another issue.
The guys did not standardized the lines, there are lines and polylines.
The first time I tried your vba it did not get any data, so I found out that they were lines ,,, 😶
Thank you for yout attention, @grobnik I'm trying to adapt your code to identify the line too.
I change the if (If TypeOf Obj Is AcadPolyline Or TypeOf Obj Is AcadLine Then)
But not it is saying that the "object does not accept the property or method" I guess it because of the Obj.Coordinates that cannot be used with line.
Public Sub lista_poly()
Dim Myapp As Object
Dim MyDwg As AcadDocument
Dim Obj As AcadObject
Dim Ent As AcadEntity
Dim text As AcadText
Dim w As Worksheet
Dim Ppos() As Double
Dim line As AcadLine
Dim pontos As Double
Dim MySset As AcadSelectionSet
Dim FilterType(4) As Integer
Dim FilterData(4) As Variant
Dim P1(0 To 2) As Double
Dim P2(0 To 2) As Double
R = 2
Set Myapp = GetObject(, "Autocad.application")
Set MyDwg = Myapp.ActiveDocument
Sheets(1).Range("B1") = "X"
Sheets(1).Range("C1") = "Y"
x = 1
For Each Obj In MyDwg.ModelSpace
If TypeOf Obj Is AcadPolyline Or TypeOf Obj Is AcadLine Then
Line_Pos = Obj.Coordinates
For i = 0 To UBound(Line_Pos) Step 2
Sheets(1).Range("B" & R) = Line_Pos(i)
Sheets(1).Range("C" & R) = Line_Pos(i + 1)
R = R + 1
Next
' GetMaxNumber (Line_Pos)
P1(0) = Line_Pos(0)
P1(1) = Line_Pos(1)
P1(2) = 0
P2(0) = UBound(Line_Pos) - 1
P2(1) = UBound(Line_Pos)
P2(2) = 0
On Error Resume Next
Set MySset = MyDwg.SelectionSets.Add("MySel")
If Err.Number <> 0 Then
MyDwg.SelectionSets.Item("MySel").Delete
Set MySset = MyDwg.SelectionSets.Add("MySel")
End If
FilterType(0) = -4
FilterData(0) = "<or"
FilterType(1) = 0
FilterData(1) = "TEXT"
FilterType(2) = 0
FilterData(2) = "MTEXT"
FilterType(3) = 0
FilterData(3) = "DIMENSION"
FilterType(4) = -4
FilterData(4) = "or>"
'MySset.Select acSelectionSetWindow, P2, P1, FilterType, FilterData
MySset.Select acSelectionSetAll, , , FilterType, FilterData
If MySset.Count >= 1 Then
For a = 0 To MySset.Count
Select Case MySset.Item(a).ObjectName
Case "AcDbText"
Sheets(1).Range("A" & R) = MySset.Item(a).TextString
Case "AcDbRotatedDimension"
Debug.Print "DIMENSION ROTATED"
Sheets(1).Range("D" & R) = MySset.Item(a).Measurement
R = R + 1
End Select
Next
End If
End If
Next
End Sub
