PDA

View Full Version : Solved: AUTOCAD - can't find blocks in polylines


ALe
11-16-2010, 05:21 AM
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.


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
fixo
11-16-2010, 12:29 PM
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.


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


Try this one instead
hope this get you started


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'~
ALe
11-17-2010, 05:25 AM
wow!
I'll give a try and let you know. Thanks
ALe
11-17-2010, 08:31 AM
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?
fixo
11-17-2010, 01:58 PM
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
ALe
11-18-2010, 02:34 AM
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".

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

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

Thank you very much!
ALe
11-18-2010, 10:53 AM
Sorry, I attach also the excel file with code in case you consider it useful
fixo
11-19-2010, 10:32 AM
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
ALe
11-19-2010, 11:15 AM
no problem fixo, take your time of course!

thanks
fixo
11-19-2010, 01:59 PM
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


''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
fixo
11-21-2010, 03:27 AM
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'~
ALe
11-22-2010, 08:20 AM
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?
ALe
11-25-2010, 07:39 AM
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:
attArr = oBlkRef.GetAttributes

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

but the value of the attribute show an error like "####"
fixo
11-26-2010, 10:58 AM
Try this quick example


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
ALe
11-29-2010, 09:26 AM
FIXO I'm really impressed! Thank you so much!
fixo
11-30-2010, 06:29 AM
FIXO I'm really impressed! Thank you so much!
You're welcome
Happy computing :)

~'J'~