Export polyline inner text to excel

[miguelmlas]

Hello, everyone!

 

I am searching for a macro that can find all polylines in a drawing and export to excel the texts that are located inside them

 

I have a building plan (in attachment) with polylines enclosing each room and the corresponding room text number inside the polyline. I am looking for a macro that can export to excel a table like this:

Text inside polyline	Polyline Area (m2)
1.1	51.34 m2
1.2	28.75 m2
1.3	14.41 m2
1.1, 1.2, 1.3	100.75 m2

 

The polylines and room text numbers are located in different layers.

One of the polylines (last row in the table) encloses the whole building, which means that there is more that one text inside it.

Polylines without text numbers should also appear in the table

 

I am fairly new to VBA so any help you can provide would be highly appreciated!

Thanks in advance!

sample.dwg

[maratovich]

Sub selEntByPline()
On Error Resume Next
Dim objCadEnt As AcadEntity
Dim vrRetPnt As Variant
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim ntexts As Integer, iText As Integer
Dim myText As AcadText
ThisDrawing.Utility.GetEntity objCadEnt, vrRetPnt
If objCadEnt.ObjectName = "AcDbPolyline" Then
    Dim objLWPline As AcadLWPolyline
    Dim objSSet As AcadSelectionSet
    Dim dblCurCords() As Double
    Dim dblNewCords() As Double
    Dim iMaxCurArr, iMaxNewArr As Integer
    Dim iCurArrIdx, iNewArrIdx, iCnt As Integer
    Set objLWPline = objCadEnt
    dblCurCords = objLWPline.Coordinates
    iMaxCurArr = UBound(dblCurCords)
    If iMaxCurArr = 3 Then
        ThisDrawing.Utility.Prompt "The selected polyline should have minimum 2 segments..."
        Exit Sub
    Else
        iMaxNewArr = ((iMaxCurArr + 1) * 1.5) - 1
        ReDim dblNewCords(iMaxNewArr) As Double
        iCurArrIdx = 0: iCnt = 1
        For iNewArrIdx = 0 To iMaxNewArr
            If iCnt = 3 Then
                dblNewCords(iNewArrIdx) = 0
                iCnt = 1
            Else
                dblNewCords(iNewArrIdx) = dblCurCords(iCurArrIdx)
                iCurArrIdx = iCurArrIdx + 1
                iCnt = iCnt + 1
            End If
        Next
        Set objSSet = ThisDrawing.SelectionSets.Add("SELENT")
        gpCode(0) = 0:  dataValue(0) = "TEXT"
        objSSet.SelectByPolygon acSelectionSetWindowPolygon, dblNewCords, gpCode, dataValue
        ntexts = objSSet.Count
        For iText = 0 To ntexts - 1
            ' do your stuff here
            ' for instance I'm listing all textstrings of the found objects
            Set myText = objSSet.Item(iText)
            MsgBox ("Found :" & myText.TextString & " - " & objLWPline.Area & "m2")
        Next iText
        objSSet.Delete
    End If
Else
    ThisDrawing.Utility.Prompt "The selected object is not a 2D Polyline...."
End If
If Err.Number <> 0 Then
    MsgBox Err.Description
    Err.Clear
End If
End Sub

 

[BIGAL]

Lisp version note coded 2013.

 

(defun getcoords (ent)
  (vlax-safearray->list
    (vlax-variant-value
      (vlax-get-property
    (vlax-ename->vla-object ent)
    "Coordinates"
      )
    )
  )
)
 
(defun co-ords2xy ()
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq numb (/ (length co-ords) 2))
(setq I 0)
(repeat numb
(setq xy (list (nth I co-ords)(nth (+ I 1) co-ords) ))
(setq coordsxy (cons xy coordsxy))
(setq I (+ I 2))
) ; end repeat
) ; end defun

; program starts here
; choose output file change acdatemp to what you want
(setq fname (strcat "c:/acadtemp/" (getstring "\nEnter file name ")))
(setq fout (open fname "w"))

(setq plobjs (ssget (list (cons 0 "lwpolyline"))))
(setq numb1 (sslength plobjs))
(setq x numb1)

(repeat numb1
(setq obj (ssname plobjs (setq x (- x 1))))
(setq co-ords (getcoords obj))
(co-ords2xy)
; write pline co-ords here
(setq numb3 (length co-ords))
(setq z numb3)
(setq ansco-ords "")
(repeat numb3 
(setq ansco-ords (strcat ansco-ords (rtos (nth (setq z (- z 1)) co-ords) 2 3 ) " " ))
)
(setq ans (strcat "Pline " ansco-ords))
(write-line ans fout)
(setq ansco-ords "")
(setq ss (ssget "WP" coordsxy (list (cons 0 "Text,Mtext")))) ; selection set of text within polygon
(if (= ss nil) 
(princ "\nnothing inside")
(progn 
(setq coordsxy nil) ; reset for next time
(setq numb2 (sslength ss))
(setq y numb2)
(repeat numb2
(setq anstext (vlax-get-property (vlax-ename->vla-object (ssname ss (setq y (- y 1)))) "Textstring"))
(princ anstext) ; change to write text to file
(write-line (strcat "text " anstext) fout)
(princ "\n")
) ; end repeat2
(setq ss nil) ; reset for next poly
)
)
) ; end repeat1
(close fout)
(princ)