树櫴希德 发表于 2019-11-22 21:59:07

纵横断面面积标注

(defun cx-ss2en
(ss / enlst)
(cond
    ((= (type ss) 'PICKSET)
      (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
    )
    ((= (type ss) 'LIST)
      (setq enlst (ssadd))
      (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    )
    ((='ename(type ss))
      (ssadd ss)
    )
)
)


;[功能]点表求面积
(defun getarea (l)
   (abs(* 0.5
      (apply
      '+
      (mapcar
          '(lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))
          l
          (append (cdr l) (list (car l)))
      )
      )
   ) )
);;;;;;;;;;;;;;;;;;;
(defun vxs(e / p a b n ob q et d d1 en et)
    (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
    (cond((="LWPOLYLINE"et)
    (repeat(length a)(setq b (nth n a) n (+ n 1))
      (if (= 10 (car b))(progn
      (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
      (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
          (setq p (list q)))))))
   ((="POLYLINE"et)
    (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
      (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
      (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
      (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    (setq p(reverse p))))P)
;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;
(defun zxzb (pts / len pt )
(setq len (length pts))
(setq pt (mapcar
'(lambda(x)
    (/ x len)
)
(apply
    'mapcar
    (cons '+ pts)
)
)
)pt)

(defun c:dmmj ( /hxbl hxbl dmx zbb mj xzzb SSA x);hxbl hxbl dmx zbb

(setq hxbl (getint "\n请输入断面横向比例 1 :"))
(setq zxbl (getint "\n请输入断面纵向比例 1 :"))

(setq ssa (ssget '( (0 . "LWPOLYLINE")   ) ) ) ;(8 . "0")

(foreach x (cx-ss2en ssa)
;(setq dmx (car(entsel "\n请选择要标注断面面积的闭合多段线：")))
(setq zbb (vxs x))
(setq xzbb(mapcar          '(lambda (a ) (list   (* (car a)(/ hxbl 1000.000) )(* (cadr a)(/ zxbl 1000.000) )   )
          )
    zbb)

   )
(setq mj (getarea xzbb))

(entmake (list '(0 . "TEXT") '(8 . "fgbaj")(cons 1 (rtos mj 2 3)) (cons 10 (zxzb zbb) ) (cons 40 3.0)))

)
       )

gzxl 发表于 2019-11-23 08:53:47

学习学习下

树櫴希德 发表于 2019-11-23 10:52:32

gzxl 发表于 2019-11-23 08:53
学习学习下

大神大哥你太谦虚； 了:$

树櫴希德 发表于 2019-11-23 17:31:47

(defun c:zs()
(setq ss(ssget'((0 . "insert")(8 . "gcd")))j -1)
(setq gcz 0)
(repeat(sslength ss)
    (setq en(ssname ss(setq j(1+ j))))
    (setq el(entget en))
    (setq zb10(assoc 10 el))
    (setq zb(last zb10))
    (setq gcz(+ gcz zb))
)
(setq gczs(/ gcz (sslength ss)))
(prompt (strcat"\n平均数为：" (rtos gczs 2 3)))
(princ)
)

czb203 发表于 2019-12-2 19:53:37

大神，发给操作视频下，不太明白怎么使用

树櫴希德 发表于 2019-12-4 20:31:41

文字连接程序(defun c:tt (/ e el str tl)
(if (and (setq e (car (entsel "\nPick First Text: ")))
         (= (cdr (assoc 0 (setq el (entget e)))) "TEXT")
      )
    (progn
      (setq str (cdr (setq tl (assoc 1 el))))
      (while (and (setq e1 (car (entsel "\nNext Join: ")))
                  (= (cdr (assoc 0 (setq el1 (entget e)))) "TEXT")
             )
      (setq str (strcat str (cdr (assoc 1 el1))))
      (entmod      (subst (cons 1 str)
                     tl
                     el
                )
      )
      (entdel e1)
      )
    )
)
(princ)
)

f4800 发表于 2020-11-1 11:10:08

横断面面积标注感谢分享源码

技术工作室 发表于 2022-9-30 21:18:47

支持分享源码

技术工作室 发表于 2023-1-3 14:12:42

支持分享源码

cjf160204 发表于 2023-1-13 11:44:28

感谢分享源码
页: [1]
查看完整版本: 纵横断面面积标注