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

mrzuolin 发表于 2014-8-30 17:43:09

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

ttthhh_hb 发表于 2014-8-30 19:49:37

(defun c:dy (/       ss    i ent enttypevlst
      arrobj newlst len ps pe    pm
      midpt ang    DIMASZ DIMBLK1 DIMBLK2DIMEXE
      DIMCLRTDIMEXO DIMGAP DIMLFAC DIMDEC    DIMLUNIT
      DIMTXSTY DIMTXT DIMSCALE DIMSAH DIMBLK    DIMCLRD
      DIMCLREDIMLWD 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 发表于 2014-8-31 07:48:47

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

ttthhh_hb 发表于 2014-8-31 11:40:34

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

zzyong00 发表于 2014-8-31 15:14:27

Sub FilterPLOrLine()
Dim sstext As AcadSelectionSet
Dim FilterType(3) As Integer
Dim FilterData(3) As Variant
Set sstext = ThisDrawing.SelectionSets.Add("SS6")
FilterType(0) = -4
FilterData(0) = "<or"
FilterType(1) = 0
FilterData(1) = "LINE"
FilterType(2) = 0
FilterData(2) = "LWPOLYLINE"
FilterType(3) = -4
FilterData(3) = "or>"

sstext.SelectOnScreen FilterType, FilterData
MsgBox sstext.Count
ThisDrawing.SelectionSets("SS6").Delete
End Sub
附一个选择line和pline的代码

页: [1]

明经CAD社区's Archiver

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