大佬帮我修改下程序

loveu515

各显神通

小鸟

2. ;论坛下载的程序 功能是生成图元的外框  需要增加功能 让用户自己输入增加矩形偏移量  加大或者缩小生成的框大小  
   
3. ;能不能帮我修改下  新建一个矩形框图层  把生成的矩形框放到新建的图层中去  谢谢大佬
   
4. ;;;;功能：最大矩形外框
   
5. ;;;逆流而上的鱼制作
   
6. (defun c:多个矩形框 (/ ent  p1 p2  obj k ss)
   
7.   (vl-load-com)
   
8.   (setvar "OSMODE" 0)
   
9.   (setq ii (getdist "\n输入边框距离:"))
   
10.   (if (setq ss (ssget))
    
11.     (repeat (setq k (sslength ss))
    
12.       (setq ent (ssname ss (setq k (1- k))))
    
13.       (setq obj (vlax-ename->vla-object ent))
    
14.       (vla-getboundingbox obj 'p1 'p2)
    
15.       (setq p1 (vlax-safearray->list p1)
    
16.       p2 (vlax-safearray->list p2)
    
17.       )
    
18.       (setq p1 (list (-(car p1) ii)(-(cadr p1) ii))
    
19.       p2 (list (+(car p2) ii)(+(cadr p2) ii))
    
20.       )
    
21.       (vl-cmdf "rectang" p1 p2)
    
22.                 (if (= (tblsearch "layer" "矩形框图层") nil)
    
23.         (command "layer" "m" "矩形框图层" "c" "1" "" "")
    
24.       )
    
25.      (command "_chprop" "l" "" "la" "矩形框图层" "");改图层
    
26.     )
    
27.   
    
28. )
    
29.   (princ)
    
30. )
    

;论坛下载的程序 功能是生成图元的外框  需要增加功能 让用户自己输入增加矩形偏移量  加大或者缩小生成的框大小  <br /> ;能不能帮我修改下  新建一个矩形框图层  把生成的矩形框放到新建的图层中去  谢谢大佬<br /> ;;;;功能：最大矩形外框<br /> ;;;逆流而上的鱼制作<br /> (defun c:多个矩形框 (/ ent  p1 p2  obj k ss)<br />   (vl-load-com)<br />   (setvar "OSMODE" 0)<br />   (setq ii (getdist "\n输入边框距离:"))<br />   (if (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 />       (setq p1 (list (-(car p1) ii)(-(cadr p1) ii))<br />       p2 (list (+(car p2) ii)(+(cadr p2) ii))<br />       )<br />       (vl-cmdf "rectang" p1 p2)<br />                 (if (= (tblsearch "layer" "矩形框图层") nil)<br />         (command "layer" "m" "矩形框图层" "c" "1" "" "")<br />       )<br />      (command "_chprop" "l" "" "la" "矩形框图层" "");改图层<br />     )<br />   <br /> )<br />   (princ)<br /> )<br />

xyp1964

1. (defun c:tt ()
   
2.   "最大矩形外框"
   
3.   (or dd (setq dd 100))
   
4.   (setq dd (Udist 7 "" "偏移距离<输入或鼠标直接量取>" dd nil))
   
5.   (if (setq ss (ssget))
   
6.     (progn
   
7.       (xyp-MkLaCo "1" 1)
   
8.       (setq i -1)
   
9.       (while (setq s1 (ssname ss (setq i (1+ i))))
   
10.         (setq s1 (xyp-Rectang (xyp-9pt s1 1) (xyp-9pt s1 9))
    
11.               s1 (xyp-Offset s1 dd t nil t)
    
12.         )
    
13.       )
    
14.     )
    
15.   )
    
16.   (princ)
    
17. )

(defun c:tt ()<br />   "最大矩形外框"<br />   (or dd (setq dd 100))<br />   (setq dd (Udist 7 "" "偏移距离<输入或鼠标直接量取>" dd nil))<br />   (if (setq ss (ssget))<br />     (progn<br />       (xyp-MkLaCo "1" 1)<br />       (setq i -1)<br />       (while (setq s1 (ssname ss (setq i (1+ i))))<br />         (setq s1 (xyp-Rectang (xyp-9pt s1 1) (xyp-9pt s1 9))<br />               s1 (xyp-Offset s1 dd t nil t)<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

mokson

八仙过海呀。。。。

paulpipi

jun353835273 发表于 2023-7-27 18:49

大神的程序挺好用，能把画的矩形边长取整吗？四舍五入保证，如7.5,8,8.5……

jun353835273

paulpipi 发表于 2023-7-28 11:00
大神的程序挺好用，能把画的矩形边长取整吗？四舍五入保证，如7.5,8,8.5……

(atoi (rtos 8.4 2 0))  =8
函数 你自己搞上去试一试

paulpipi

jun353835273 发表于 2023-7-28 12:46
(atoi (rtos 8.4 2 0))  =8
函数 你自己搞上去试一试

谢谢大神回复，是可以取整，但矩形偏位不在正中，而且没有保留一位小数，麻烦指导一下，看怎么修改，感谢！

jun353835273

paulpipi 发表于 2023-7-28 14:06
谢谢大神回复，是可以取整，但矩形偏位不在正中，而且没有保留一位小数，麻烦指导一下，看怎么修改，感谢 ...

取整了怎么保留一位小数，还是只保留1位小数。

paulpipi

jun353835273 发表于 2023-7-28 15:20
取整了怎么保留一位小数，还是只保留1位小数。

就是0.5,1,1.5,2,2.5,3,3.5……就是小数点后面不是0.5就取0.5，如果超过0.5就取整，可能我表达的不清楚，不好意思

jun353835273

paulpipi 发表于 2023-7-28 16:37
就是0.5,1,1.5,2,2.5,3,3.5……就是小数点后面不是0.5就取0.5，如果超过0.5就取整，可能我表达的不清楚， ...

2. ;;;;功能：最大矩形外框
   
3. ;;20230728半途中修改
   
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 dis (fixdata dis))
   
10.    (setq ss (ssget )))
    
11. (repeat (setq k (sslength ss))
    
12. (setq ent (ssname ss (setq k (1- k))))
    
13. (setq obj (vlax-ename->vla-object ent))
    
14. (vla-getboundingbox obj 'p1 'p2)
    
15. (setq p1 (vlax-safearray->list p1)
    
16.      p2 (vlax-safearray->list p2)
    
17. )
    
18.   
    
19. (setq p11 (mapcar '(lambda(x)  (- x dis) )p1)  )
    
20. (setq p22 (mapcar '(lambda(x)  (+ x dis) )p2)  )
    
21. (Make-Rectange  p11 p22)
    
22. )
    
23.   
    
24. )
    
25. (princ)
    
26. )
    
27. ;;;;20230728半途中修改
    
28. ;;数据处理
    
29. (defun fixdata(in / out)
    
30. (setq out (atof (rtos in 2 0 ) ))
    
31. (if (> in  out)
    
32. (setq out (+ (fix in) 0.5))
    
33.   )
    
34. out
    
35. )
    
36. (defun Make-Rectange (pt1 pt2)
    
37.   (entmake
    
38.     (list
    
39.       '(0 . "LWPOLYLINE")                                         
    
40.       '(100 . "AcDbEntity")                              
    
41.       '(100 . "AcDbPolyline")
    
42.       '(90 . 4)                                                  
    
43.       '(70 . 1)                                                   
    
44.       (cons 8 "new-rectang")
    
45.       (cons 62 1)                          
    
46.       (cons 10 (list (car pt1) (cadr pt1)))                     
    
47.       (cons 10 (list (car pt2) (cadr pt1)))                     
    
48.       (cons 10 (list (car pt2) (cadr pt2)))                  
    
49.       (cons 10 (list (car pt1) (cadr pt2)))                     
    
50.       (cons 210 '(0 0 1))                                       
    
51.     )
    
52.   )
    
53. )
    
54. 试一试
    
55. 
    

;;;;功能：最大矩形外框<br /> ;;20230728半途中修改<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 dis (fixdata 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 /> )<br /> (princ)<br /> )<br /> ;;;;20230728半途中修改<br /> ;;数据处理<br /> (defun fixdata(in / out)<br /> (setq out (atof (rtos in 2 0 ) ))<br /> (if (> in  out)<br /> (setq out (+ (fix in) 0.5))<br />   )<br /> out<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 /> )<br /> 试一试<br /> <br />