iCAx开思网

标题: 镶件外形生成 [打印本页]

作者: chenjian1 时间: 2006-1-20 22:45
标题: 镶件外形生成
;;;镶件外形生成 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 时间: 2006-1-23 23:12
不要看此贴了，另一贴最新最全

欢迎光临 iCAx开思网 (https://www.icax.org/)