求线组合成块（采用格式刷那种样子）

flytoday

哪位高手弄下啊谢谢~~~~
我找的无名块源码。

byghbcx

再试试

2. (defun c:tt( / ss n en dxfcod pt ss1)
   
3.   (defun ptrlist ( pt r / rlist n)
   
4.   (setq rlist nil n 0)
   
5.   (repeat 30
   
6.     (setq rlist (cons (polar pt (* 12 n (/ pi 180)) r) rlist))
   
7.     (setq n (1+ n))
   
8.     )
   
9.   rlist
   
10.   )
    
11.   (defun blk (ss pt / ss pt doc space objs idx blkobj sArray);无名块
    
12.    (vl-load-com)
    
13.    (setq doc (vla-get-activedocument (vlax-get-acad-object))
    
14.          space (if (= (vla-get-activespace doc) 1)
    
15.                        (vla-get-ModelSpace doc)
    
16.                        (vla-get-PaperSpace doc))
    
17.          idx     -1)
    
18.    (repeat (sslength ss)
    
19.        (setq objs (cons (vlax-ename->vla-object (ssname ss (setq idx (1+ idx))))
    
20.                                          objs))
    
21.        )
    
22.    (mapcar '(lambda (e) (vla-move e (vlax-3d-point pt) (vlax-3d-point '(0 0 0)))) objs)
    
23.    (setq blkobj (vla-add (vla-get-blocks doc) (vlax-3d-point '(0 0 0)) "*U"))
    
24.    (setq sArray (vlax-safearray-fill (vlax-make-safearray  vlax-vbObject  (cons 0 (1- (length objs))))
    
25.                                  objs))
    
26.    (vla-copyobjects doc sArray blkobj)
    
27.    (mapcar 'vla-delete objs)
    
28.    (vla-insertblock space (vlax-3d-point pt) (vla-get-name blkobj) 1 1 1 0)
    
29.    (mapcar 'vlax-release-object (list doc space blkobj))
    
30.    (princ)
    
31.    )
    
32.   (setq oldvar (mapcar 'getvar '("cmdecho" "osmode")))
    
33.   (mapcar 'setvar '("cmdecho" "osmode") '(0 0 2))
    
34.   (if (not (and
    
35.   (= (getvar "ucsname") "")
    
36.   (equal '(0.0 0.0 0.0) (getvar"ucsorg"))
    
37.   (equal '(1.0 0.0 0.0) (getvar"ucsxdir"))
    
38.   (equal '(0.0 1.0 0.0) (getvar"ucsydir"))
    
39.   ))
    
40.   (progn (command "_.ucs" "w") (command "_.zoom" "p"))
    
41.   )
    
42.   (setq ss (ssget '((0 . "CIRCLE,ELLIPSE"))) n 0)
    
43.   (if ss
    
44.   (repeat (sslength ss)
    
45.     (setq en (ssname ss n))
    
46.     (setq dxfcod (entget en))
    
47.     (setq pt (cdr (assoc 10 dxfcod)))
    
48.     (cond
    
49.       ((= "CIRCLE" (cdr (assoc 0 dxfcod))) (setq r (cdr (assoc 40 dxfcod))))
    
50.       ((= "ELLIPSE" (cdr (assoc 0 dxfcod))) (setq r (distance '(0 0 0) (cdr (assoc 11 dxfcod)))))
    
51.       )
    
52.     (setq ptlist (ptrlist pt r))
    
53.     (setq ss1 (ssget "_wp" ptlist))
    
54.     (if ss1 (progn (ssadd en ss1) (blk ss1 pt)))
    
55.     (setq n (1+ n))
    
56.     )
    
57.     )
    
58.   (mapcar 'setvar '("cmdecho" "osmode") oldvar)
    
59.   (princ)
    
60.   )

(defun c:tt( / ss n en dxfcod pt ss1)<br />   (defun ptrlist ( pt r / rlist n)<br />   (setq rlist nil n 0)<br />   (repeat 30<br />     (setq rlist (cons (polar pt (* 12 n (/ pi 180)) r) rlist))<br />     (setq n (1+ n))<br />     )<br />   rlist<br />   )<br />   (defun blk (ss pt / ss pt doc space objs idx blkobj sArray);无名块<br />    (vl-load-com)<br />    (setq doc (vla-get-activedocument (vlax-get-acad-object))<br />          space (if (= (vla-get-activespace doc) 1)<br />                        (vla-get-ModelSpace doc)<br />                        (vla-get-PaperSpace doc))<br />          idx     -1)<br />    (repeat (sslength ss)<br />        (setq objs (cons (vlax-ename->vla-object (ssname ss (setq idx (1+ idx))))<br />                                          objs))<br />        )<br />    (mapcar '(lambda (e) (vla-move e (vlax-3d-point pt) (vlax-3d-point '(0 0 0)))) objs)<br />    (setq blkobj (vla-add (vla-get-blocks doc) (vlax-3d-point '(0 0 0)) "*U"))<br />    (setq sArray (vlax-safearray-fill (vlax-make-safearray  vlax-vbObject  (cons 0 (1- (length objs))))<br />                                  objs))<br />    (vla-copyobjects doc sArray blkobj)<br />    (mapcar 'vla-delete objs)<br />    (vla-insertblock space (vlax-3d-point pt) (vla-get-name blkobj) 1 1 1 0)<br />    (mapcar 'vlax-release-object (list doc space blkobj))<br />    (princ)<br />    )<br />   (setq oldvar (mapcar 'getvar '("cmdecho" "osmode")))<br />   (mapcar 'setvar '("cmdecho" "osmode") '(0 0 2))<br />   (if (not (and <br />   (= (getvar "ucsname") "")<br />   (equal '(0.0 0.0 0.0) (getvar"ucsorg"))<br />   (equal '(1.0 0.0 0.0) (getvar"ucsxdir"))<br />   (equal '(0.0 1.0 0.0) (getvar"ucsydir"))<br />   ))<br />   (progn (command "_.ucs" "w") (command "_.zoom" "p"))<br />   )<br />   (setq ss (ssget '((0 . "CIRCLE,ELLIPSE"))) n 0)<br />   (if ss<br />   (repeat (sslength ss)<br />     (setq en (ssname ss n))<br />     (setq dxfcod (entget en))<br />     (setq pt (cdr (assoc 10 dxfcod)))<br />     (cond<br />       ((= "CIRCLE" (cdr (assoc 0 dxfcod))) (setq r (cdr (assoc 40 dxfcod))))<br />       ((= "ELLIPSE" (cdr (assoc 0 dxfcod))) (setq r (distance '(0 0 0) (cdr (assoc 11 dxfcod)))))<br />       )<br />     (setq ptlist (ptrlist pt r))<br />     (setq ss1 (ssget "_wp" ptlist))<br />     (if ss1 (progn (ssadd en ss1) (blk ss1 pt)))<br />     (setq n (1+ n))<br />     )<br />     )<br />   (mapcar 'setvar '("cmdecho" "osmode") oldvar)<br />   (princ)<br />   )

longer1000

帮顶一个！！！！！！！！！！！！！！！！！

yjr111

思路？
1、找到相交直线，并以交点作为块插入点
2、根据交点找到最近的园
3、把园和直线组合做块

flytoday

严哥谢谢捧场。思路嘛我也不会哈

我觉滴你这路太针对性了哈，，，会不会有点不通用哈，，

最好是能指定线、多义线，闭合的线。随意能组合成块最好哈

flytoday

那个无名块要一条线一条线滴选择啊。我要框选下，一下子几个组合一起啊，，谢谢高手给弄下啊谢谢

flytoday

哦这处没想到哈。。我认得电脑不认得哈，。老大帮帮忙哈

狂刀lxx

理论上是可以编出这样的程序的，实际是我的时间不允许，等有空再帮你研究下了

2553306039

看来很难哈

byghbcx

这个试试看，这图里全是椭圆呀，不过长轴与短轴相同，可以当园来用。

2. (defun c:tt( / ss n en dxfcod pt ss1)
   
3.   (defun ptrlist ( pt r / rlist n)
   
4.   (setq rlist nil n 0)
   
5.   (repeat 30
   
6.     (setq rlist (cons (polar pt (* 12 n (/ pi 180)) r) rlist))
   
7.     (setq n (1+ n))
   
8.     )
   
9.   rlist
   
10.   )
    
11.   (defun blk (ss pt / ss pt doc space objs idx blkobj sArray);无名块
    
12.    (vl-load-com)
    
13.    (setq doc (vla-get-activedocument (vlax-get-acad-object))
    
14.          space (if (= (vla-get-activespace doc) 1)
    
15.                        (vla-get-ModelSpace doc)
    
16.                        (vla-get-PaperSpace doc))
    
17.          idx     -1)
    
18.    (repeat (sslength ss)
    
19.        (setq objs (cons (vlax-ename->vla-object (ssname ss (setq idx (1+ idx))))
    
20.                                          objs))
    
21.        )
    
22.    (mapcar '(lambda (e) (vla-move e (vlax-3d-point pt) (vlax-3d-point '(0 0 0)))) objs)
    
23.    (setq blkobj (vla-add (vla-get-blocks doc) (vlax-3d-point '(0 0 0)) "*U"))
    
24.    (setq sArray (vlax-safearray-fill (vlax-make-safearray  vlax-vbObject  (cons 0 (1- (length objs))))
    
25.                                  objs))
    
26.    (vla-copyobjects doc sArray blkobj)
    
27.    (mapcar 'vla-delete objs)
    
28.    (vla-insertblock space (vlax-3d-point pt) (vla-get-name blkobj) 1 1 1 0)
    
29.    (mapcar 'vlax-release-object (list doc space blkobj))
    
30.    (princ)
    
31.    )
    
32.   (command "_.ucs" "w")
    
33.   (command "_.zoom" "p")
    
34.   (setq ss (ssget '((0 . "CIRCLE,ELLIPSE"))) n 0)
    
35.   (if ss
    
36.   (repeat (sslength ss)
    
37.     (setq en (ssname ss n))
    
38.     (setq dxfcod (entget en))
    
39.     (setq pt (cdr (assoc 10 dxfcod)))
    
40.     (cond
    
41.       ((= "CIRCLE" (cdr (assoc 0 dxfcod))) (setq r (cdr (assoc 40 dxfcod))))
    
42.       ((= "ELLIPSE" (cdr (assoc 0 dxfcod))) (setq r (distance '(0 0 0) (cdr (assoc 11 dxfcod)))))
    
43.       )
    
44.     (setq ptlist (ptrlist pt r))
    
45.     (setq ss1 (ssget "_wp" ptlist))
    
46.     (ssadd en ss1)
    
47.     (blk ss1 pt)
    
48.     (setq n (1+ n))
    
49.     )
    
50.     )
    
51.   )

(defun c:tt( / ss n en dxfcod pt ss1)<br />   (defun ptrlist ( pt r / rlist n)<br />   (setq rlist nil n 0)<br />   (repeat 30<br />     (setq rlist (cons (polar pt (* 12 n (/ pi 180)) r) rlist))<br />     (setq n (1+ n))<br />     )<br />   rlist<br />   )<br />   (defun blk (ss pt / ss pt doc space objs idx blkobj sArray);无名块<br />    (vl-load-com)<br />    (setq doc (vla-get-activedocument (vlax-get-acad-object))<br />          space (if (= (vla-get-activespace doc) 1)<br />                        (vla-get-ModelSpace doc)<br />                        (vla-get-PaperSpace doc))<br />          idx     -1)<br />    (repeat (sslength ss)<br />        (setq objs (cons (vlax-ename->vla-object (ssname ss (setq idx (1+ idx))))<br />                                          objs))<br />        )<br />    (mapcar '(lambda (e) (vla-move e (vlax-3d-point pt) (vlax-3d-point '(0 0 0)))) objs)<br />    (setq blkobj (vla-add (vla-get-blocks doc) (vlax-3d-point '(0 0 0)) "*U"))<br />    (setq sArray (vlax-safearray-fill (vlax-make-safearray  vlax-vbObject  (cons 0 (1- (length objs))))<br />                                  objs))<br />    (vla-copyobjects doc sArray blkobj)<br />    (mapcar 'vla-delete objs)<br />    (vla-insertblock space (vlax-3d-point pt) (vla-get-name blkobj) 1 1 1 0)<br />    (mapcar 'vlax-release-object (list doc space blkobj))<br />    (princ)<br />    )<br />   (command "_.ucs" "w")<br />   (command "_.zoom" "p")<br />   (setq ss (ssget '((0 . "CIRCLE,ELLIPSE"))) n 0)<br />   (if ss<br />   (repeat (sslength ss)<br />     (setq en (ssname ss n))<br />     (setq dxfcod (entget en))<br />     (setq pt (cdr (assoc 10 dxfcod)))<br />     (cond<br />       ((= "CIRCLE" (cdr (assoc 0 dxfcod))) (setq r (cdr (assoc 40 dxfcod))))<br />       ((= "ELLIPSE" (cdr (assoc 0 dxfcod))) (setq r (distance '(0 0 0) (cdr (assoc 11 dxfcod)))))<br />       )<br />     (setq ptlist (ptrlist pt r))<br />     (setq ss1 (ssget "_wp" ptlist))<br />     (ssadd en ss1)<br />     (blk ss1 pt)<br />     (setq n (1+ n))<br />     )<br />     )<br />   )