iCAx开思网

标题: 个人开发-镶件外形生成autolisp [打印本页]

作者: chenjian1 时间: 2005-11-13 19:48
标题: 个人开发-镶件外形生成autolisp
;;;;;;;;;;;;;;;;;;;;;
;;;镶件外形生成 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 编辑 ]

作者: kayin1981 时间: 2005-11-14 09:28
标题: ask
高手：
你的命令WX加载后用不了了（附件），请指点一下：kayin1981@163.com

作者: ADSHENG 时间: 2005-11-14 20:55
對啊.加载不了.期盼摟主做成lisp傳上來.感激!!

作者: chenjian1 时间: 2005-11-14 23:01
标题: 希望可以帮上忙
;;;********************************************************************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")
)

作者: chenjian1 时间: 2005-11-14 23:12
标题: 请有问题传上来，附带声明一份
DES:ChenJian
E-mail:ChenJianCaiHong@163.com
6. 使用此「软件」的目的是提高五金连续模设计效率,减少人为的错误,使用或不使用此「软件」给你带来的任何有形或无形的损失,本人不负任何责任。

[ 本帖最后由 chenjian1 于 2005-11-17 04:55 编辑 ]

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