将多段线内部文本导出到
大家好！我正在搜索一个宏，该宏可以找到图形中的所有多段线，并将其中的文本导出到excel中
我有一个建筑平面图（见附件），其中多段线包围了每个房间，多段线内有相应的房间文本编号。我正在寻找一个宏，可以导出到excel这样的表格：
多段线内文字多段线面积（m2）1.1]51.34 m2]1.2]28.75 m2]1.3]14.41 m2]1.1，1.2，1.3100.75平方米
多段线和房间文字编号位于不同的层中。
其中一条多段线（表中的最后一行）包围了整个建筑，这意味着其中有多个文本。
没有文本编号的多段线也应出现在表中
我是VBA新手，非常感谢您的帮助！
[左对齐][颜色=#666666][大小=14px]提前感谢！
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 Lisp版本注释编码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)
页:
[1]