一个程序，请各位高手看一看

hpy · 发表于 2003-12-25 20:47:00

下面这个程序是一本书上的。它的功能是给圆添加中心线并使中心线随着圆的改变而改变。
在使用中觉得程序有一点点问题。具体表现在如果对圆进行了编辑（比如拉伸、移动等）后
如果进行"undo"操作，在2002中会出现提示：错误：Automation错误，未提供说明。
如果再对圆进行编辑则中心线不再随着圆的改变而改变。在AutoCAD2004中不会出现错误提示，
但如果再对圆进行编辑则中心线也不再随着圆的改变而改变。
请各位高手看一看，帮忙解决一下这个问题。另外该程序一次只能对一个圆添加中心线，如果
能对多个圆添加中心线那就更好了。
(defun c:ccen ()
(setvar "CMDECHO" 0)
(vl-load-com) ;;加载visualisp延伸功能
(setq acadobject (vlax-get-acad-object))
(setq acadDocument (vla-get-ActiveDocument acadobject))
(setq mspace (vla-get-ModelSpace acadDocument))
(setq util (vla-get-Utility acadDocument))
(setq lts (vla-get-Linetypes acadDocument))
;;获取模型空间变量，utility变量与线型变量
(setq selsets (vla-get-Selectionsets acadDocument)) ;;获取当前图形中的选择集
(setq i (vla-get-Count selsets)) ;;将选到的变量存在变量i中
(while (> i 0)
      (setq sset (vla-item selsets 0))
      (vla-delete sset)
      (setq i (- i 1))
)  ;;;这个程序是说:如果选择集中有图元存在，则将其从选择集中删除，
   ;;;注意:这并不会从图面上真正删除图元。
(setq sset (vla-add selsets "sset"))
;;新建选择集sset，如果没有以上的准备工作，则在下一次执行程序时，由于
;;sset选择集已存在，执行到此就无法新建一个同名选择集，程序会提示一
;;错误信息
(vla-SelectOnScreen sset)
(setq notallcircle nil) ;;设定变量notallcircle来判断是或所选对象为圆
(setq ssetcount (vla-get-count sset)) ;;获取选择集中图元数量
(while (> ssetcount 0)
      (setq obj (vla-item sset (- ssetcount 1)))
      (setq objname (vla-get-objectname obj))
      (if (/= objname "AcDbCircle")
         (setq notallcircle t)
      )
   (setq ssetcount (- ssetcount 1))
   ) ;;上面的循环程序用来判断是或所选图元均为圆(用图元名判断)若非，设定变量notallcircle为t
   (while (and (vla-get-count sset) notallcircle)
      (prompt "所选图元中至少有一非圆的图元，请再选一次，或按ESC结束!")
      (vla-clear sset)
      (vla-SelectOnScreen sset)
      (setq notallcircle nil)
      (setq ssetcount (vla-get-count sset))
   (while (> ssetcount 0)
      (setq obj (vla-item sset (- ssetcount 1)))
      (setq objname (vla-get-objectname obj))
      (if (/= objname "AcDbCircle")
         (setq notallcircle t)
      )
      (setq ssetcount (- ssetcount 1))
   ))
   (setq circ-d (vla-get-Radius obj))
   (setq circ-cen (vla-get-center obj))
   (setq pt (vla-PolarPoint util circ-cen 0 (+ 5 circ-d)))
   (setq line (vla-addline mspace circ-cen pt))
   (load-line-types "CENTER" "acad.lin")
   (vla-put-Linetype line "CENTER")
   (setq lts (/ circ-d 5))
   (vla-put-LinetypeScale line lts)
   (setq linearray (vla-ArrayPolar line 4 (/ (* pi 2 (1- 4)) 4) circ-cen))
   (vla-delete sset)
   (setq circleReactor (VLR-Object-Reactor (list obj) "circle Reactor"
         '((:VLR-modified . mark))))
)
(defun load-line-types (line-type file-name / tmp res)
   (if (and (setq tmp (vlax-get-acad-object))
      (setq tmp (vla-get-activedocument tmp))
      (setq tmp (vla-get-linetypes tmp))
   )
   (if (setq res (find-line-type line-type tmp))
      res
      (progn (vla-load tmp line-type file-name)
         (if (vla-item tmp line-type)
            (vla-item tmp line-type) nil)
         )
      ) nil
   )
)
(defun find-line-type (line-type line-type-collection / res)
(setq line-type (strcase line-type))
(vlax-for 1-obj line-type-collection (if (= (strcase
            (vla-get-name 1-obj)) line-type)
            (setq res 1-obj)
   )) res
)
(defun mark (notifier-object reactor-object parameter-list)
(vl-load-com)
(setq circ-d (vla-get-Radius obj))
(setq circ-cen (vla-get-center obj))
(setq pt (vla-PolarPoint util circ-cen 0 (+ 5 circ-d)))
(vla-delete line)
(setq linesafearray (vlax-variant-value linearray))
(vla-delete (vlax-safearray-get-element linesafearray 0))
(vla-delete (vlax-safearray-get-element linesafearray 1))
(vla-delete (vlax-safearray-get-element linesafearray 2))
(setq line (vla-addline mspace circ-cen pt))
(load-line-types "CENTER" "acad.lin")
(vla-put-Linetype line "CENTER")
(setq lts (/ circ-d 5))
(vla-put-LinetypeScale line lts)
(setq linearray (vla-ArrayPolar line 4 (/ (* pi 2 (1- 4)) 4) circ-cen))
)