没啥用！

cq4920

感觉没啥用！但修改一下 也许能用上！直接删除有点可惜！需要的自己下载修改吧！
有啥疑问，就不要问我了自行查询吧！

lee50310

換成這個 ，是否感覺效果不一樣?  如圖

1. ;;
   
2. (defun c:grd ( / massoclst pol1 pol2 bl lst1 lst2 lil p gr pp v lst2n )
   
3. 
   
4.   (defun massoclst ( key lst )
   
5.     (if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
   
6.   )
   
7. 
   
8.   (setq pol1 (car (entsel "\n选择LWPOLYLINE ...")))
   
9.   (setq pol2 (entmakex (vl-remove-if (function (lambda ( x ) (vl-position (car x) '(-1 5 330)))) (entget pol1))))
   
10.   (setq bl (massoclst 42 (entget pol2)))
    
11.   (setq lst1 (mapcar 'cdr (massoclst 10 (entget pol1))))
    
12.   (setq lst2 (mapcar 'cdr (massoclst 10 (entget pol2))))
    
13.   (mapcar (function (lambda ( a b ) (setq lil (cons (entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b))) lil)))) lst1 lst2)
    
14.   (setq lil (reverse lil))
    
15.   (setq p (getpoint "\n选择指定点 "))
    
16.   (prompt "\n移动鼠标并按 \"+\" or \"-\" 比例放大縮小键和 \"4\" or \"6\" 旋转...完成鼠标左键单击...")
    
17.   (while (/= 3 (car (setq gr (grread t))))
    
18.     (cond
    
19.       ( (and (= 2 (car gr)) (= 43 (cadr gr)))
    
20.         (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ pp (mapcar '* (mapcar '- x pp) (list (sqrt 2.0) (sqrt 2.0)))))) lst2n))
    
21.       )
    
22.       ( (and (= 2 (car gr)) (= 45 (cadr gr)))
    
23.         (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ pp (mapcar '* (mapcar '- x pp) (list (/ (sqrt 2.0) 2.0) (/ (sqrt 2.0) 2.0)))))) lst2n))
    
24.       )
    
25.       ( (and (= 2 (car gr)) (= 52 (cadr gr)))
    
26.         (setq lst2n (mapcar (function (lambda ( x ) (polar pp (+ (angle pp x) (/ pi 4.0)) (distance pp x)))) lst2n))
    
27.       )
    
28.       ( (and (= 2 (car gr)) (= 54 (cadr gr)))
    
29.         (setq lst2n (mapcar (function (lambda ( x ) (polar pp (- (angle pp x) (/ pi 4.0)) (distance pp x)))) lst2n))
    
30.       )
    
31.       ( t
    
32.         (if (null pp)
    
33.           (setq pp (cadr gr))
    
34.         )
    
35.         (setq v (mapcar '- pp p))
    
36.         (if (null lst2n)
    
37.           (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ v x))) lst2))
    
38.           (progn
    
39.             (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ (mapcar '- (cadr gr) pp) x))) lst2n))
    
40.             (setq pp (cadr gr))
    
41.           )
    
42.         )
    
43.       )
    
44.     )
    
45.     (entmod (append (vl-remove-if (function (lambda ( x ) (vl-position (car x) '(10 42)))) (entget pol2)) (apply 'append (mapcar (function (lambda ( a b ) (list (cons 10 a) b))) lst2n bl))))
    
46.     (mapcar (function (lambda ( a x ) (entmod (subst (cons 11 a) (assoc 11 (entget x)) (entget x))))) lst2n lil)
    
47.     (redraw)
    
48.   )
    
49.   (princ)
    
50. )
    

;;<br /> (defun c:grd ( / massoclst pol1 pol2 bl lst1 lst2 lil p gr pp v lst2n )<br /> <br />   (defun massoclst ( key lst )<br />     (if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))<br />   )<br /> <br />   (setq pol1 (car (entsel "\n选择LWPOLYLINE ...")))<br />   (setq pol2 (entmakex (vl-remove-if (function (lambda ( x ) (vl-position (car x) '(-1 5 330)))) (entget pol1))))<br />   (setq bl (massoclst 42 (entget pol2)))<br />   (setq lst1 (mapcar 'cdr (massoclst 10 (entget pol1))))<br />   (setq lst2 (mapcar 'cdr (massoclst 10 (entget pol2))))<br />   (mapcar (function (lambda ( a b ) (setq lil (cons (entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b))) lil)))) lst1 lst2)<br />   (setq lil (reverse lil))<br />   (setq p (getpoint "\n选择指定点 "))<br />   (prompt "\n移动鼠标并按 \"+\" or \"-\" 比例放大縮小键和 \"4\" or \"6\" 旋转...完成鼠标左键单击...")<br />   (while (/= 3 (car (setq gr (grread t))))<br />     (cond<br />       ( (and (= 2 (car gr)) (= 43 (cadr gr)))<br />         (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ pp (mapcar '* (mapcar '- x pp) (list (sqrt 2.0) (sqrt 2.0)))))) lst2n))<br />       )<br />       ( (and (= 2 (car gr)) (= 45 (cadr gr)))<br />         (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ pp (mapcar '* (mapcar '- x pp) (list (/ (sqrt 2.0) 2.0) (/ (sqrt 2.0) 2.0)))))) lst2n))<br />       )<br />       ( (and (= 2 (car gr)) (= 52 (cadr gr)))<br />         (setq lst2n (mapcar (function (lambda ( x ) (polar pp (+ (angle pp x) (/ pi 4.0)) (distance pp x)))) lst2n))<br />       )<br />       ( (and (= 2 (car gr)) (= 54 (cadr gr)))<br />         (setq lst2n (mapcar (function (lambda ( x ) (polar pp (- (angle pp x) (/ pi 4.0)) (distance pp x)))) lst2n))<br />       )<br />       ( t<br />         (if (null pp)<br />           (setq pp (cadr gr))<br />         )<br />         (setq v (mapcar '- pp p))<br />         (if (null lst2n)<br />           (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ v x))) lst2))<br />           (progn<br />             (setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ (mapcar '- (cadr gr) pp) x))) lst2n))<br />             (setq pp (cadr gr))<br />           )<br />         )<br />       )<br />     )<br />     (entmod (append (vl-remove-if (function (lambda ( x ) (vl-position (car x) '(10 42)))) (entget pol2)) (apply 'append (mapcar (function (lambda ( a b ) (list (cons 10 a) b))) lst2n bl))))<br />     (mapcar (function (lambda ( a x ) (entmod (subst (cons 11 a) (assoc 11 (entget x)) (entget x))))) lst2n lil)<br />     (redraw)<br />   )<br />   (princ)<br /> )<br />

lee50310

pengfei2010 发表于 2020-4-2 14:13
你这个平面生成立面是根据什么规则生成的呀，我看了好几遍都没有看明白！

使用 grread函数 去抓滑鼠及鍵盤
這裡有介紹:
http://bbs.mjtd.com/thread-91191-1-1.html

cq4920

墨雨尘峰 发表于 2020-3-30 22:48
好东西啊，但是我这边有 错误: no function definition: XJTC

删除（xjtc）再把需要的图层名都改成你用的图层或者都改成 0 层

墨雨尘峰

好东西啊，但是我这边有 错误: no function definition: XJTC

zjlai521

东西不错 可惜  权限不够

QQ873240166

还不可以看  再回帖

hhh454

画装饰施工图可以用到，

pengfei2010

你这个平面生成立面是根据什么规则生成的呀，我看了好几遍都没有看明白！

pengfei2010

lee50310 发表于 2020-4-2 17:43
使用 grread函数 去抓滑鼠及鍵盤
這裡有介紹:
http://bbs.mjtd.com/thread-91191-1-1.html

不知道有啥用处