求助，改为可框选的最大外形，现在只有单选多义线的最大外形。

努力活着

求助，改为可框选的最大外形，现在只有单选多义线的最大外形。
请高手，帮忙看看吧，太感谢了

;;;;;;;;;;;; X016 最大外形（镶件外形）-WX
(defun c:WX (/            pt1           pt2          pt3         pt4        Y1     Y2     midY
             lineY  newY1  newY2  X1         X2        midX   lineX  newX1
             newX2  newpt1 newpt2 newpt3 newpt4
            )
  (setvar "cmdecho" 0)
  (command "undo" "be")
  (C:GETBOX)
  (if (= des-GetBox-OK 1)
    (progn
      (setq pt1 des-GetBox-top-pt1)
      (setq pt2 des-GetBox-bottom-pt2)
      (setq pt3 des-GetBox-left-pt3)
      (setq pt4 des-GetBox-right-pt4)
      (setq Y1 (cadr pt1))
      (setq Y2 (cadr pt2))
      (setq midY (/ (+ Y1 Y2) 2.0))        ;中点Y坐标
      (setq lineY (+ (/ (fix (abs (- Y1 Y2))) 2.0) 4));外偏大距离4MM
      (setq newY1 (+ midY lineY))
      (setq newY2 (- midY lineY))
      (setq X1 (car pt3))
      (setq X2 (car pt4))
      (setq midX (/ (+ X1 X2) 2.0))        ;中点X坐标
      (setq lineX (+ (/ (fix (abs (- X2 X1))) 2.0) 4));外偏大距离4MM
      (setq newX1 (- midX lineX))
      (setq newX2 (+ midX lineX))
      (setq newpt1 (list newX1 newY1))
      (setq newpt2 (list newX2 newY1))
      (setq newpt3 (list newX2 newY2))
      (setq newpt4 (list newX1 newY2))
      (setq os (getvar "osmode"))
      (setvar "osmode" 0)
      (setq oldcolor (getvar "CECOLOR"))
      (setvar "CECOLOR" "3")
      (command "PLINE" newpt1 newpt2 newpt3 newpt4 "c")
      (setvar "CECOLOR" oldcolor)
      (setvar "osmode" os)
      (command "undo" "e")
    )
    (Princ "\n------无对象?!")
  )
  (Princ "\n-----------Bye c:WX 镶件外形生成------------")
  (prin1)
)
(defun c:GetBox        (/ des-GetBox-en1    ename-name
                 vlaobject-ename-name
                )
  (setq des-GetBox-en1 nil)
  (setq des-GetBox-OK nil)
  (setq des-GetBox-en1 (entsel "\n选取图形... "))
  (vl-load-com)
  (while des-GetBox-en1
;;;当en1存在时，做以下内容，直到en1不存在为止
    (sub-GetBoundingBox des-GetBox-en1)
    (setq des-GetBox-en1 nil)
  )
  (prin1)
)
(defun sub-GetBoundingBox (des-GetBox-en1)
;;;  (command "ucs" "w")
  (setq ename-name (car des-GetBox-en1))
  (setq        vlaobject-ename-name
         (vlax-ename->vla-object ename-name)
  )
  (vla-GetBoundingBox
    vlaobject-ename-name
    'minpoint
    'maxpoint
  )
  (setq minpoint (vlax-safearray->list minpoint))
  (setq maxpoint (vlax-safearray->list maxpoint))
  (setq minpoint(trans minpoint 0 1))      ;转为ucs点
  (setq maxpoint(trans maxpoint 0 1))      ;转为ucs点
  (setq des-GetBox-top-pt1 maxpoint)
  (setq des-GetBox-bottom-pt2 minpoint)
  (setq des-GetBox-left-pt3 minpoint)
  (setq des-GetBox-right-pt4 maxpoint)
  (setq des-GetBox-midpt (polar minpoint
         (angle minpoint maxpoint)
         (/(distance minpoint maxpoint) 2.0)
         ))
  (setq des-GetBox-OK 1)
  (princ "\nReturn-BoundingBox-ok")
)

努力活着

;;;Highflybird  2008.03.22 海南
;;;本着开源的精神，此代码可以免费拷贝复制。
;;;免责申明：使用此程序带来的一切责任由使用这承担。
(vl-load-com)
;;;主程序
(defun c:wwx (/  i    xdir    ydir    zdir    origin  wcsOrg  UcsFlag
               matLst  matrix  revMat  sel     ent     obj     minPt
               maxPt   minLs   maxLs   maxX    maxY    minX    minY
              )
  ;;先判断UCS是否与WCS相同。如是则取得UCS的X方向，
  ;;Y方向，Z方向，UCS原点及WCS的原点相对UCS的坐标点
  ;;然后得到UCS变换矩阵和到WCS的逆变换矩阵
  (setq UcsFlag (getvar "WORLDUCS"))                           
  (if (= UcsFlag 0)                                               ;UCS是否与WCS相同
    (setq UcsFlag T                                               ;设置标志位为true
          xdir          (getvar "UCSXDIR")                              ;X方向矢量
          ydir          (getvar "UCSYDIR")                              ;Y方向矢量
          zdir          (G:CrossProductor xdir ydir)                    ;X和Y的方向矢量的叉积
          origin  (getvar "UCSORG")                               ;原点
          WcsOrg  (trans '(0 0 0) 0 1)                            ;WCS的原点相对UCS的坐标
          matLst  (list xdir ydir zdir)                           ;旋转的变换矩阵表
          matrix  (GetMatrix matLst origin nil)                   ;从WCS到UCS的变换矩阵
          revMat  (GetMatrix matLst WcsOrg T)                     ;从UCS到WCS的变换矩阵
    )
    (setq UcsFlag nil)                                            ;否则不予变换
  )

  ;;在UCS下先变换物体到WCS下，取得每个物体的包围框，
  ;;求出包围框集合的最小XY，最大XY，并用矩形框画出来
  ;;然后把物体变换回到UCS，并把矩形也变换回去
  (if (setq sel (ssget))                                          ;;选择物体
    (progn
      (setq i 0)                                             
      (setq minPt (vlax-make-safearray vlax-vbdouble '(0 . 2)))   ;左下角点
      (setq maxPt (vlax-make-safearray vlax-vbdouble '(0 . 2)))   ;右上角点
      (repeat (sslength sel)
        (setq ent (ssname sel i))                                 ;图元
        (setq obj (vlax-ename->vla-object ent))                   ;obj对象
        (and UcsFlag (vla-TransformBy obj revMat))                ;反变换到WCS
        (vla-GetBoundingBox obj 'minpt 'maxpt)                    ;得到包围框
        (setq minPt (vlax-safearray->list minPt))
        (setq maxPt (vlax-safearray->list maxPt))
        (setq minLs (cons minPt minLs))                           ;得到左下角点表
        (setq maxLs (cons maxPt maxLs))                           ;得到右上角点表
        (and UcsFlag (vla-TransformBy obj matrix))                ;变换回到UCS
        (setq i (1+ i))                                         
      )
      (setq minX (apply 'min (mapcar 'car  minLs)))               ;最小点集的最小X
      (setq minY (apply 'min (mapcar 'cadr minLs)))               ;最小点集的最小Y
      (setq maxX (apply 'max (mapcar 'car  maxLs)))               ;最大点集的最小X
      (setq maxY (apply 'max (mapcar 'cadr maxLs)))               ;最打点集的最小Y
      (and
        (make-Rectange (list minX minY 0) (list maxX maxY 0))     ;构造边框
        UcsFlag                                                   ;如果UCS的话
        (vla-TransformBy
          (vlax-ename->vla-object (entlast)) matrix               ;变换边框到UCS
        )
      )
    )
  )
  (princ)
)

;;;矩阵的变换与逆变换
(defun GetMatrix (lst org Revflag / mat i j)
  (setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3)));初始化一个4X4的矩阵
  (setq i 0)
  (repeat 3
    (vlax-safearray-put-element mat i 3 (nth i org))              ;平移变换
    (setq j 0)
    (repeat 3                                                     
      (if RevFlag
        (vlax-safearray-put-element mat i j (nth j (nth i lst)))  ;角度逆变换
        (vlax-safearray-put-element mat i j (nth i (nth j lst)))  ;角度的变换
      )
      (setq j (1+ j))                                             
    )
    (setq i (1+ i))
  )
  (vlax-safearray-put-element mat 3 3 1)                          
  mat                                                             ;返回矩阵
)
;;;构造矩形
(defun Make-Rectange (pt1 pt2)
  (entmake
    (list
      '(0 . "LWPOLYLINE")                                         ;轻多段线
      '(100 . "AcDbEntity")                              
      '(100 . "AcDbPolyline")
      '(90 . 4)                                                   ;四个顶点
      '(70 . 1)                                                   ;闭合
      (cons 38 (caddr pt1))                                       ;高程
      (cons 10 (list (car pt1) (cadr pt1)))                       ;左下角
      (cons 10 (list (car pt2) (cadr pt1)))                       ;右下角
      (cons 10 (list (car pt2) (cadr pt2)))                       ;右上角
      (cons 10 (list (car pt1) (cadr pt2)))                       ;左上角
      (cons 210 '(0 0 1))                                         ;法线方向
    )
  )
)
;;;两矢量的叉积
(defun G:CrossProductor        (vec1 vec2 / a b c d e f)                 
  (setq a (car   vec1))
  (setq b (cadr  vec1))
  (setq c (caddr vec1))
  (setq d (car   vec2))
  (setq e (cadr  vec2))
  (setq f (caddr vec2))
  (list
    (- (* b f) (* c e))
    (- (* c d) (* a f))
    (- (* a e) (* b d))
  )
)

xyp1964

2. ;; 框选实体最小外边框  伪源码需要e派工具箱(XCAD)的支持
   
3. (defun c:tt ()
   
4.   (if (setq ss (ssget))
   
5.     (xyp-rectang (xyp-get-9pt ss 1) (xyp-get-9pt ss 9))
   
6.   )
   
7.   (princ)
   
8. )

;; 框选实体最小外边框  伪源码需要e派工具箱(XCAD)的支持<br /> (defun c:tt ()<br />   (if (setq ss (ssget))<br />     (xyp-rectang (xyp-get-9pt ss 1) (xyp-get-9pt ss 9))<br />   )<br />   (princ)<br /> )

努力活着

首先感谢这位版主，真是相当热情，，太感谢了，可是，问题还是没有解决到，能不能直接改上面的程序。

努力活着

(defun C:wx()
(vl-load-com)
(command "undo" "be")
(setvar "cmdecho" 0)
(command "ucs" "w")
(princ "\n请选择物体:")
(while(null(setq en (ssget))))
(setq minx0 1e6 miny0 1e6 maxx0 -1e6 maxy0 -1e6)
(setq i 0)
(repeat (sslength en)
  (setq end (ssname en i))
  (setq end_data (entget end))
  (Min_Max)
  (setq i(1+ i))
)
(setq pmin (list minx0 miny0)
       pmax (list maxx0 maxy0))
(command ".rectang" "non" pmin "non" pmax)
(command "undo" "e")
(princ)
)
;;;子程序，求选集是大外形坐标
(defun Min_Max()
(vla-getboundingbox(vlax-ename->vla-object end) 'minp 'maxp)
(setq minp (vlax-safearray->list minp)
       maxp (vlax-safearray->list maxp))
(setq minx (car minp)
       maxx (car maxp)
       miny (cadr minp)
       maxy (cadr maxp))
(if (> minx0 minx) (setq minx0 minx))
(if (> miny0 miny) (setq miny0 miny))
(if (< maxx0 maxx) (setq maxx0 maxx))
(if (< maxy0 maxy) (setq maxy0 maxy))
)

sicky111

能不能框选多义线，然后分别计算出每个多义线的最小包围盒？

xyp1964

sicky111 发表于 2014-3-8 12:10
能不能框选多义线，然后分别计算出每个多义线的最小包围盒？

2. (defun c:tt ()
   
3.   (setq i -1)
   
4.   (if (setq ss (ssget '((0 . "*polyline"))))
   
5.     (while (setq s1 (ssname ss (setq i (1+ i))))
   
6.       (xyp-rectang (xyp-get-9pt s1 1) (xyp-get-9pt s1 9))
   
7.     )
   
8.   )
   
9.   (princ)
   
10. )

(defun c:tt ()<br />   (setq i -1)<br />   (if (setq ss (ssget '((0 . "*polyline"))))<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (xyp-rectang (xyp-get-9pt s1 1) (xyp-get-9pt s1 9))<br />     )<br />   )<br />   (princ)<br /> )

sicky111

xyp1964 发表于 2014-3-8 13:35

尊敬的院长大人，请移尊步到http://bbs.mjtd.com/thread-106846-1-1.html看看，9楼是我提出来的问题。

皇上快溜

xyp1964 发表于 2014-3-8 13:35

版主你好。5楼那个程序，想给它形成的最大外形加个OFFSET命令，不知道从哪里接起来，可以帮我改改吗，谢谢你

2548572928

努力活着 发表于 2013-10-19 19:30
(defun C:wx()
(vl-load-com)
(command "undo" "be")

谢谢楼主的无私分享 好用:P