遍历所有线,计算线的距离(DI)，并将长度以文本形式放在线的中上位置

mrzuolin

遍历所有线(L 或  PL),计算线(遍历中的某条线)的长度(DI)，并将长度以文本形式放在线的中上位置,文本的角度(ZT)与线一至
请问这个难吗？有人知道怎么弄吗？
付费也行，谢谢了。

ttthhh_hb

(defun c:dy (/              ss       i        ent         enttype  vlst
             arrobj   newlst   len        ps         pe          pm
             midpt    ang      DIMASZ        DIMBLK1         DIMBLK2  DIMEXE
             DIMCLRT  DIMEXO   DIMGAP        DIMLFAC         DIMDEC          DIMLUNIT
             DIMTXSTY DIMTXT   DIMSCALE        DIMSAH         DIMBLK          DIMCLRD
             DIMCLRE  DIMLWD   DIMLWE
            )
  (defun getdimvar ()
    (setq DIMSCALE (getvar "DIMSCALE")
          DIMASZ   (getvar "DIMASZ")
          DIMSAH   (getvar "DIMSAH")
          DIMBLK   (getvar "DIMBLK")
          DIMBLK1  (getvar "DIMBLK1")
          DIMBLK2  (getvar "DIMBLK2")
          DIMEXE   (getvar "DIMEXE")
          DIMEXO   (getvar "DIMEXO")
          DIMGAP   (getvar "DIMGAP")
          DIMLFAC  (getvar "DIMLFAC")
          DIMDEC   (getvar "DIMDEC")
          DIMTXT   (getvar "DIMTXT")
          DIMTXSTY (getvar "DIMTXSTY")
          DIMCLRT  (getvar "DIMCLRT")
          DIMCLRD  (getvar "DIMCLRD")
          DIMCLRE  (getvar "DIMCLRE")
          DIMLWD   (getvar "DIMLWD")
          DIMLWE   (getvar "DIMLWE")
          DIMLUNIT (getvar "DIMLUNIT")
          CLAYER   (getvar "CLAYER")
    )
    (if        (= DIMSCALE 0)
      (setq DIMSCALE 1)
    )
    (setq DIMASZ (* DIMSCALE DIMASZ)
          DIMEXE (* DIMSCALE DIMEXE)
          DIMEXO (* DIMSCALE DIMEXO)
          DIMGAP (* DIMSCALE DIMGAP)
          DIMTXT (* DIMSCALE DIMTXT)
    )
  )
  (getdimvar)
  (setq        ss     (ssget '((0 . "*LINE,ARC")))
        vlst   (list)
        newlst (list)
        i      0
  )
  (if ss
    (progn
      (repeat (sslength ss)
        (setq
          ent          (ssname ss i)
          enttype (cdr (assoc 0 (entget ent)))

        )
        (if (or (= enttype "LWPOLYLINE") (= enttype "POLYLINE"))
          (setq        arrobj (vla-explode
                         (vlax-ename->vla-object ent)
                       )
                vlst   (append
                         vlst
                         (vlax-safearray->list (vlax-variant-value arrobj))
                       )
                newlst (append
                         newlst
                         (vlax-safearray->list (vlax-variant-value arrobj))
                       )
          )
          (setq vlst (cons (vlax-ename->vla-object ent) vlst))
        )
        (setq i (1+ i))
      )
      (setq i 0)
      (repeat (length vlst)
        (setq obj   (nth i vlst)
              ps    (vlax-curve-getstartparam obj)
              pe    (vlax-curve-getendparam obj)
              pm    (/ (+ pe ps) 2)
              len   (vlax-curve-getDistAtParam
                      obj
                      pe
                    )
              midpt (vlax-curve-getpointatparam obj pm)
              ang   (angle '(0 0 0) (vlax-curve-getfirstderiv obj pm))
        )
        (setq ang (if (and (< (* 0.5 PI) ang) (>= (* 1.5 PI) ang))
                    (+ PI ang)
                    ang
                  )
        )
        (entmake
          (list
            (cons 0 "TEXT")
            (cons 100 "AcDbEntity")
            (cons 100 "AcDbText")
            (cons 7 DIMTXSTY)
            (cons 10 midpt)
            (cons 11 midpt)
            (cons 40 DIMTXT)
            (cons
              41
              (cdr (assoc 41 (tblsearch "STYLE" DIMTXSTY)))
            )
            (cons 1 (rtos (* DIMLFAC len) DIMLUNIT DIMDEC))
            (cons 50 ang)
            (cons 72 1)
            (cons 73 1)
          )
        )
        (setq i (1+ i))
      )
      (setq i 0)
      (repeat (length newlst)
        (setq obj (nth i newlst))
        (vla-Delete obj)
        (setq i (1+ i))
      )
    )
  )
)

mrzuolin

谢谢回答。
我画了两条线，然后创建LISP，运行后没有反应，我对LISP不熟，VBA勉强还能看懂。

ttthhh_hb

加载这段代码，在命令行里输入“dy”，然后选择线条即可。

zzyong00

1. Sub FilterPLOrLine()
   
2.     Dim sstext As AcadSelectionSet
   
3.     Dim FilterType(3) As Integer
   
4.     Dim FilterData(3) As Variant
   
5.     Set sstext = ThisDrawing.SelectionSets.Add("SS6")
   
6.     FilterType(0) = -4
   
7.     FilterData(0) = "<or"
   
8.     FilterType(1) = 0
   
9.     FilterData(1) = "LINE"
   
10.     FilterType(2) = 0
    
11.     FilterData(2) = "LWPOLYLINE"
    
12.     FilterType(3) = -4
    
13.     FilterData(3) = "or>"
    
14.    
    
15.     sstext.SelectOnScreen FilterType, FilterData
    
16.     MsgBox sstext.Count
    
17.     ThisDrawing.SelectionSets("SS6").Delete
    
18. End Sub

Sub FilterPLOrLine()<br />     Dim sstext As AcadSelectionSet<br />     Dim FilterType(3) As Integer<br />     Dim FilterData(3) As Variant<br />     Set sstext = ThisDrawing.SelectionSets.Add("SS6")<br />     FilterType(0) = -4<br />     FilterData(0) = "<or"<br />     FilterType(1) = 0<br />     FilterData(1) = "LINE"<br />     FilterType(2) = 0<br />     FilterData(2) = "LWPOLYLINE"<br />     FilterType(3) = -4<br />     FilterData(3) = "or>"<br />     <br />     sstext.SelectOnScreen FilterType, FilterData<br />     MsgBox sstext.Count<br />     ThisDrawing.SelectionSets("SS6").Delete<br /> End Sub

附一个选择line和pline的代码