沿直线画圆环

非ing · 发表于 2013-6-3 13:11:38

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

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

×

本帖最后由 hai20130408 于 2013-6-3 14:13 编辑

前面发了几篇工作中随手编的lisp程序，程序随便的以至于后来自己都觉得有班门弄斧之嫌，但各位高手的精彩点评，也让自己受益匪浅啊，其一些建议都是考虑到了程序的容错性，简要性。今天我接着抛一块臭泥砖，引各位金玉良言，欢迎各位拍砖。

(setq rcircle 1);;;圆环半径
(setq XX_jl 4);;;直线方向长度
(defun ZX(rcircle XX_jl / acaddocument acadobject application msg mspace os rcircle varlst x xx_angle xx_endpoint
xx_object xx_pt xx_ptcircle xx_ptcirclef xx_ss xx_sscircle xx_startpoint)
setq XX_pt (getpoint "\n输入点"))
(while (not xx_pt)(setq XX_pt (getpoint "\n输入点")) )
(setq os (getvar "osmode"))
(setq varlst (mapcar (function (lambda (x) (list 'setvar x (getvar x))))
'("autosnap" "osmode" "pickbox")));_定义还原变量
(setvar "osmode" 0)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument AcadObject)
Application (vla-get-Application AcadDocument)
mspace (vla-get-ModelSpace AcadDocument)
)
(defun *error* (msg)
(mapcar 'eval varlst)
(if (not (member
msg
'(nil "函数被取消" ";错误:quit / exit abort")
)
)
(princ (strcat ";错误:" msg))
)
)
(setq xx_ss (ssget XX_pt))
(setq xx_object (vlax-ename->vla-object (ssname xx_ss 0)))
(setq xx_startpoint (vlax-curve-getStartPoint xx_object))
(setq xx_endpoint (vlax-curve-getEndPoint xx_object))
;;; (vla-zoomwindow Application (vlax-3d-point xx_startpoint) (vlax-3d-point xx_endpoint))
;;; (command "_delay" 200)
(setq xx_ssdount (ssget))
(setq xx_ptcircle0 (vlax-safearray->list (vlax-variant-value(vlax-get-property (vlax-ename->vla-object (ssname xx_ssdount 0)) 'Coordinate 0))))
(setq xx_ptcircle1 (vlax-safearray->list (vlax-variant-value(vlax-get-property (vlax-ename->vla-object (ssname xx_ssdount 0)) 'Coordinate 1))))
(setq xx_ptcircle (list (/ (+ (car xx_ptcircle0) (car xx_ptcircle1)) 2.0) (/ (+ (cadr xx_ptcircle0) (cadr xx_ptcircle1)) 2.0) 0))
;;; (setq xx_ptcircle (cdr (assoc 10 (entget (ssname xx_ssdount 0)))))
(setq XX_angle (angle xx_ptcircle XX_pt))
(setq xx_ptcirclef (polar xx_ptcircle XX_angle XX_jl))
;;; (vl-cmdf "_circle" xx_ptcirclef rcircle "")
;;; (vla-addcircle mSpace (vlax-3d-point xx_ptcirclef) rcircle)
(vl-cmdf "donut" 0 rcircle xx_ptcirclef "")
(princ "完成")
(*error* nil)
(setvar "osmode" os)
(prin1)
)
(defun c:tt()
(ZX rcircle XX_jl)
)

(setq rcircle 1);;;圆环半径 
(setq XX_jl 4);;;直线方向长度 
(defun ZX(rcircle XX_jl / acaddocument acadobject application msg mspace os rcircle varlst x xx_angle xx_endpoint 
               xx_object xx_pt xx_ptcircle xx_ptcirclef xx_ss xx_sscircle xx_startpoint) 
setq XX_pt (getpoint "\n输入点")) 
(while (not xx_pt)(setq XX_pt (getpoint "\n输入点")) ) 
  (setq os (getvar "osmode")) 
   (setq varlst (mapcar (function (lambda (x) (list 'setvar x (getvar x)))) 
                   '("autosnap" "osmode" "pickbox")));_定义还原变量 
   (setvar "osmode" 0) 
  (setq AcadObject (vlax-get-acad-object) 
        AcadDocument (vla-get-ActiveDocument AcadObject) 
  Application (vla-get-Application AcadDocument) 
  mspace (vla-get-ModelSpace AcadDocument) 
      ) 
  (defun *error* (msg) 
      (mapcar 'eval varlst) 
      (if (not (member 
                msg 
                '(nil "函数被取消" ";错误:quit / exit abort") 
               ) 
          )       
      (princ (strcat ";错误:" msg)) 
      ) 
   ) 
   (setq xx_ss (ssget XX_pt)) 
   (setq xx_object (vlax-ename->vla-object (ssname xx_ss 0))) 
   (setq xx_startpoint (vlax-curve-getStartPoint xx_object)) 
   (setq xx_endpoint (vlax-curve-getEndPoint xx_object)) 
;;;   (vla-zoomwindow Application (vlax-3d-point xx_startpoint) (vlax-3d-point xx_endpoint)) 
;;;   (command "_delay" 200) 
   (setq xx_ssdount (ssget)) 
   (setq xx_ptcircle0 (vlax-safearray->list (vlax-variant-value(vlax-get-property (vlax-ename->vla-object (ssname xx_ssdount 0)) 'Coordinate 0)))) 
   (setq xx_ptcircle1 (vlax-safearray->list (vlax-variant-value(vlax-get-property (vlax-ename->vla-object (ssname xx_ssdount 0)) 'Coordinate 1)))) 
   (setq xx_ptcircle (list (/ (+ (car xx_ptcircle0) (car xx_ptcircle1)) 2.0) (/ (+ (cadr xx_ptcircle0) (cadr xx_ptcircle1)) 2.0) 0)) 
;;;   (setq xx_ptcircle (cdr (assoc 10 (entget (ssname xx_ssdount 0))))) 
   (setq XX_angle (angle xx_ptcircle XX_pt)) 
   (setq xx_ptcirclef (polar xx_ptcircle XX_angle XX_jl)) 
;;;   (vl-cmdf "_circle" xx_ptcirclef rcircle "") 
;;;   (vla-addcircle mSpace (vlax-3d-point xx_ptcirclef) rcircle) 
   (vl-cmdf "donut" 0 rcircle xx_ptcirclef "") 
   (princ "完成") 
   (*error* nil) 
   (setvar "osmode" os) 
   (prin1) 
) 
 
(defun c:tt() 
  (ZX rcircle XX_jl) 
)

eachy · 发表于 2013-6-3 13:21:43

1 看lz用了vla，想必对activex很熟悉，画圆环用vla方法更好
2 对变量的命名在alisp中还是简单明了，可读性更强，而且码那么多字又费时费力的
3 函数可以写成仅对单一曲线操作，圆环写另外一个函数(可以供别的程序用),这样写命令时就可以处理选择集

非ing · 发表于 2013-6-3 13:33:42

eachy 发表于 2013-6-3 13:21
1 看lz用了vla，想必对activex很熟悉，画圆环用vla方法更好
2 对变量的命名在alisp中还是简单明了，可读性 ...

是的，
vl-cmdf容易出错；
命名确实养成了一个坏习惯，不过都是复制粘贴的，嘿嘿，慢慢改，但是因为有时为了调试方便，把所有局部变量都设置为全局变量了，但是又为了防止变量干涉。所以把每个变量都冠以该函数的函数名。都调试成功后，再改为局部变量；

Lispboy · 发表于 2013-6-3 14:00:55

本帖最后由 Lispboy 于 2013-6-3 14:02 编辑

楼主，这个地方：

(setq XX_pt (getpoint "\n输入点"))

如果用户回车了，没选点尼，程序接下去运行就要错了，所以，还是建议你在程序中加上必要的判断语句，需要的条件都成立了，再运行下面的代码。
我的经验是，凡是用户和ACAD交互的地方，一定要判断返回值。

非ing · 发表于 2013-6-3 14:05:07

Lispboy 发表于 2013-6-3 14:00
楼主，这个地方：

呵呵，是的，我只图简单了，这点确实有待改进。可以改成：(setq XX_pt (getpoint "\n输入点"))(while (not xx_pt)(setq XX_pt (getpoint "\n输入点")) )

Lispboy · 发表于 2013-6-3 14:13:58

本帖最后由 Lispboy 于 2013-6-3 14:16 编辑

另外：

(setq varlst (mapcar (function (lambda (x) (list 'setvar x (getvar x))))
'("autosnap" "osmode" "pickbox")));_定义还原变量
(setvar "osmode" 0)

赞一句这个写法，看到你错误处理有还原，但是程序结束后，你用的是:

(setvar "osmode" os)

建议你最后程序也执行下错误处理里面的还原变量。建议保存写个函数，恢复写个函数

如：

(defun sav-var (varList)
(setq $global-sysVar-varlst (mapcar (function (lambda (x) (list 'setvar x (getvar x)))) varlist)
t
)
(defun res-var ()
(mapcar 'eval $global-sysVar-varlst)
t
)

这样，在程序开始的时候用

(sav-var '("autosnap" "osmode" "pickbox"))

程序结束前执行

(res-var)

非ing · 发表于 2013-6-3 14:17:11

Lispboy 发表于 2013-6-3 14:13
另外：

呵呵，是的，另外我的程序中的ssget没有选中实体，理论上也需要进行一个错误处理，这个我就不写了。

Lispboy · 发表于 2013-6-3 14:20:09

类似于XDRX_API里面的BEGIN....END结构，在增强你的代码，begin里面，除了保存变量，你还可以把 UNDO信息保存起来，结束恢复变量的时候恢复UNDO标志。这样，如果你程序执行过很多命令时候，用户一个UNDO就回到程序开始运行前。

(begin .....)
......
(end)

Lispboy · 发表于 2013-6-3 14:22:37

hai20130408 发表于 2013-6-3 14:05
呵呵，是的，我只图简单了，这点确实有待改进。可以改成：(setq XX_pt (getpoint "\n输入点"))(while (no ...

你是希望用户循环取点吗？你那么写有些冗余了，可以这样：

(while (setq pt (getpoint "\n拾取点<退出>:"))
......
)

提示字符里面明确告诉用户，回车结束。

非ing · 发表于 2013-6-3 14:31:09

Lispboy 发表于 2013-6-3 14:20
类似于XDRX_API里面的BEGIN....END结构，在增强你的代码，begin里面，除了保存变量，你还可以把 UNDO信息保 ...

嗯，不错，这个是可以加入程序。

eachy · 发表于 2013-6-3 16:00:18

[pcode=lisp,true];;绘制圆环，这个经常用，写个函数
;;参数：中心点、半径、宽度
;;    这里参数给个 space 适用多数情况 Modelspace
;;    Paperspace Blockdeference ..
(defun Ea:AddDount (space p r w)
  (setq  p1 (polar p 0. (* r 0.5))
  p2 (polar p1 pi r) ;_圆环直径上的两个端点
  )
  (setq  pl
(vla-addlightweightpolyline
   space
   (vlax-make-variant
   (vlax-safearray-fill
      (vlax-make-safearray vlax-vbdouble '(0 . 3)) ;_ 这里只构造两个点，后面用 Closed 属性
      (apply
   'append
   (mapcar '(lambda (x) (list (car x) (cadr x))) (list p1 p2));_这里用的逆时针
      ) ;_ 3D -> 2D point
   )
   )
)
  )
  ;;设定Bulge, 对半圆来说 = 1 和 -1
  (vla-setbulge pl 0 -1.0);_如果顺时针绘制Bulge=1.0
  (vla-setbulge pl 1 -1.0)
  (vla-put-closed pl :vlax-true) ;_闭合Pline
  (vla-put-ConstantWidth pl (* w 0.5)) ;_据说乘法比除法快一点点
)
;;开始主程序
(defun c:tt (/ ss sp p1 pt)
  ;;这里演示在模型空间操作，仅用到 Modelspace， ms 简写
  (setq  ms (vla-get-modelspace
   (vla-get-activedocument (vlax-get-acad-object))
   )
  )
  (while (setq e (car (entsel "\n拾取曲线: "))) ;_可以循环选择
;;仅在第一段处绘制
(setq sp (vlax-curve-getstartpoint e) ;_vlax-curve参数可以是 Entity 也可以是 Object
p1 (vlax-curve-getpointatparam e 1.) ;_第二个点是参数 1.0
)
(setq pt (mapcar '(lambda (x) (* x 0.5)) (mapcar '+ sp p1))) ;_求中点
(Ea:AddDount ms pt 1. 2.) ;_调用绘制圆环函数
  )
  (vlax-release-object ms)
  (princ)
)[/pcode]
这里没有进行 ERROR 处理，这个应用中用户中断的机会就在选择时，中断后唯一的就是 ms 没有释放，其他代码没有影响

非ing · 发表于 2013-6-3 16:16:37

eachy 发表于 2013-6-3 16:00
;;绘制圆环，这个经常用，写个函数
;;参数：中心点、半径、宽度
;; 这里参数给个 space 适用多数情 ...

我这个程序设计背景是当一条直线上有一个圆环，然后向沿直线上指定方向偏移指定的距离，你这个程序确实也很不错。

fjb54007 · 发表于 2014-11-14 21:55:45

正需要，谢谢楼主分享

吴外安放 · 发表于 2020-7-26 14:43:02

谢谢版主分享

账号		自动登录	找回密码
密码			立即注册

[每日一码] 沿直线画圆环

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

相关帖子

点评

点评

点评

点评

点评

点评