镶件外形生成

chenjian1

;;;镶件外形生成 Command:WX
;;;2005-10-11     Chen Jian
;;;Version 1.1    add (C:GETBOX)
;;;2005-07-01     Chen Jian
;;;Version 1.0
;;;MADE IN CHINA
(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) 5.5))
      (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) 5.5))
      (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)
)
;;;********************************************************************1
;;;取得s最小包围框 Command:GetBox
;;;Return minpoint maxpoint des-GetBox-top-pt1 des-GetBox-bottom-pt2
;;;       des-GetBox-left-pt3 des-GetBox-right-pt4 des-GetBox-midpt
;;;2005-10-11     Chen Jian
;;;Version 1.0
;;;MADE IN CHINA
(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")
)
;;;DES:ChenJian
;;;E-mail:ChenJianCaiHong@163.com

chenjian1