大佬帮我修改下程序

787116960

论坛下载的程序 功能是生成图元的外框  需要增加功能 让用户自己输入增加矩形偏移量  加大或者缩小生成的框大小  
能不能帮我修改下  新建一个矩形框图层  把生成的矩形框放到新建的图层中去  谢谢大佬
;;;;功能：最大矩形外框
;;;逆流而上的鱼制作
(defun c:多个矩形框 ( / ent p1 p2 obj k ss)
(vl-load-com)
(setvar "OSMODE" 0)
(if (setq ss (ssget ))
(repeat (setq k (sslength ss))
(setq ent (ssname ss (setq k (1- k))))
(setq obj (vlax-ename->vla-object ent))
(vla-getboundingbox obj 'p1 'p2)
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
)
(vl-cmdf "rectang" p1 p2)
)
)
(princ)
)

jun353835273

paulpipi 发表于 2023-7-30 11:40
谢谢大神耐心回复，但测试后发现数据没有改变，小数点后面还是多位小数，有空帮忙看一下，感谢！！

调试下 应该不会

ssyfeng

试试这个效果：

jun353835273

2. ;;;;功能：最大矩形外框
   
3. ;;;逆流而上的鱼制作
   
4. (defun c:多个矩形框 ( / ent p1 p2 obj k ss p11  p22 dis)
   
5. (vl-load-com)
   
6. (setvar "OSMODE" 0)
   
7. (setq dis (getdist "\n输入边框距离:"))
   
8. (if (and dis
   
9.    (setq ss (ssget )))
   
10. (repeat (setq k (sslength ss))
    
11. (setq ent (ssname ss (setq k (1- k))))
    
12. (setq obj (vlax-ename->vla-object ent))
    
13. (vla-getboundingbox obj 'p1 'p2)
    
14. (setq p1 (vlax-safearray->list p1)
    
15.      p2 (vlax-safearray->list p2)
    
16. )
    
17.   
    
18. (setq p11 (mapcar '(lambda(x)  (- x dis) )p1)  )
    
19. (setq p22 (mapcar '(lambda(x)  (+ x dis) )p2)  )
    
20. (vl-cmdf "rectang" p11 p22)
    
21. )
    
22. )
    
23. (princ)
    
24. )

;;;;功能：最大矩形外框<br /> ;;;逆流而上的鱼制作<br /> (defun c:多个矩形框 ( / ent p1 p2 obj k ss p11  p22 dis)<br /> (vl-load-com)<br /> (setvar "OSMODE" 0)<br /> (setq dis (getdist "\n输入边框距离:"))<br /> (if (and dis<br />    (setq ss (ssget )))<br /> (repeat (setq k (sslength ss))<br /> (setq ent (ssname ss (setq k (1- k))))<br /> (setq obj (vlax-ename->vla-object ent))<br /> (vla-getboundingbox obj 'p1 'p2)<br /> (setq p1 (vlax-safearray->list p1)<br />      p2 (vlax-safearray->list p2)<br /> )<br />   <br /> (setq p11 (mapcar '(lambda(x)  (- x dis) )p1)  )<br /> (setq p22 (mapcar '(lambda(x)  (+ x dis) )p2)  )<br /> (vl-cmdf "rectang" p11 p22)<br /> )<br /> )<br /> (princ)<br /> )

787116960

jun353835273 发表于 2023-7-27 12:59

大佬 能不能帮我修改下  新建一个矩形框图层  把生成的矩形框放到新建的图层中去  谢谢大佬

787116960

ssyfeng 发表于 2023-7-27 14:56
试试这个效果：

老哥  我没有名金币

ssyfeng

给论坛做点贡献，买些就好了，太容易得到的东西都不太珍惜。

bai2000

不错，能分堆在画框最好了

jun353835273

787116960 发表于 2023-7-27 13:45
大佬 能不能帮我修改下  新建一个矩形框图层  把生成的矩形框放到新建的图层中去  谢谢大佬

2. ;;;;功能：最大矩形外框
   
3. ;;;逆流而上的鱼制作
   
4. (defun c:att ( / ent p1 p2 obj k ss p11  p22 dis)
   
5. (vl-load-com)
   
6. (setvar "OSMODE" 0)
   
7. (setq dis (getdist "\n输入边框距离:"))
   
8. (if (and dis
   
9.    (setq ss (ssget )))
   
10. (repeat (setq k (sslength ss))
    
11. (setq ent (ssname ss (setq k (1- k))))
    
12. (setq obj (vlax-ename->vla-object ent))
    
13. (vla-getboundingbox obj 'p1 'p2)
    
14. (setq p1 (vlax-safearray->list p1)
    
15.      p2 (vlax-safearray->list p2)
    
16. )
    
17.   
    
18. (setq p11 (mapcar '(lambda(x)  (- x dis) )p1)  )
    
19. (setq p22 (mapcar '(lambda(x)  (+ x dis) )p2)  )
    
20. (Make-Rectange  p11 p22)
    
21. )
    
22. )
    
23. (princ)
    
24. )
    
25. (defun Make-Rectange (pt1 pt2)
    
26.   (entmake
    
27.     (list
    
28.       '(0 . "LWPOLYLINE")                                         
    
29.       '(100 . "AcDbEntity")                              
    
30.       '(100 . "AcDbPolyline")
    
31.       '(90 . 4)                                                  
    
32.       '(70 . 1)                                                   
    
33.       (cons 8 "new-rectang")
    
34.       (cons 62 1)                          
    
35.       (cons 10 (list (car pt1) (cadr pt1)))                     
    
36.       (cons 10 (list (car pt2) (cadr pt1)))                     
    
37.       (cons 10 (list (car pt2) (cadr pt2)))                  
    
38.       (cons 10 (list (car pt1) (cadr pt2)))                     
    
39.       (cons 210 '(0 0 1))                                       
    
40.     )
    
41.   )
    
42. )

;;;;功能：最大矩形外框<br /> ;;;逆流而上的鱼制作<br /> (defun c:att ( / ent p1 p2 obj k ss p11  p22 dis)<br /> (vl-load-com)<br /> (setvar "OSMODE" 0)<br /> (setq dis (getdist "\n输入边框距离:"))<br /> (if (and dis<br />    (setq ss (ssget )))<br /> (repeat (setq k (sslength ss))<br /> (setq ent (ssname ss (setq k (1- k))))<br /> (setq obj (vlax-ename->vla-object ent))<br /> (vla-getboundingbox obj 'p1 'p2)<br /> (setq p1 (vlax-safearray->list p1)<br />      p2 (vlax-safearray->list p2)<br /> )<br />   <br /> (setq p11 (mapcar '(lambda(x)  (- x dis) )p1)  )<br /> (setq p22 (mapcar '(lambda(x)  (+ x dis) )p2)  )<br /> (Make-Rectange  p11 p22)<br /> )<br /> )<br /> (princ)<br /> )<br /> (defun Make-Rectange (pt1 pt2)<br />   (entmake<br />     (list<br />       '(0 . "LWPOLYLINE")                                         <br />       '(100 . "AcDbEntity")                               <br />       '(100 . "AcDbPolyline")<br />       '(90 . 4)                                                  <br />       '(70 . 1)                                                   <br />       (cons 8 "new-rectang")<br />       (cons 62 1)                          <br />       (cons 10 (list (car pt1) (cadr pt1)))                     <br />       (cons 10 (list (car pt2) (cadr pt1)))                     <br />       (cons 10 (list (car pt2) (cadr pt2)))                   <br />       (cons 10 (list (car pt1) (cadr pt2)))                     <br />       (cons 210 '(0 0 1))                                       <br />     )<br />   )<br /> )

xyp1964

787116960 发表于 2023-7-27 14:59
老哥  我没有名金币

1. (defun c:tt ()
   
2.   "最大矩形外框"
   
3.   (if (setq ss (ssget))
   
4.     (progn
   
5.       (setq os (getvar 'osmode)
   
6.             la (getvar 'clayer)
   
7.       )
   
8.       (setq i -1)
   
9.       (setvar "OSMODE" 0)
   
10.       (command "-layer" "m" "1" "c" "1" "" "")
    
11.       (while (setq s1 (ssname ss (setq i (1+ i))))
    
12.         (setq ob (vlax-ename->vla-object s1))
    
13.         (vla-getboundingbox ob 'p1 'p2)
    
14.         (setq p1 (vlax-safearray->list p1)
    
15.               p2 (vlax-safearray->list p2)
    
16.         )
    
17.         (vl-cmdf "rectang" p1 p2)
    
18.       )
    
19.       (setvar 'osmode os)
    
20.       (setvar 'clayer la)
    
21.     )
    
22.   )
    
23.   (princ)
    
24. )

(defun c:tt ()<br />   "最大矩形外框"<br />   (if (setq ss (ssget))<br />     (progn<br />       (setq os (getvar 'osmode)<br />             la (getvar 'clayer)<br />       )<br />       (setq i -1)<br />       (setvar "OSMODE" 0)<br />       (command "-layer" "m" "1" "c" "1" "" "")<br />       (while (setq s1 (ssname ss (setq i (1+ i))))<br />         (setq ob (vlax-ename->vla-object s1))<br />         (vla-getboundingbox ob 'p1 'p2)<br />         (setq p1 (vlax-safearray->list p1)<br />               p2 (vlax-safearray->list p2)<br />         )<br />         (vl-cmdf "rectang" p1 p2)<br />       )<br />       (setvar 'osmode os)<br />       (setvar 'clayer la)<br />     )<br />   )<br />   (princ)<br /> )

jun353835273

1. 再来一个，这样也可以的，直接偏移

复制代码

2. (defun c:att2 ( / doc lay ent p1 p2 obj k ss p11  p22 dis)
   
3. (vl-load-com)
   
4. (if (not (tblsearch "layer" "new"))
   
5. (progn
   
6. (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
   
7. (setq lay (Vla-Add (Vlax-Get doc 'Layers) "new" ))
   
8.    )
   
9. )
   
10. (setvar "OSMODE" 0)
    
11. (setq dis (getdist "\n输入边框距离:"))
    
12. (if (and dis
    
13.    (setq ss (ssget )))
    
14. (repeat (setq k (sslength ss))
    
15. (setq ent (ssname ss (setq k (1- k))))
    
16. (setq obj (vlax-ename->vla-object ent))
    
17. (setq obj2 (vla-offset obj (- 0 dis)))
    
18. (Vla-Put-Layer (CAR (vlax-safearray->list (vlax-variant-value obj2)))  "new" )
    
19. )
    
20. )
    
21. (princ)
    
22. )

(defun c:att2 ( / doc lay ent p1 p2 obj k ss p11  p22 dis)<br /> (vl-load-com)<br /> (if (not (tblsearch "layer" "new"))<br /> (progn<br /> (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))<br /> (setq lay (Vla-Add (Vlax-Get doc 'Layers) "new" ))<br />    )<br /> )<br /> (setvar "OSMODE" 0)<br /> (setq dis (getdist "\n输入边框距离:"))<br /> (if (and dis<br />    (setq ss (ssget )))<br /> (repeat (setq k (sslength ss))<br /> (setq ent (ssname ss (setq k (1- k))))<br /> (setq obj (vlax-ename->vla-object ent))<br /> (setq obj2 (vla-offset obj (- 0 dis)))<br /> (Vla-Put-Layer (CAR (vlax-safearray->list (vlax-variant-value obj2)))  "new" )<br /> )<br /> )<br /> (princ)<br /> )