交点布块，论坛里很多，带方向性的交点布块更有意思。
看一看，学一学。
(defun INSERT_with (ss2brk ss2brkwith self /
cmd intpts lst masterlist
ss ssobjs onlockedlayer
ssget->vla-list list->3pairget_interpts
INSERT_obj
)
(vl-load-com)
(setq ptlist nil)
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
(defun ssget->vla-list (ss / i ename lst)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq lst (cons (vlax-ename->vla-object ename) lst))
)
lst
)
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)
)
)
(reverse new)
)
(defun get_interpts (obj1 obj2 / iplist)
(if (not
(vl-catch-all-error-p
(setq
iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
)
)
)
)
)
)
iplist
)
)
(defun INSERT_obj (ent brkptlst / brkobjlst
en enttype maxparam closedobj
minparam obj obj2INSERTp1param
p2 p2param
)
(setq obj2INSERT ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
)
(foreach brkpt brkptlst
(if brkobjlst
(progn
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2INSERT brkpt)
)
)
)
(foreach obj brkobjlst
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj brkpt)
)
)
(setq obj2INSERT obj)
)
)
)
)
)
(cond
((and (= "SPLINE" enttype)
(vlax-curve-isclosed obj2INSERT)
)
(setq p1param (vlax-curve-getparamatpoint obj2INSERT brkpt)
p2 (vlax-curve-getpointatparam
obj2INSERT
(+ p1param 0.000001)
)
)
(setq pt (list (trans brkpt 0 1)))
(setq ptlist(append ptlist pt));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
)
((= "CIRCLE" enttype)
(setq p1param (vlax-curve-getparamatpoint obj2INSERT brkpt)
p2 (vlax-curve-getpointatparam
obj2INSERT
(+ p1param 0.000001)
)
)
(setq pt (list (trans brkpt 0 1)))
(setq ptlist (append ptlist pt));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq enttype "ARC")
)
((and (= "ELLIPSE" enttype)
(vlax-curve-isclosed obj2INSERT)
)
(setq p1param (vlax-curve-getparamatpoint obj2INSERT brkpt)
p2param (+ p1param 0.000001)
minparam (min p1param p2param)
maxparam (max p1param p2param)
obj (vlax-ename->vla-object obj2INSERT)
)
(vlax-put obj 'startparameter maxparam)
(vlax-put obj 'endparameter (+ minparam (* pi 2)))
)
(t
(setq closedobj (vlax-curve-isclosed obj2INSERT))
(setq pt (list (trans brkpt 0 1)))
(setq ptlist(append ptlist pt));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (not closedobj)
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
)
)
(if (and ss2brk ss2brkwith)
(progn
(foreach obj (ssget->vla-list ss2brk)
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
(foreach intobj (ssget->vla-list ss2brkwith)
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst))
)
)
(if lst
(setq masterlist
(cons (cons (vlax-vla-object->ename obj) lst)
masterlist
)
)
)
)
)
)
(if masterlist
(foreach obj2brk masterlist
(INSERT_obj (car obj2brk) (cdr obj2brk))
)
)
)
)
(setq ptlist (gps->lst-delsame ptlist))
(setq num (length ptlist))
(setq n 0)
(repeat num
(setq pt (nth n ptlist))
(if (and (>= maxX (car pt) minX)
(>= maxY (cadr pt) minY)
)
(command "_insert" ts pt d d "")
)
(setq n (1+ n))
)
(princ)
)
;;;xshrimp的函数
;;;删除表中重复图元.不支持表中表的重复图元.
;;; (gps->lst-delsame '(1 2 1 2 (1 1) (1 2 1 2 1) 1 2 (1 1) (1 2)))
;;;-->(1 2 (1 1) (1 2 1 2 1) (1 2))
(defun gps->lst-delsame (lst / lstitem lstnew)
(foreach lstitem lst
(if (not (member lstitem lstnew))
(setq lstnew (append lstnew (list lstitem)))
)
)
lstnew
)
(DEFUN C:ib (/ cmd ss)
(command "._undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ts "")
(while (not (tblsearch "BLOCK" ts))
(setq ts (getstring "\n请输入块的名称(回车选取):"))
(if (= "" ts)
(progn
(setq b0 nil)
(while (not b0)
(initget " ")
(setq b0 (entsel "\n选取样块："))
(cond
((= (type b0) 'STR) (setq b0 t))
((and
(= (type b0) 'LIST)
(/= (cdr (assoc 0 (setq b0 (entget (car b0)))))
"INSERT"
)
)
(setq b0 nil)
)
(t (setq ts (cdr (assoc 2 b0))))
)
)
)
)
)
(setq d (getreal "\n插入比例<1.0>"))
(if (null d)
(setq d 1.0)
(setq d (rtos d 2))
)
(while (and
(setq p1 (getpoint "\n请选择第一个角点："))
(setq p2 (GETCORNER p1 "\n请选择第二个角点："))
)
(setq ss
(ssget
"c"
p1
p2
'((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
)
)
)
(setq minX (apply 'min (mapcar 'car (list p1 p2)));借用Gu_xl的程序
minY (apply 'min (mapcar 'cadr (list p1 p2)))
maxX (apply 'max (mapcar 'car (list p1 p2)))
maxY (apply 'max (mapcar 'cadr (list p1 p2)))
)
(grvecs (list 1
(list minx miny)
(list maxx miny)
1
(list maxx miny)
(list maxx maxy)
1
(list maxx maxy)
(list minx maxy)
1
(list minx maxy)
(list minx miny)
)
)
(INSERT_with ss ss nil)
)
(setvar "CMDECHO" cmd)
(command "._undo" "_end")
(princ)
)
429014673 发表于 2015-6-10 09:44 static/image/common/back.gif
交点布块，论坛里很多，带方向性的交点布块更有意思。
方向性的才是更合理的
感谢分享
谢谢孤行前辈分享源码，你是结构的吗？
看图速度超快.
感谢！继续支持！
lucas_3333 发表于 2015-6-10 08:08 static/image/common/back.gif
这是在画太阳啊
是在画菊花
smartstar 发表于 2015-6-10 09:35 static/image/common/back.gif
插入用“vla-insertblock”是不是更快一点呢？
好的，我再优化下。