Solved: AUTOCAD - can't find blocks in polylines

Hi everybody,

for the first time I'm using VBA with autocad on dwg files.

I found on internet a piece of code that is exactly what I was looking for. This sub get all the polylines in the file and extract attributes values from the blocks that stay within each polyline.

The fact is that the code works only with polylines with a few vertexes, doesn't work with complex lines because it doesn't get the blocks ("Etichetta Locale") staying inside the poly area.

Any ideas how to fix it? Thanx in advance.

[vba]
Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String, IDP As String, AreaP As Double, PerimP As Double)

Dim Filtertype(0) As Integer
Dim Filterdata(0) As Variant
'Dim Sset As AcadSelectionSet
Dim element As AcadEntity
Dim Coord As Variant
Dim Sset1 As AcadSelectionSet
Dim element1 As AcadBlockReference
Dim Punti3D As Variant
Dim Pigreco As Double
Pigreco = 4 * Atn(1)
On Error Resume Next
If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element")) Then
Set Sset = AcApp.ActiveDocument.SelectionSets.Item("element")
Sset.Delete
End If
Coord = MyPoly.Coordinates
x = ((UBound(Coord) - 1) / 2) + UBound(Coord)
ReDim Punti3D(0 To x + 1) As Double
For I = 0 To UBound(Coord) Step 2
Punti3D(u) = Coord(I)
Punti3D(u + 1) = Coord(I + 1)
u = u + 2
Punti3D(u) = 0
u = u + 1
Next I
If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element1")) Then
Set Sset1 = AcApp.ActiveDocument.SelectionSets.Item("element1")
Sset1.Delete
End If
Set Sset1 = AcApp.ActiveDocument.SelectionSets.Add("element1")
Filtertype(0) = 0
Filterdata(0) = "insert"
Sset1.SelectByPolygon acSelectionSetCrossingPolygon, Punti3D, Filtertype, Filterdata
'MsgBox ("selected elements:" & Sset1.Count)

z = 1

'AcApp.ActiveDocument.Regen acAllViewports
For Each element1 In Sset1
If element1.Name = "Etichetta Locale" Then
'element1.Highlight True
'MsgBox ("Object" & z & ":" & element1.Name & vbLf & "Punto inserimento" & vbLf & "x: " & element1.InsertionPoint(0) & vbLf & "y: " & element1.InsertionPoint(1) & vbLf & "Rotazione: " & (element1.Rotation) / Pigreco * 180)
varattributes = element1.GetAttributes
End if
Next

End sub
[/vba]

Quote:

---

Originally Posted by ALe

Hi everybody,

for the first time I'm using VBA with autocad on dwg files.

I found on internet a piece of code that is exactly what I was looking for. This sub get all the polylines in the file and extract attributes values from the blocks that stay within each polyline.

The fact is that the code works only with polylines with a few vertexes, doesn't work with complex lines because it doesn't get the blocks ("Etichetta Locale") staying inside the poly area.

Any ideas how to fix it? Thanx in advance.

[vba]
Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String, IDP As String, AreaP As Double, PerimP As Double)

Dim Filtertype(0) As Integer
Dim Filterdata(0) As Variant
'Dim Sset As AcadSelectionSet
Dim element As AcadEntity
Dim Coord As Variant
Dim Sset1 As AcadSelectionSet
Dim element1 As AcadBlockReference
Dim Punti3D As Variant
Dim Pigreco As Double
Pigreco = 4 * Atn(1)
On Error Resume Next
If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element")) Then
Set Sset = AcApp.ActiveDocument.SelectionSets.Item("element")
Sset.Delete
End If
Coord = MyPoly.Coordinates
x = ((UBound(Coord) - 1) / 2) + UBound(Coord)
ReDim Punti3D(0 To x + 1) As Double
For I = 0 To UBound(Coord) Step 2
Punti3D(u) = Coord(I)
Punti3D(u + 1) = Coord(I + 1)
u = u + 2
Punti3D(u) = 0
u = u + 1
Next I
If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element1")) Then
Set Sset1 = AcApp.ActiveDocument.SelectionSets.Item("element1")
Sset1.Delete
End If
Set Sset1 = AcApp.ActiveDocument.SelectionSets.Add("element1")
Filtertype(0) = 0
Filterdata(0) = "insert"
Sset1.SelectByPolygon acSelectionSetCrossingPolygon, Punti3D, Filtertype, Filterdata
'MsgBox ("selected elements:" & Sset1.Count)

z = 1

'AcApp.ActiveDocument.Regen acAllViewports
For Each element1 In Sset1
If element1.Name = "Etichetta Locale" Then
'element1.Highlight True
'MsgBox ("Object" & z & ":" & element1.Name & vbLf & "Punto inserimento" & vbLf & "x: " & element1.InsertionPoint(0) & vbLf & "y: " & element1.InsertionPoint(1) & vbLf & "Rotazione: " & (element1.Rotation) / Pigreco * 180)
varattributes = element1.GetAttributes
End if
Next

End sub
[/vba]

---

Try this one instead
hope this get you started

Code:

---

Option Explicit
Sub test()
 Dim objTemp As AcadEntity
    Dim objUtil As AcadUtility
    Dim oPline As AcadLWPolyline
    Dim varPnt As Variant
    Dim varCancel As Variant
    On Error GoTo Err_Control
    Set objUtil = ThisDrawing.Utility
    objUtil.GetEntity objTemp, varPnt, vbCrLf & "Select Contour>>"
    If TypeOf objTemp Is AcadLWPolyline Then
    Set oPline = objTemp
 Call AnalizzaBlocchiInPolilinea(oPline, "Etichetta Locale")
    End If
Err_Control:
    If Err.Number <> 0 Then
    MsgBox Err.Description
    End If
End Sub
Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String) '' IDP As String, AreaP As Double, PerimP As Double)
 
    Dim Filtertype(1) As Integer
    Dim Filterdata(1) As Variant
  Dim Sset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim i, z
    Dim PointsArray As Variant
    Dim Sset1 As AcadSelectionSet
    Dim oBlkRef As AcadBlockReference
    Dim oAttrib As AcadAttributeReference
    Dim Punti3D As Variant
    Dim Pigreco As Double
    Pigreco = 4 * Atn(1)
'    On Error Resume Next
 
          With ThisDrawing.SelectionSets
              While .Count > 0
                    .Item(0).Delete
              Wend
          Set Sset = .Add("$Blocks$")
          End With
 
    PointsArray = MyPoly.Coordinates
    ReDim Punti3D((UBound(PointsArray) + 1) / 2 * 3 - 1) As Double
                        For i = 0 To ((UBound(PointsArray) + 1) / 2) - 1
                            Punti3D(i * 3) = PointsArray(i * 2)
                            Punti3D(i * 3 + 1) = PointsArray(i * 2 + 1)
                            Punti3D(i * 3 + 2) = 0
                        Next
 
    Filtertype(0) = 0: Filtertype(1) = 2
    Filterdata(0) = "insert": Filterdata(1) = NomeP
    Sset.SelectByPolygon acSelectionSetWindowPolygon, Punti3D, Filtertype, Filterdata
    MsgBox ("selected Blocks: " & Sset.Count)
 
    z = 1
    For Each oEnt In Sset
    Set oBlkRef = oEnt
    ThisDrawing.Utility.Prompt vbCr & "Object" & z & ":" & oBlkRef.EffectiveName & vbLf & "Punto inserimento" & vbLf & "x: " & oBlkRef.InsertionPoint(0) & vbLf & "y: " & oBlkRef.InsertionPoint(1) & vbLf & "Rotazione: " & (oBlkRef.Rotation) / Pigreco * 180
            oBlkRef.Highlight True
            Dim varAttributes As Variant
 
            varAttributes = oBlkRef.GetAttributes
            For i = 0 To UBound(varAttributes)
          Set oAttrib = varAttributes(i)
          Dim strTag As String
          Dim strValue As String
          strTag = oAttrib.TagString
          strValue = oAttrib.TextString
          ThisDrawing.Utility.Prompt vbCr & "Tag: " & strTag & vbLf & "Value: " & strValue & vbLf
          Next i
          z = z + 1
    Next oEnt
 
End Sub

---

~'J'~

wow!
I'll give a try and let you know. Thanks

fixo, your code works.

The problem I'm facing is that I'm calling the sub from excel, and from excel I can't see the ThisDrawing Object.

I tried changing "ThisDrawing" with "ActiveDocument". In this case it doesn't work, running the code both in autocad as in excel. How is it possible????

Is there any way to use the ThisDrawing Object from Excel? Which library the object belongs to?

Quote:

---

Originally Posted by ALe

fixo, your code works.

The problem I'm facing is that I'm calling the sub from excel, and from excel I can't see the ThisDrawing Object.

I tried changing "ThisDrawing" with "ActiveDocument". In this case it doesn't work, running the code both in autocad as in excel. How is it possible????

Is there any way to use the ThisDrawing Object from Excel? Which library the object belongs to?

---

Hi, Ale
Change Thisdrawing on

AcApp.ActivedDocument like it is in your first post

Let me know if it's not working as well

It's driving me crazy.

I run the sub test with "ThisDrawing" and it works, with "ActiveDocument" doesn't.

Here your code updated to my needs, can't find a way to run the sub "RunTruFile".

[vba]Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String) '' IDP As String, AreaP As Double, PerimP As Double)

Dim Filtertype(1) As Integer
Dim Filterdata(1) As Variant
Dim Sset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim i, z
Dim PointsArray As Variant
Dim Sset1 As AcadSelectionSet
Dim oBlkRef As AcadBlockReference
Dim oAttrib As AcadAttributeReference
Dim Punti3D As Variant
Dim Pigreco As Double
Pigreco = 4 * Atn(1)
' On Error Resume Next

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

PointsArray = MyPoly.Coordinates
ReDim Punti3D((UBound(PointsArray) + 1) / 2 * 3 - 1) As Double
For i = 0 To ((UBound(PointsArray) + 1) / 2) - 1
Punti3D(i * 3) = PointsArray(i * 2)
Punti3D(i * 3 + 1) = PointsArray(i * 2 + 1)
Punti3D(i * 3 + 2) = 0
Next

Filtertype(0) = 0: Filtertype(1) = 2
Filterdata(0) = "insert": Filterdata(1) = NomeP
Sset.SelectByPolygon acSelectionSetWindowPolygon, Punti3D, Filtertype, Filterdata
MsgBox ("selected Blocks: " & Sset.Count)

z = 1
For Each oEnt In Sset
Set oBlkRef = oEnt
ThisDrawing.Utility.Prompt vbCr & "Object" & z & ":" & oBlkRef.EffectiveName & vbLf & "Punto inserimento" & vbLf & "x: " & oBlkRef.InsertionPoint(0) & vbLf & "y: " & oBlkRef.InsertionPoint(1) & vbLf & "Rotazione: " & (oBlkRef.Rotation) / Pigreco * 180
oBlkRef.Highlight True
Dim varAttributes As Variant

varAttributes = oBlkRef.GetAttributes
For i = 0 To UBound(varAttributes)
Set oAttrib = varAttributes(i)
Dim strTag As String
Dim strValue As String
strTag = oAttrib.TagString
strValue = oAttrib.TextString
ThisDrawing.Utility.Prompt vbCr & "Tag: " & strTag & vbLf & "Value: " & strValue & vbLf
Next i
z = z + 1
Next oEnt
End Sub

Sub RunTruFile()
Dim objSelectionSet As AcadSelectionSet
Dim intGroupCode(0) As Integer
Dim varDataCode(0) As Variant
Dim objAcadPoly As AcadLWPolyline
Dim lngL As Long
On Error Resume Next
'do Lightweight polylines
intGroupCode(0) = 0
varDataCode(0) = "LWPolyline"
ThisDrawing.SelectionSets.Item("Poly").Delete
If Err Then Err.Clear
'create a selection of all lightweight polylines
Set objSelectionSet = ThisDrawing.SelectionSets.Add("Poly")
objSelectionSet.Select acSelectionSetAll, , , intGroupCode, varDataCode

'go through each polyline object
For Each objAcadPoly In objSelectionSet
If objAcadPoly.Layer = "RM" Then Call AnalizzaBlocchiInPolilinea(objAcadPoly, "Etichetta Locale")
Next objAcadPoly
End Sub[/vba]

I attach the file I'm working with, maybe it's something regarding the file.

Thank you very much!

Sorry, I attach also the excel file with code in case you consider it useful

Quote:

---

Originally Posted by ALe

Sorry, I attach also the excel file with code in case you consider it useful

---

Ale,sorry, I was busy with my own
Wait please, I'll back tomorrow only

no problem fixo, take your time of course!

thanks

Quote:

---

Originally Posted by ALe

no problem fixo, take your time of course!

thanks

---

Ale
Try this module from AutoCAD only
If this codwill be working good for you tthen
we could be go further

Code:

---

''Attribute VB_Name = "RoomsToCSV"
Option Explicit
' Extractpolylines/ blocks data information to csv file
' Rooms must be as closed lwpolylines only
' CSV file would be created in the same folder you'll working
'~~~~~~~~~~~~~~~~~~~~'
Sub WriteCoorsToTextFile()
Dim oSset As AcadSelectionSet
Dim itmSet As AcadSelectionSet
Dim oPoly As AcadLWPolyline
Dim oEnt As AcadEntity
Dim nestEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oAttrib As AcadAttributeReference
Dim attArr() As AcadAttributeReference
Dim coordArr As Variant
Dim ftype(2) As Integer
Dim fdata(2) As Variant
Dim dxfCode, dxfValue
On Error GoTo Something_Wrong_Here
  With ThisDrawing.SelectionSets
              While .Count > 0
                    .Item(0).Delete
              Wend
          Set oSset = .Add("$Parcels$")
          End With
 
 
Dim strFileName As String
strFileName = ThisDrawing.Name
ftype(0) = 0
ftype(1) = 70
ftype(2) = 8
fdata(0) = "LWPOLYLINE"
fdata(1) = 1
fdata(2) = "RM"
dxfCode = ftype: dxfValue = fdata
Dim mode As Integer
mode = acSelectionSetAll
oSset.SelectOnScreen dxfCode, dxfValue
If oSset.Count = 0 Then
Exit Sub
End If
'Dim tmpArr() As Variant
'Dim i, j, m As Long
Dim fName, inpStr As String
Dim fDesc As Integer
fDesc = FreeFile
fName = InputBox("Enter file name without extension", "File Name")
fName = ThisDrawing.Path & "\" & fName & ".csv"
Open fName For Output As fDesc
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Dim filttype(1) As Integer
ReDim filtdata(1) As Variant
filttype(0) = 0
filttype(1) = 2
filtdata(0) = "INSERT"
filtdata(1) = "Etichetta Locale"
dxfCode = filttype: dxfValue = filtdata
''~~~~~~~~~~~~~build table headers ~~~~~~~~~~''
Dim strHeaders As String
strHeaders = "COD_LOC" & vbTab & "DESTINAZIONE" & vbTab & "CDC" & vbTab & "Tipo_polilinea" & vbTab & "ID_polilinea" & vbTab & "Area" & vbTab & "Perimetro" & vbTab & "Altezza Controsoffitto" & vbTab & "Altezza Soffitto" & vbTab & "Nome_FILE"
Print #fDesc, strHeaders
Dim n
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
For Each oEnt In oSset
Set oPoly = oEnt
Dim strOBjName As String
strOBjName = oPoly.ObjectName
Dim intId As Long
intId = oPoly.ObjectID
Dim dblArea As Double
dblArea = oPoly.Area
Dim dblPerim As Double
dblPerim = oPoly.Length
coordArr = get_vertices(oPoly)
 Set itmSet = ThisDrawing.SelectionSets.Add("$Room$")
 itmSet.SelectByPolygon acSelectionSetWindowPolygon, coordArr, dxfCode, dxfValue
 
  ''~~~to make sure that just one block inside~~~''
 If itmSet.Count = 1 Then
 Set nestEnt = itmSet.Item(0)
 Set oBlkRef = nestEnt
 
 ''~~~~~~~~~~~~loop through attributes~~~~~~~~''
 attArr = oBlkRef.GetAttributes
 Dim strCodLOc As String
  Dim strDest As String
  Dim strCDC As String
 For n = 0 To UBound(attArr)
 Set oAttrib = attArr(n)
 
''~~~~~~~~~~~~~~~~Select Case~~~~~~~~~~~~''
 If UCase(oAttrib.TagString) Like "DESTINAZIONE*" Then '<-- I use "Like" because of Single quotes in Tag name
 strDest = oAttrib.TextString
 ElseIf UCase(oAttrib.TagString) = "CODICE_LOCALE" Then
 strCodLOc = oAttrib.TextString
 ElseIf UCase(oAttrib.TagString) = "CENTRO_COSTO" Then
 strCDC = oAttrib.TextString
 End If
''~~~~~~~~~~~~~build tab delimited text line~~~~~~~~~~''
Dim strText As String
strText = strCodLOc & vbTab & strDest & vbTab & strCDC & vbTab & strOBjName & vbTab & CStr(intId) & vbTab _
& Format(dblArea, "0.00") & vbTab & Format(dblPerim, "0.00") & vbTab & "-" & vbTab & "-" & vbTab & strFileName
 Next n
 
Print #fDesc, strText
End If ''<--if itmSet.Count=1
ThisDrawing.SelectionSets.Item("$Room$").Delete
'itmSet.Delete
Next oEnt
Close #fDesc
ThisDrawing.SelectionSets.Item("$Parcels$").Delete
MsgBox "Done!"
Something_Wrong_Here:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
 
Public Function get_vertices(oPoly As AcadLWPolyline) As Double()
Dim retCoords  As Variant
Dim i As Long
retCoords = oPoly.Coordinates
    ReDim dblArr((UBound(retCoords) + 1) / 2 * 3 - 1) As Double
    For i = 0 To ((UBound(retCoords) + 1) / 2) - 1
        dblArr(i * 3) = retCoords(i * 2)
        dblArr(i * 3 + 1) = retCoords(i * 2 + 1)
        dblArr(i * 3 + 2) = 0
    Next
 
get_vertices = dblArr
End Function

---

Hi Ale,
Here is the final project
This will works just fom AutoCAD only because you can't switch twice
between Excel and "non-Office" external application without of loosing the focus

Go this way
Unzip attached project
Open AutoCAD
Type VBALOAD in the command line
Select decompressed project ALe.dvb
Click ALt+F11 to open VBA editor
and change all in References tab to you suit
(and the Excel file path at the very top of code module too)
Then type VBARUN to execute
See result after the message box "Done" would be appears
Sorry, I can't help further

~'J'~

it seems to me it works, except for complex polylines.

Thank you.

Is there any way to get automatically all the polylines of the drawing instead of prompt?

It works on 90% of polylines and it's enough for me.

I eliminated prompt by using "oSset.Select acSelectionSetAll"

I'm trying to insert the field formula in a new attribute of the block. The formula for the attribute value is:
"%<\AcObjProp Object(%<\_ObjId 2130239776>%).Area \f "%lu2">%" where ObjId 2130239776 is the poly containing the block.

It works manually, but I can't do it via VBA. I tried:
[vba] attArr = oBlkRef.GetAttributes

attArr(3).TextString = "%<\AcObjProp Object(%<\_ObjId 2130018928>%).Area>% \f " & """ %lu2 &""" & ">%"[/vba]

but the value of the attribute show an error like "####"

Try this quick example

Code:

---

Public Sub addField()
Dim oSset As AcadSelectionSet
Dim itmSet As AcadSelectionSet
Dim oPoly As AcadLWPolyline
Dim oEnt As AcadEntity
Dim nestEnt As AcadEntity
Dim n
Dim pickPt As Variant
Dim oBlkRef As AcadBlockReference
Dim oAttrib As AcadAttributeReference
Dim attArr() As AcadAttributeReference
Dim id As Long
ThisDrawing.Utility.GetEntity oEnt, pickPt, vbCr & "Select polyline:"
If TypeOf oEnt Is AcadLWPolyline Then
Set oPoly = oEnt
id = oPoly.ObjectID
End If
ThisDrawing.Utility.GetEntity oEnt, pickPt, vbCr & "Select block:"
If TypeOf oEnt Is AcadBlockReference Then
 Set oBlkRef = oEnt
 ''~~~~~~~~~~~~loop through attributes~~~~~~~~''
 attArr = oBlkRef.GetAttributes
 For n = 0 To UBound(attArr)
 Set oAttrib = attArr(n)
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
 If UCase(oAttrib.TagString) = "CENTRO_COSTO" Then '<--change attribute  name "CENTRO_COSTO" here on whatever you need
 oAttrib.TextString = "%<\AcObjProp Object(%<\_ObjId " & CStr(id) & ">%).Area \f " & Chr(34) & "%lu2" & Chr(34) & ">%"
 Exit For
 End If
 Next n
End If
ThisDrawing.Regen acActiveViewport '<-- this line is important to display fields after changing
End Sub

---

FIXO I'm really impressed! Thank you so much!

Quote:

---

Originally Posted by ALe

FIXO I'm really impressed! Thank you so much!

---

You're welcome
Happy computing :)

~'J'~