社区 › AutoLISP/Visual LISP 编程技术 › 批量交点插入块

【KAIXIN】 发表于 2015-6-12 10:36:36

看看作品

edata 发表于 2015-6-12 10:40:27

Linhay 发表于 2015-6-11 17:25 static/image/common/back.gif
在图中,只要用insert重新插入一下以后就能顺利运行,否则即使在图中也不可以。

你试试这个。没用过2016
;交点插块edata @mjtd.com 2015年6月
;先选线，再选块
(vl-load-com)
(defun c:jdck(/ ss ss_lst ss2_lst en1 en2 lst IPTS SK_BLK SS_BLK X)
(princ "\n选择需要插入块的线计算交点:")
(if(and(setq ss(ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
       (list t(princ"\n选择图块:"))
       (setq ss_blk(ssget ":E:S"'((0 . "insert"))))
       )
    (progn
      (setq sk_blk(cdr(assoc 2 (entget(ssname ss_blk 0)))))
      (setq ss_lst(sk_ss->list ss))      
      (while(setq en1(car ss_lst))
        (setq ss2_lst(cdr ss_lst))
        (while (setq en2(car ss2_lst))
          (setq ipts(sk_2obj_ipts en1 en2 nil))
          (if ipts (cond((=(type (car ipts)) 'LIST)
                       (setq lst(append ipts lst))
                       )
                        (t (setq lst(consipts lst)))
                        )
          )
          (setq ss2_lst(cdr ss2_lst))
          )
        (setq ss_lst(cdr ss_lst))
        )
      (setq lst(reverse lst))
      (if lst(setq lst(sk_removept lst 1e-8)))
      (if lst(mapcar '(lambda(x)(sk_insert sk_blk x)) lst))
      )
    (princ"\n没有选择!")
    )
(princ)
)
(defun sk_insert(name pt)(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt))))
(defun sk_ss->list(ss / en lst )
(if (= (type ss) 'PICKSET)
    (progn
      (setq lst '())
      (while (setq en (ssname ss 0))
        (setq lst(cons en lst))
        (setq ss(ssdel en ss))
        )
      (setq lst(reverse lst))
      )
    )
)
(defun sk_2obj_ipts(en1 en2 mode / ipts lst obj1 obj2)
(if (and en1 en2
           (or (= (type en1) 'ENAME)(= (type en1) 'VLA-OBJECT))
           (or (= (type en2) 'ENAME)(= (type en2) 'VLA-OBJECT))
           )
    (progn
      (setq obj1(if(= (type en1) 'ENAME)(vlax-ename->vla-object en1) en1)
          obj2(if(= (type en2) 'ENAME)(vlax-ename->vla-object en2) en2)
          mode(if (and mode (=(type mode) 'INT)) mode 0)
          )
      (setq ipts(vlax-variant-value (vla-intersectwith obj1 obj2 mode)));取得俩物体的交点变体
      (if (> (vlax-safearray-get-u-bound ipts 1) 0)
        (progn
          (setq ipts(vlax-safearray->list ipts);将vla交点变体转化成表的形式
                lst '())
          (if (>(length ipts) 3);分离多个交点
          (repeat(/(length ipts)3)
              (setq lst(cons(list(car ipts)(cadr ipts)(caddr ipts)) lst))
              (setq ipts(cdddr ipts))
              )
          (setq lst ipts)
          )
          lst
          )
        )
      )
    )
)
(defun sk_removept (ptLst fuzz / pt1)
    (cond ((<= (length ptLst) 1) ptLst)
          (t
         (setq pt1 (car ptLst))
         (cons pt1
               (vl-remove-if
                   '(lambda (x) (and(equal (car pt1) (car x) fuzz)
                                  (equal (cadr pt1) (cadr x) fuzz)
                                  )
                                  )
                   (sk_removept (cdr ptLst) fuzz)
               )
         )
          )
    )
)
(prompt"\n交点插块，命令 jdck")
(princ)

edata 发表于 2015-6-12 10:49:43

试了下匿名块

Linhay 发表于 2015-6-12 11:24:56

本帖最后由 Linhay 于 2015-6-12 12:43 编辑

edata 发表于 2015-6-12 10:40 static/image/common/back.gif
你试试这个。没用过2016
测试了,2016下运行没问题,谢谢~可是我还是想知道荒野大侠的作品在2016里运行到底因为什么出现错误.

EL_JAY 发表于 2015-6-12 13:40:34

看看源码

ynhh 发表于 2015-6-12 14:18:15

感谢你的分享啊

yzxdzy 发表于 2015-6-12 14:26:40

一直在找这个

52幕墙设计 发表于 2015-6-12 15:58:55

天天有惊喜啊

dongya1235 发表于 2015-6-12 16:00:16

谢谢分享。下载下来看看。

emk 发表于 2015-6-12 16:09:31

速度有待提高，赞

查看完整版本: 批量交点插入块