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
''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