批量交点插入块

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

看看作品

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

Linhay 发表于 2015-6-11 17:25
在图中,只要用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(cons ipts 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 @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(cons  ipts 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
你试试这个。没用过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

速度有待提高，赞

账号		自动登录	找回密码
密码			注册

[源码] 批量交点插入块

评分

本帖子中包含更多资源

本帖子中包含更多资源