个人开发-镶件外形生成autolisp

chenjian1 · 发表于 2005-11-13 19:48:10

马上注册，结交更多同行朋友，交流，分享，学习。

您需要登录才可以下载或查看，没有帐号？注册

x

;;;;;;;;;;;;;;;;;;;;;
;;;镶件外形生成 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)
)
如有问题请E-mail:ChenJianCaiHong@163.com

[ 本帖最后由 chenjian1 于 2005-11-13 11:53 编辑 ]