明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 604|回复: 5

方格排序 感谢73哥等大神函数

[复制链接]
发表于 2017-12-12 15:16 | 显示全部楼层 |阅读模式
方格排序 感谢73哥等大神函数[code="lisp] (defun zxzb (pts / len pt )
  (setq len (length pts))
(setq pt (mapcar
  '(lambda(x)
    (/ x len)
  )
  (apply
    'mapcar
    (cons '+ pts)
  )
)
)  pt)


(defun Plinexy(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 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 t2t (p1 p2 p3 / p1 p2 p3) ;点到直线距离1
  

  (abs (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1))))
  
)   ;;;;;;;;;;;;;;;;

(defun t1t (p1 p2 p3 / p1 p2 p3) ;点到直线距离2
  

   (car (trans (mapcar '- p3 p1) 0 (mapcar '- p2 p1)))
  
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:szpx (/ ssa kongbiao i ii zb paixuzb p1 p2 fgjj p3 cishu kb kbb iii)
(setq ssa (ssget "x"'( (0 . "polyline")  (8 . "tf-fg1") ) ) )
(setq kongbiao '()) (setq i 0)
(foreach x (cx-ss2en ssa)
     
    (setq zb (zxzb(plinexy x))) (setq kongbiao (append (list zb) kongbiao)) (setq i (1+ i))
  )

(setq paixuzb (vl-sort kongbiao
             (function (lambda (e1 e2)      (> (cadr e1)(cadr e2 ) )   
              ) ) )
       )
(setq p1 (getpoint "\n请选择直线起点:"))
  (setq p2 (getpoint "\n请选择直线第二点:"))
(setq fgjj (getint "\n请输入方格间距(输入整数):"));输入整数
  (setq p3 (last paixuzb))
(setq cishu (+ 2 (fix (/ (t2t p1 p2 p3) fgjj )  ) ) )
(setq kb '()) (setq ii 0)
(repeat cishu
   

(setq kbb
(vl-sort (vl-remove-if-not  (FUNCTION (LAMBDA (A1) (< (* -1 fgjj) (t1t (polar p1 (+ (* 0.5 pi)(angle p1 p2)) (* ii fgjj)) (polar p2 (+ (* 0.5 pi)(angle p1 p2)) (* ii fgjj)) A1) 0) ))  kongbiao)
             (function (lambda (e1 e2)      (> (car e1)(car e2 ) )   
              ) ) )

)  
(setq kb (append kbb kb))

(setq ii (1+ ii))


  )
  (setq iii 0)
(foreach n (reverse kb)


   (entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos (+ iii 1) 2 0)) (cons 10 n ) (cons 40 1.0)))
  (entmake (list '(0 . "circle") '(8 . "fgbj")(cons 62 3) (cons 10 n ) (cons 40 1.0)))
(setq iii (1+ iii))

  )

(princ)
)[/code]

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x

评分

参与人数 2明经币 +2 收起 理由
USER2128 + 1 赞一个!
BaoWSE + 1 赞一个!

查看全部评分

本帖被以下淘专辑推荐:

  • · excel|主题: 80, 订阅: 1
 楼主| 发表于 2017-12-12 15:50 | 显示全部楼层
欢迎下载 改进

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2017-12-25 23:38 | 显示全部楼层
好贴!估计楼主也花了不少时间写这个代码
发表于 2017-12-29 08:59 | 显示全部楼层
选择直线起点是只能选择最北的直线并且得从右往左选择,不然就出错,能否优化一下
发表于 2018-1-4 16:40 | 显示全部楼层

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
发表于 2018-1-4 16:48 | 显示全部楼层
本帖最后由 血司 于 2018-1-5 09:36 编辑

(defun c:lxybh (/ str k qz ss xxpx xxss zg)
        (setq ss (ssget (list '(0 . "*LWPOLYLINE")))
              zg (getreal"\n请输入标注字高:")
              qz (getstring"\n请输入前缀:")
        )
        (setq xxss nil)
        (foreach cc (lxy-ss->list ss)
                (setq xxss (append (list (lxy-poly-cen (lxy-poly-pts cc))) xxss))
        )
        (setq xxpx (lxy-pts-xy xxss 1 0))
        (setq k 0)
        (foreach aa xxpx
                (if (= qz nil)
                        (setq str (itoa (1+ k)))
                        (setq str (strcat qz (itoa (1+ k))))
                )
                (maketext aa str zg)
        )
        (princ)
)
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-9-25 09:34 , Processed in 0.247576 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表