[编程交流] 将多段线内部文本导出到

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

(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)