有没有类拟lsp生成一个边界框

licream

请问下有没有类似lsp可以窗选左边的图生成一个边界矩形框.
谢谢。

296715530

Gu_xl 发表于 2012-5-25 17:49

感谢版主
东拼西凑加了记忆功能，和外框指定图层，以及中途退出捕捉恢复



(defun c:wk (/ ss i l1 l2 ll ur os d)
  (defun *MYERR* (MSG)
(setvar "CMDECHO" CMD_OLD)
(setvar "OSMODE" OS_OLD)
(setq *ERROR* *OLDERR*)
(if (= MSG "完美退出。谢谢使用。")
     (princ (strcat "\\n>>>" MSG))
     (princ "\n>>>虽然中途退出了，对象捕捉已经被恢复。")
)
(princ)
    )
    (setq *OLDERR* *ERROR*
   *ERROR*  *MYERR*
   OS_OLD   (getvar "OSMODE")
   CMD_OLD  (getvar "CMDECHO")
    )
(setvar "CMDECHO" 0);_关闭命令提示
(Setq osmode_bak (getvar "osmode"));_记录捕捉
(Setvar "osmode" 0);_关闭捕捉

(if *Scale* (setq d (getreal (strcat  "\n偏距<" (rtos *Scale* 2 2) ">:") ) )  (setq d (getreal  "\n偏

距:")))
(if (null d) (setq d *Scale*) (setq *Scale*  d ))

(setq ss (ssget))
  (repeat (setq i (sslength ss))
    (vla-getboundingbox
      (vlax-ename->vla-object (ssname ss (setq i (1- i))))
      'll
      'ur
    )
    (setq l1 (cons (vlax-safearray->list ll) l1)
          l2 (cons (vlax-safearray->list ur) l2)
    )
  )
  (mapcar 'set
          (list 'll 'ur)
          (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
                  '(min max)
                  (list l1 l2)
          )
  )
  (command
    "rectang"
    (trans (polar ll (* pi 1.25) (setq d (sqrt (+ (* d d) (* d d)))))
           0
           1
    )
    (trans (polar ur (* pi 0.25) d) 0 1)
  )

(command "CHPROP" "L" "" "LA" "_3" "");指定图层
(Setvar "osmode" osmode_bak);_还原捕捉


(setvar "CMDECHO" 1);_打开命令提示


  (princ)
)

tangjunasd58

;【PF工具箱--自动边界盒】
(defun c:bjh (/ ss i l1 l2 ll ur os d)
   (setq os (getvar 'osmode))
   (PRINC "\n【PF工具箱--QQ交流群：214654218】--自动边界盒 ")(PRINC)  
   (setq d (getreal "\n偏距<5>"))
   (if (null d)
     (setq d 5)
   )
   (setq ss (ssget))
   (repeat (setq i (sslength ss))
     (vla-getboundingbox
       (vlax-ename->vla-object (ssname ss (setq i (1- i))))
       'll
       'ur
     )
     (setq l1 (cons (vlax-safearray->list ll) l1)
           l2 (cons (vlax-safearray->list ur) l2)
     )
   )
   (mapcar 'set
           (list 'll 'ur)
           (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
                   '(min max)
                   (list l1 l2)
           )
   )
   (command
     "rectang"
     (trans (polar ll (* pi 1.25) (setq d (sqrt (+ (* d d) (* d d)))))
            0
            1
     )
     (trans (polar ur (* pi 0.25) d) 0 1)
   )
   (setvar 'osmode os)
   (princ)
)

Gu_xl

1. (defun c:tt (/ ss i l1 l2 ll ur os d)
   
2.   (setq os (getvar 'osmode))
   
3.   (setvar 'osmode 0)
   
4.   (setq d (getreal "\n偏距<10>"))
   
5.   (if (null d)
   
6.     (setq d 10)
   
7.   )
   
8.   (setq ss (ssget))
   
9.   (repeat (setq i (sslength ss))
   
10.     (vla-getboundingbox
    
11.       (vlax-ename->vla-object (ssname ss (setq i (1- i))))
    
12.       'll
    
13.       'ur
    
14.     )
    
15.     (setq l1 (cons (vlax-safearray->list ll) l1)
    
16.           l2 (cons (vlax-safearray->list ur) l2)
    
17.     )
    
18.   )
    
19.   (mapcar 'set
    
20.           (list 'll 'ur)
    
21.           (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
    
22.                   '(min max)
    
23.                   (list l1 l2)
    
24.           )
    
25.   )
    
26.   (command
    
27.     "rectang"
    
28.     (trans (polar ll (* pi 1.25) (setq d (sqrt (+ (* d d) (* d d)))))
    
29.            0
    
30.            1
    
31.     )
    
32.     (trans (polar ur (* pi 0.25) d) 0 1)
    
33.   )
    
34.   (setvar 'osmode os)
    
35.   (princ)
    
36. )
    

(defun c:tt (/ ss i l1 l2 ll ur os d)<br />   (setq os (getvar 'osmode))<br />   (setvar 'osmode 0)<br />   (setq d (getreal "\n偏距<10>"))<br />   (if (null d)<br />     (setq d 10)<br />   )<br />   (setq ss (ssget))<br />   (repeat (setq i (sslength ss))<br />     (vla-getboundingbox<br />       (vlax-ename->vla-object (ssname ss (setq i (1- i))))<br />       'll<br />       'ur<br />     )<br />     (setq l1 (cons (vlax-safearray->list ll) l1)<br />           l2 (cons (vlax-safearray->list ur) l2)<br />     )<br />   )<br />   (mapcar 'set<br />           (list 'll 'ur)<br />           (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))<br />                   '(min max)<br />                   (list l1 l2)<br />           )<br />   )<br />   (command<br />     "rectang"<br />     (trans (polar ll (* pi 1.25) (setq d (sqrt (+ (* d d) (* d d)))))<br />            0<br />            1<br />     )<br />     (trans (polar ur (* pi 0.25) d) 0 1)<br />   )<br />   (setvar 'osmode os)<br />   (princ)<br /> )<br />

xyp1964

2. 
   
3. ;; 边界外框 伪源码 需要e派工具箱(XCAD)的支持：http://xyp1964.ys168.com
   
4. (defun c:tt ()
   
5.   (if (setq ss (ssget))
   
6.     (xyp-rectang
   
7.       (xyp-get-Pt2XY (xyp-get-9pt ss 1) -10 -10)
   
8.       (xyp-get-Pt2XY (xyp-get-9pt ss 9) 10 10)
   
9.     )
   
10.   )
    
11.   (princ)
    
12. )
    

<br /> ;; 边界外框 伪源码 需要e派工具箱(XCAD)的支持：http://xyp1964.ys168.com<br /> (defun c:tt ()<br />   (if (setq ss (ssget))<br />     (xyp-rectang<br />       (xyp-get-Pt2XY (xyp-get-9pt ss 1) -10 -10)<br />       (xyp-get-Pt2XY (xyp-get-9pt ss 9) 10 10)<br />     )<br />   )<br />   (princ)<br /> )<br />

qq229918602

版主的很好。。

licream

非常感谢二位楼版主，这问题终于解决了。谢谢你们。

yoyoho

感谢二位楼版主分享程序!

sfzyr

版主的 (mapcar 'set

20.          (list 'll 'ur)
21.          (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
22.                  '(min max)
23.                  (list l1 l2)
24.          )
25.  )

mapcar 用的甚是好啊！

zhuquanmao

感谢版主分享！

yaokui25

这个我一直在找，谢谢

lish

学习！！！！！