【飞鸟集】心随我动--为LISP定制的动态输入,拖拉和动态信息函数(更新至20130731)

highflybir

源码已经贴在ObjectArx版块处！！
http://bbs.mjtd.com/thread-90552-1-1.html
arx程序和LISP样例：

===========================================
2013.07.31日作重大更新新
把函数全部加上前缀 HFB_
增添了一些函数：
1、对图功能
C:CompareDwgs
2、状态栏开关函数
C:ShowDrawingStatusBar
3、进度条函数
HFB_SetProgressMeter
HFB_SetProgressMeterPos
4、带关键字回调的SSGet
HFB_SSGet
HFB_InitGet
HFB_SSFree
另外，对JIG,Monitor和Hook以及定时器事件都进行了优化和改进。
===========================================
12.9日更新，先附上beta版本，等各位测试后没问题，再替换。
增加了开关函数。具体演示如下：

===========================================
12.4更新,修正了动态输入的问题。消除了可能引起异常的几个bug.
增加了英文版本。
===========================================
11.29更新，修正了几个bug。增加了钩子和定时器。请重新下载新的arx和LISP.
现在可以卸载时候不弹出对话框和使得CAD崩溃了。
(setLIsptimer 回调函数 毫秒数)    ;增加一个定时器事件
(KillLispTimer)     ;关闭定时器
(RegisterHook  回调函数)  ；注册一个钩子
(removeHook)   ；移除钩子
===========================================
11.21更新，增加了R2000-2002版本。增加了几个新的函数。请重新下载新的arx和LISP.
(GetAperture)     ;靶框下的图元列表
(GetOSMode)     ;当前的捕捉模式（非系统变量）
(GetNested)      ;嵌套选择的图元列表
===========================================
ARX已经更新，有反映R2004不能用的请重新下载，并请反馈测试结果。
新增加R2007,R2008,R2009的64位版本。(dynArxFor2007-2009x64.arx)
===========================================
虽说LISP中已经提供了动态的输入采集函数grread，然而这个函数有诸多不足，譬如不支持捕捉，正交及动态输入。不能在图形外的菜单等处操作。等等。
而且在一定情况下受速度限制。
为此，我特意编写了几个函数，极大程度地扩张了CAD的动态函数。
有了这几个函数，你就可以自由地拖拉物体，既支持捕捉，也支持正交，等等。
还可以定制自己的tooltip（热信息）,定制自己的光标（这个光标可以是CAD的任何图元）;
可以随时采集输入信息，甚至可以让GetPoint,SSGet之类的函数能带有回调。

用法，先依据自己的CAD版本，加载相应的arx，然后运行附件中的测试样例。

说明：
这个arx提供了四个主要函数 HFB_PointMonitor， SSJIG ， DragGen ， XFormSS.其用法介绍参见下面的帖子。
其中以HFB_PointMonitor效果最好，SSJIG能动态输入，DragGen和XFormSS可执行大量选择集的变换。
这些函数在R2012版本上效果最好。
帖子会随时更新源码和演示，欢迎大家提意见，或者把自己的样例放上来。我会为样例加分。
在编写这个程序中，得到了FSXM的很多建议和支持，在此深表感谢。

一、输入点监视函数HFB_PointMonitor

    用来动态采集CAD中光标的位置，并反馈给用户处理。这样以来，你就可以拥有自己的鼠标。
    用来动态采集Getpoint,getangle,getdist,getorient,getcorner,entsel,nentsel,nentselp,ssget之类的函数时光标所在位置，并对其反应，形成各种特殊的效果，譬如动态拖拉，动态信息等等。
    这个函数的优点在于，回调函数不一定要在命令状态下就可以运行，就像非模态一样。

1. (vl-load-com)
   
2. (if (null CurDoc)
   
3.   (setq CurDoc
   
4. (vla-get-ActiveDocument (vlax-get-acad-object)))
   
5. )
   
6. 
   
7. 
   
8. ;;;*********************************************************************
   
9. ;;;HFB_PointMonitor用法:                                                
   
10. ;;;(HFB_PointMonitor [回调函数] [选择集/图元])                          
    
11. ;;;不带参数的(HFB_PointMonitor)为关闭监视事件                           
    
12. ;;;第一个参数为回调函数名称，应该为字符串，且存在的函数                 
    
13. ;;;回调函数只有一个参数，这个参数为三维点，代表你现在鼠标所在位置.如果返
    
14. ;;;回值为选择集或者图元，将更改鼠标捕捉排除的物体为你返回值所代表的物体.
    
15. ;;;如果返回值为字符串，说明将把字符串的信息附加到CAD的tooltip上。      
    
16. ;;;第二个参数可以缺省，缺省的话，将不排除鼠标捕捉,不过你以后仍可指定.   
    
17. ;;;*********************************************************************
    
18. ;;;*********************************************************************
    
19. ;;;图元信息显示                     
    
20. ;;;*********************************************************************
    
21. (defun c:Info(/ ret)
    
22.   (defun InfoCallback (dynpt / txt lst dat)
    
23.     (setq txt (vl-princ-to-string (mapcar 'rtos dynpt)))
    
24.     (setq txt (strcat "\n当前点的坐标是：" txt))
    
25.     (if (setq lst (nentselp dynpt))
    
26.       (progn
    
27. (setq dat (entget (car lst)))
    
28.         (strcat txt "\n这个图元的类型是：" (cdr (assoc 0 dat)))
    
29.       )
    
30.       txt
    
31.     )
    
32.   )
    
33.   (setq ret (HFB_PointMonitor "InfoCallback"))
    
34.   (prompt "\n如果要关闭监视，请用函数(HFB_PointMonitor)")
    
35.   (princ)
    
36. )
    
37. ;;;*********************************************************************
    
38. ;;;自定义光标                       
    
39. ;;;*********************************************************************
    
40. (defun C:MyCursorOn(/ ret ent)      ;打开光标
    
41.   (defun CursorCallback (dynpt / height insPnt)
    
42.     (if (not (vlax-erased-p txtobj))
    
43.       (progn
    
44.         (setq height (/ (getvar 'viewsize) 50))
    
45.         (setq insPnt (mapcar '+ dynpt (list (/ height 2) (/ height 2) 0)))
    
46.         (vlax-put txtobj 'InsertionPoint inspnt)
    
47.         (vlax-put txtobj 'height  height)
    
48.       )
    
49.       (HFB_PointMonitor)
    
50.     )
    
51.   )
    
52.   (setq ent (entmakex
    
53.        (list
    
54.         '(0 . "text")
    
55.         '(1 . "highflybird")   
    
56.         '(62 . 3)
    
57.         (cons 10 (getvar 'lastpoint))
    
58.         (cons 40 (/ (getvar 'viewsize) 50))   ;for a standard dwg
    
59.       )
    
60.     )
    
61.   )
    
62.   (setq txtobj (vlax-ename->vla-object ent))
    
63.   (setq ret (HFB_PointMonitor "CursorCallback" ent))
    
64.   (prompt "\n如果要关闭自定义光标，请用命令MyCursorOff.")
    
65.   (princ)
    
66. )
    
67. (defun C:MyCursorOff(/ ret)      ;关闭光标
    
68.   (HFB_PointMonitor)
    
69.   (and (not (vlax-erased-p txtobj)) (vla-erase txtobj))
    
70.   (setq txtobj nil)
    
71.   (princ)
    
72. )
    
73. ;;;*********************************************************************
    
74. ;;;带回调函数的GetXXX测试(模拟move命令)                                 
    
75. ;;;*********************************************************************
    
76. (defun C:GetXXX(/ OBJLST P0 PT SS)
    
77.   (setq *error*_Old *error*)      ;保存出错处理函数
    
78.   (setq *error* *error*_New)      ;设置新的出错处理
    
79.   (defun PointCallback (dynpt)      ;回调函数
    
80.     (foreach obj objlst
    
81.       (vla-move obj (vlax-3d-point p0) (vlax-3d-point dynpt))  ;移动物体
    
82.     )
    
83.     (setq p0 dynpt)      
    
84.   )
    
85.   (vla-StartUndoMark CurDoc)      ;撤销编组开始
    
86.   (if (and (setq ss (ssget))
    
87.     (setq pt (getpoint "\n第一点(1st Point): "))
    
88.       )
    
89.     (progn
    
90.       (setq objlst (GetObjects ss))
    
91.       (setq p0 (trans pt 1 0))      ;需要转化到世界坐标系
    
92.      
    
93.       ;;设置回调函数名和需要排除捕捉的选择集
    
94.       (setq ret (HFB_PointMonitor "PointCallback" ss))   ;第一个参数是回调函数名，第二个参数是可以省略（如果不需要排除捕捉的话）
    
95.       ;;现在就可以看到动态效果了
    
96.       (setq ret (getpoint pt "\n第二点(2nd point): "))   ;此处可以是lisp的交互函数，例如getpoint,getangle之类。
    
97.       ;;最后关闭监视
    
98.       (HFB_PointMonitor)      
    
99.       
    
100.       (princ ret)
     
101.     )
     
102.   )
     
103.   (vla-EndUndoMark curdoc)      ;编组结束  
     
104.   (princ)
     
105. )

(vl-load-com)<br /> (if (null CurDoc)<br />   (setq CurDoc <br /> (vla-get-ActiveDocument (vlax-get-acad-object)))<br /> )<br /> <br /> <br /> ;;;*********************************************************************<br /> ;;;HFB_PointMonitor用法:                                                <br /> ;;;(HFB_PointMonitor [回调函数] [选择集/图元])                          <br /> ;;;不带参数的(HFB_PointMonitor)为关闭监视事件                           <br /> ;;;第一个参数为回调函数名称，应该为字符串，且存在的函数                 <br /> ;;;回调函数只有一个参数，这个参数为三维点，代表你现在鼠标所在位置.如果返<br /> ;;;回值为选择集或者图元，将更改鼠标捕捉排除的物体为你返回值所代表的物体.<br /> ;;;如果返回值为字符串，说明将把字符串的信息附加到CAD的tooltip上。       <br /> ;;;第二个参数可以缺省，缺省的话，将不排除鼠标捕捉,不过你以后仍可指定.   <br /> ;;;*********************************************************************<br /> ;;;*********************************************************************<br /> ;;;图元信息显示                      <br /> ;;;*********************************************************************<br /> (defun c:Info(/ ret)<br />   (defun InfoCallback (dynpt / txt lst dat)<br />     (setq txt (vl-princ-to-string (mapcar 'rtos dynpt)))<br />     (setq txt (strcat "\n当前点的坐标是：" txt))<br />     (if (setq lst (nentselp dynpt))<br />       (progn<br /> (setq dat (entget (car lst)))<br />         (strcat txt "\n这个图元的类型是：" (cdr (assoc 0 dat)))<br />       )<br />       txt<br />     )<br />   )<br />   (setq ret (HFB_PointMonitor "InfoCallback")) <br />   (prompt "\n如果要关闭监视，请用函数(HFB_PointMonitor)")<br />   (princ)<br /> )<br /> ;;;*********************************************************************<br /> ;;;自定义光标                       <br /> ;;;*********************************************************************<br /> (defun C:MyCursorOn(/ ret ent)      ;打开光标<br />   (defun CursorCallback (dynpt / height insPnt)<br />     (if (not (vlax-erased-p txtobj))<br />       (progn <br />         (setq height (/ (getvar 'viewsize) 50))<br />         (setq insPnt (mapcar '+ dynpt (list (/ height 2) (/ height 2) 0)))<br />         (vlax-put txtobj 'InsertionPoint inspnt)<br />         (vlax-put txtobj 'height  height)<br />       )<br />       (HFB_PointMonitor)<br />     )<br />   )<br />   (setq ent (entmakex<br />        (list<br />         '(0 . "text")<br />         '(1 . "highflybird")    <br />         '(62 . 3)<br />         (cons 10 (getvar 'lastpoint))<br />         (cons 40 (/ (getvar 'viewsize) 50))   ;for a standard dwg<br />       )<br />     )<br />   )<br />   (setq txtobj (vlax-ename->vla-object ent))<br />   (setq ret (HFB_PointMonitor "CursorCallback" ent)) <br />   (prompt "\n如果要关闭自定义光标，请用命令MyCursorOff.")<br />   (princ)<br /> )<br /> (defun C:MyCursorOff(/ ret)      ;关闭光标<br />   (HFB_PointMonitor)<br />   (and (not (vlax-erased-p txtobj)) (vla-erase txtobj))<br />   (setq txtobj nil)<br />   (princ)<br /> )<br /> ;;;*********************************************************************<br /> ;;;带回调函数的GetXXX测试(模拟move命令)                                 <br /> ;;;*********************************************************************<br /> (defun C:GetXXX(/ OBJLST P0 PT SS)<br />   (setq *error*_Old *error*)      ;保存出错处理函数<br />   (setq *error* *error*_New)      ;设置新的出错处理<br />   (defun PointCallback (dynpt)      ;回调函数<br />     (foreach obj objlst<br />       (vla-move obj (vlax-3d-point p0) (vlax-3d-point dynpt))  ;移动物体<br />     )<br />     (setq p0 dynpt)       <br />   )<br />   (vla-StartUndoMark CurDoc)      ;撤销编组开始<br />   (if (and (setq ss (ssget))<br />     (setq pt (getpoint "\n第一点(1st Point): "))<br />       )<br />     (progn<br />       (setq objlst (GetObjects ss))<br />       (setq p0 (trans pt 1 0))      ;需要转化到世界坐标系<br />      <br />       ;;设置回调函数名和需要排除捕捉的选择集<br />       (setq ret (HFB_PointMonitor "PointCallback" ss))   ;第一个参数是回调函数名，第二个参数是可以省略（如果不需要排除捕捉的话）<br />       ;;现在就可以看到动态效果了<br />       (setq ret (getpoint pt "\n第二点(2nd point): "))   ;此处可以是lisp的交互函数，例如getpoint,getangle之类。<br />       ;;最后关闭监视<br />       (HFB_PointMonitor)      <br />       <br />       (princ ret)<br />     )<br />   )<br />   (vla-EndUndoMark curdoc)      ;编组结束  <br />   (princ)<br /> )

xshrimp

给力.
CAD2004加载不成功. 2006加载成功.

Gu_xl

动态信息查询,由一个经典的yad动态信息查询函数改编而来!

1. ;;;飞鸟集]心随我动--为LISP定制的动态输入，动态拖拉和动态信息函数之应用---动态信息查询
   
2. ;;;由一个经典的yad动态信息查询函数改编而来！改编： Gu_xl 2011.11.19
   
3. (defun InfoCallBak (PT /  TOANG    DIS ENT)
   
4.   (defun toang(ang i)
   
5.     (if (= i 1)
   
6.       (* ang (/ 180 pi))
   
7.       (* ang (/ pi 180))
   
8.     )
   
9.   )
   
10. (defun gxl-dxf (ent i)
    
11. (cdr (assoc i (entget ent)))
    
12. )
    
13.   (defun dis (ENT / MJBL OBJ LAYNM NAME LST)
    
14.     (if (= mjdw 1000) (setq mjbl 1000000) (setq mjbl 1))
    
15.     (setq obj (vlax-ename->vla-object ent))
    
16.     (setq laynm (strcat "图层:" (gxl-dxf ent 8)) name (gxl-dxf ent 0))
    
17.     (cond
    
18.       ((= name "3DFACE")
    
19.         (setq lst (list "【三维面】" laynm))
    
20.       )
    
21.       ((= name "3DSOLID")
    
22.         (setq lst (list "【三维实体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
    
23.       )
    
24.       ((= name "ACAD_PROXY_ENTITY")
    
25.         (setq lst (list "【代理】" laynm))
    
26.       )
    
27.       ((= name "ARC")
    
28.         (setq lst (list "【圆弧】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
    
29.                                          (strcat "圆心角:" (rtos (toang (vla-get-TotalAngle obj) 1) 2 1) "度")
    
30.                                          (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
    
31.                                          (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
    
32.                                          (strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 0))
    
33.                                          (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
    
34.         ))
    
35.       )
    
36.       ((= name "ATTDEF")
    
37.         (setq lst (list "【属性定义】" laynm (strcat "标签:" (vla-get-TagString obj))
    
38.                                              (strcat "提示:" (vla-get-PromptString obj))
    
39.                                              (strcat "缺省值:" (vla-get-TextString obj))
    
40.                                              (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
    
41.                                              (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
    
42.                                              (strcat "文字样式:" (vla-get-StyleName obj))
    
43.         ))
    
44.       )
    
45.       ((= name "ATTRIB")
    
46.         (setq lst (list "【属性】" laynm (strcat "标签:" (vla-get-TagString obj))
    
47.                                          (strcat "缺省值:" (vla-get-TextString obj))
    
48.                                          (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
    
49.                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
    
50.                                          (strcat "文字样式:" (vla-get-StyleName obj))
    
51.         ))
    
52.       )
    
53.       ((= name "BODY")
    
54.         (setq lst (list "【体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
    
55.       )
    
56.       ((= name "CIRCLE")
    
57.         (setq lst (list "【圆】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
    
58.                                        (strcat "周长:" (rtos (vla-get-Circumference obj) 2 0))
    
59.                                        (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
    
60.         ))
    
61.       )
    
62.       ((= name "DIMENSION")
    
63.         (setq lst (list "【尺寸标注】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
    
64.                                              (strcat "文字样式:" (vla-get-TextStyle obj))
    
65.                                              (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
    
66.                                              (strcat "替带文字:" (if (= (gxl-dxf ent 1) "") "无" (gxl-dxf ent 1)))
    
67.         ))
    
68.       )
    
69.       ((= name "ELLIPSE")
    
70.         (setq lst (list "【椭圆】" laynm (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 0))
    
71.                                          (strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 0))
    
72.                                          (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
    
73.                                          (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
    
74.                                          (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
    
75.         ))
    
76.       )
    
77.       ((= name "HATCH")
    
78.         (setq lst (list "【图案填充】" laynm (strcat "图案名称:" (vla-get-PatternName obj))
    
79.                                              (strcat "角度:" (rtos (toang (vla-get-PatternAngle obj) 1) 2 1))
    
80.                                              (strcat "比例:" (rtos (vla-get-PatternScale obj) 2 0))
    
81.                                              (strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))
    
82.                                              (strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))
    
83.         ))
    
84.       )
    
85.       ((= name "IMAGE")
    
86.         (setq lst (list "【图像】" laynm (strcat "图像大小:" (rtos (car (gxl-dxf ent 13)) 2 0) "X" (rtos (cadr (gxl-dxf ent 13)) 2 0))))
    
87.       )
    
88.       ((= name "INSERT")
    
89.         (setq lst (list "【图块】" laynm (strcat "名称:" (gxl-dxf ent 2))
    
90.                                          (strcat "X比例:" (rtos (gxl-dxf ent 41) 2 1))
    
91.                                          (strcat "Y比例:" (rtos (gxl-dxf ent 42) 2 1))
    
92.                                          (strcat "Z比例:" (rtos (gxl-dxf ent 43) 2 1))
    
93.                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
    
94.         ))
    
95.       )
    
96.       ((= name "LEADER")
    
97.         (setq lst (list "【引线】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
    
98.                                          (strcat "引线类型:" (gxl-dxf (list (cons 0 "折线") (cons 1 "样条曲线")) (gxl-dxf ent 72)))
    
99.         ))
    
100.       )
     
101.       ((= name "LINE")
     
102.         (setq lst (list "【直线】" laynm (strcat "长度:" (rtos (vla-get-length obj) 2 0))
     
103.                                          (strcat "角度:" (rtos (toang (vla-get-angle obj) 1) 2 1) "度")
     
104.         ))
     
105.       )
     
106.       ((= name "LWPOLYLINE")
     
107.         (setq lst (list "【多段线】" laynm (strcat "常量宽度:" (if (gxl-dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 0) "变宽度"))
     
108.                                             (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
     
109.                                             (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
     
110.         ))
     
111.       )
     
112.       ((= name "MLINE")
     
113.         (setq lst (list "【多线】" laynm (strcat "多线样式:" (vla-get-StyleName obj))
     
114.                                          (strcat "比例因子:" (rtos (gxl-dxf ent 40) 2 1))
     
115.                                          (strcat "对齐:" (nth (gxl-dxf ent 70) '("上" "零" "下")))
     
116.         ))
     
117.       )
     
118.       ((= name "MTEXT")
     
119.         (setq lst (list "【多行文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
     
120.                                              (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
     
121.                                              (strcat "样式:" (vla-get-StyleName obj))
     
122.         ))
     
123.       )
     
124.       ((or (= name "OLEFRame") (= name "OLE2FRame"))
     
125.         (setq lst (list "【OLE边框】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
     
126.       )
     
127.       ((= name "POINT")
     
128.         (setq lst (list "【点】" laynm))
     
129.       )
     
130.       ((= name "POLYLINE")
     
131.         (setq lst (list "【三维多段线】" laynm))
     
132.       )
     
133.       ((= name "RAY")
     
134.         (setq lst (list "【射线】" laynm))
     
135.       )
     
136.       ((= name "REGION")
     
137.         (setq lst (list "【面域】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
     
138.       )
     
139.       ((= name "SHAPE")
     
140.         (setq lst (list "【形】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
     
141.                                        (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
     
142.                                        (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
     
143.         ))
     
144.       )
     
145.       ((= name "SOLID")
     
146.         (setq lst (list "【实体】" laynm))
     
147.       )
     
148.       ((= name "SPLINE")
     
149.         (setq lst (list "【样条曲线】" laynm (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
     
150.                                              (strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))
     
151.                                              (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
     
152.         ))
     
153.       )
     
154.       ((= name "TEXT")
     
155.         (setq lst (list "【文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
     
156.                                          (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
     
157.                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
     
158.                                          (strcat "样式:" (vla-get-StyleName obj))
     
159.                                          (strcat "对齐:" (nth (vla-get-Alignment obj) '("Left" "Center" "Right" "Aligned" "Middle" "Fit" "TopLeft" "TopCenter" "TopRight"
     
160.                                                                                         "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")))
     
161.         ))
     
162.       )
     
163.       ((= name "TOLERANCE")
     
164.         (setq lst (list "【公差】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
     
165.                                          (strcat "文字样式:" (vla-get-TextStyle obj))
     
166.                                          (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
     
167.         ))
     
168.       )
     
169.       ((= name "TRACE")
     
170.         (setq lst (list "【宽线】" laynm))
     
171.       )
     
172.       ((= name "VERTEX")
     
173.         (setq lst (list "【顶点】" laynm (strcat "起始宽度:" (rtos (gxl-dxf ent 40) 2 0))
     
174.                                          (strcat "结束宽度:" (rtos (gxl-dxf ent 41) 2 0))
     
175.                                          (strcat "凸度:" (rtos (gxl-dxf ent 42) 2 1))
     
176.         ))
     
177.       )
     
178.       ((= name "XLINE")
     
179.         (setq lst (list "【构造线】" laynm))
     
180.       )
     
181.       (T
     
182.         (setq lst (list "【未知对象】" laynm))
     
183.       )
     
184.     )
     
185.     (apply 'strcat (mapcar '(lambda (x)(strcat x "\n")) lst))
     
186.   )
     
187. (if (setq ent (nentselp pt)
     
188.             ent (if (and ent (= (type (last (last ent))) 'ename))
     
189.                   (last (last ent))
     
190.                   (car ent)
     
191.                 )
     
192.       )
     
193. (dis ent)
     
194.    )
     
195. )
     
196. (defun c:DynInfo  (/ loaded openview closeview)
     
197.   (defun openview  (/ arxs)
     
198.     (VL-ACAD-DEFUN 'InfoCallBak)
     
199.     (if (null mjdw)
     
200.       (progn
     
201. (INITget 7 "Yes No  ")
     
202. (setq Mjdw (getKword "\n以毫米为单位?[<Yes/No>]<No>:"))
     
203. (if (= mjdw "Yes")
     
204.    (setq mjdw 1000)
     
205.    (setq mjdw 999)
     
206. )
     
207.       )
     
208.     )
     
209.     (HFB_PointMonitor)
     
210.     (HFB_PointMonitor "InfoCallBak")
     
211.     (princ "\n动态信息查看打开！")
     
212.     (setq *dynViewEnt* t)
     
213.     )
     
214.   (defun closeview  ()
     
215.     (HFB_PointMonitor)
     
216.     (princ "\n动态信息查看关闭！")
     
217.     (setq *dynViewEnt* nil)
     
218.     )
     
219.   (cond ((= 16 (atoi (getvar 'acadver)))
     
220.   (if (not (member "dynarxfor2004-2006.arx" (arx)))
     
221.     (if (setq fn (findfile "dynarxfor2004-2006.arx"))
     
222.       (setq loaded (arxload fn "1"))
     
223.       (setq loaded "2")
     
224.       )
     
225.     (setq loaded "3") ;_ 已加载
     
226.     )
     
227.   )
     
228. ((= 17 (atoi (getvar 'acadver)))
     
229.   (if (not (member "dynarxfor2007-2009.arx" (arx)))
     
230.     (if (setq fn (findfile "dynarxfor2007-2009.arx"))
     
231.       (setq loaded (arxload fn "1"))
     
232.       (setq loaded "2")
     
233.       )
     
234.     (setq loaded "3")
     
235.     )
     
236.   )
     
237. ((= 18 (atoi (getvar 'acadver)))
     
238.   (if (= "x86" (getenv "PROCESSOR_ARCHITECTURE"))
     
239.     (if (not (member "dynarxfor2010-2012x32.arx" (arx)))
     
240.       (if (setq fn (findfile "dynarxfor2010-2012x32.arx"))
     
241.         (setq loaded (arxload fn "1"))
     
242.         (setq loaded "2")
     
243.         )
     
244.       (setq loaded "3")
     
245.       )
     
246.     (if (not (member "dynarxfor2010-2012x64.arx" (arx)))
     
247.       (if (setq fn (findfile "dynarxfor2010-2012x64.arx"))
     
248.         (setq loaded
     
249.         (arxload (findfile "dynarxfor2010-2012x64.arx")
     
250.           "1"))
     
251.         (setq loaded "2")
     
252.         )
     
253.       (setq loaded "3")
     
254.       )
     
255.     )
     
256.   )
     
257. (t (setq loaded "2"))
     
258. )
     
259.   (if (not (or (= "1" loaded) (= "2" loaded)))
     
260.     (if *dynViewEnt*
     
261. (closeview)
     
262. (openview)
     
263. )
     
264.     )
     
265.   (princ)
     
266.   )
     

;;;飞鸟集]心随我动--为LISP定制的动态输入，动态拖拉和动态信息函数之应用---动态信息查询<br /> ;;;由一个经典的yad动态信息查询函数改编而来！改编： Gu_xl 2011.11.19<br /> (defun InfoCallBak (PT /  TOANG    DIS ENT)<br />   (defun toang(ang i)<br />     (if (= i 1)<br />       (* ang (/ 180 pi))<br />       (* ang (/ pi 180))<br />     )<br />   )<br /> (defun gxl-dxf (ent i)<br /> (cdr (assoc i (entget ent)))<br /> )<br />   (defun dis (ENT / MJBL OBJ LAYNM NAME LST)<br />     (if (= mjdw 1000) (setq mjbl 1000000) (setq mjbl 1))<br />     (setq obj (vlax-ename->vla-object ent))<br />     (setq laynm (strcat "图层:" (gxl-dxf ent 8)) name (gxl-dxf ent 0))<br />     (cond<br />       ((= name "3DFACE")<br />         (setq lst (list "【三维面】" laynm))<br />       )<br />       ((= name "3DSOLID")<br />         (setq lst (list "【三维实体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))<br />       )<br />       ((= name "ACAD_PROXY_ENTITY")<br />         (setq lst (list "【代理】" laynm))<br />       )<br />       ((= name "ARC")<br />         (setq lst (list "【圆弧】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))<br />                                          (strcat "圆心角:" (rtos (toang (vla-get-TotalAngle obj) 1) 2 1) "度")<br />                                          (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")<br />                                          (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")<br />                                          (strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 0))<br />                                          (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")<br />         ))<br />       )<br />       ((= name "ATTDEF")<br />         (setq lst (list "【属性定义】" laynm (strcat "标签:" (vla-get-TagString obj))<br />                                              (strcat "提示:" (vla-get-PromptString obj))<br />                                              (strcat "缺省值:" (vla-get-TextString obj))<br />                                              (strcat "高度:" (rtos (vla-get-Height obj) 2 0))<br />                                              (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")<br />                                              (strcat "文字样式:" (vla-get-StyleName obj))<br />         ))<br />       )<br />       ((= name "ATTRIB")<br />         (setq lst (list "【属性】" laynm (strcat "标签:" (vla-get-TagString obj))<br />                                          (strcat "缺省值:" (vla-get-TextString obj))<br />                                          (strcat "高度:" (rtos (vla-get-Height obj) 2 0))<br />                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")<br />                                          (strcat "文字样式:" (vla-get-StyleName obj))<br />         ))<br />       )<br />       ((= name "BODY")<br />         (setq lst (list "【体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))<br />       )<br />       ((= name "CIRCLE")<br />         (setq lst (list "【圆】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))<br />                                        (strcat "周长:" (rtos (vla-get-Circumference obj) 2 0))<br />                                        (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")<br />         ))<br />       )<br />       ((= name "DIMENSION")<br />         (setq lst (list "【尺寸标注】" laynm (strcat "标注样式:" (vla-get-StyleName obj))<br />                                              (strcat "文字样式:" (vla-get-TextStyle obj))<br />                                              (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))<br />                                              (strcat "替带文字:" (if (= (gxl-dxf ent 1) "") "无" (gxl-dxf ent 1)))<br />         ))<br />       )<br />       ((= name "ELLIPSE")<br />         (setq lst (list "【椭圆】" laynm (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 0))<br />                                          (strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 0))<br />                                          (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")<br />                                          (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")<br />                                          (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")<br />         ))<br />       )<br />       ((= name "HATCH")<br />         (setq lst (list "【图案填充】" laynm (strcat "图案名称:" (vla-get-PatternName obj))<br />                                              (strcat "角度:" (rtos (toang (vla-get-PatternAngle obj) 1) 2 1))<br />                                              (strcat "比例:" (rtos (vla-get-PatternScale obj) 2 0))<br />                                              (strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))<br />                                              (strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))<br />         ))<br />       )<br />       ((= name "IMAGE")<br />         (setq lst (list "【图像】" laynm (strcat "图像大小:" (rtos (car (gxl-dxf ent 13)) 2 0) "X" (rtos (cadr (gxl-dxf ent 13)) 2 0))))<br />       )<br />       ((= name "INSERT")<br />         (setq lst (list "【图块】" laynm (strcat "名称:" (gxl-dxf ent 2))<br />                                          (strcat "X比例:" (rtos (gxl-dxf ent 41) 2 1))<br />                                          (strcat "Y比例:" (rtos (gxl-dxf ent 42) 2 1))<br />                                          (strcat "Z比例:" (rtos (gxl-dxf ent 43) 2 1))<br />                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")<br />         ))<br />       )<br />       ((= name "LEADER")<br />         (setq lst (list "【引线】" laynm (strcat "标注样式:" (vla-get-StyleName obj))<br />                                          (strcat "引线类型:" (gxl-dxf (list (cons 0 "折线") (cons 1 "样条曲线")) (gxl-dxf ent 72)))<br />         ))<br />       )<br />       ((= name "LINE")<br />         (setq lst (list "【直线】" laynm (strcat "长度:" (rtos (vla-get-length obj) 2 0))<br />                                          (strcat "角度:" (rtos (toang (vla-get-angle obj) 1) 2 1) "度")<br />         ))<br />       )<br />       ((= name "LWPOLYLINE")<br />         (setq lst (list "【多段线】" laynm (strcat "常量宽度:" (if (gxl-dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 0) "变宽度"))<br />                                             (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))<br />                                             (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")<br />         ))<br />       )<br />       ((= name "MLINE")<br />         (setq lst (list "【多线】" laynm (strcat "多线样式:" (vla-get-StyleName obj))<br />                                          (strcat "比例因子:" (rtos (gxl-dxf ent 40) 2 1))<br />                                          (strcat "对齐:" (nth (gxl-dxf ent 70) '("上" "零" "下")))<br />         ))<br />       )<br />       ((= name "MTEXT")<br />         (setq lst (list "【多行文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))<br />                                              (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")<br />                                              (strcat "样式:" (vla-get-StyleName obj))<br />         ))<br />       )<br />       ((or (= name "OLEFRame") (= name "OLE2FRame"))<br />         (setq lst (list "【OLE边框】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))<br />       )<br />       ((= name "POINT")<br />         (setq lst (list "【点】" laynm))<br />       )<br />       ((= name "POLYLINE")<br />         (setq lst (list "【三维多段线】" laynm))<br />       )<br />       ((= name "RAY")<br />         (setq lst (list "【射线】" laynm))<br />       )<br />       ((= name "REGION")<br />         (setq lst (list "【面域】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))<br />       )<br />       ((= name "SHAPE")<br />         (setq lst (list "【形】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))<br />                                        (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))<br />                                        (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")<br />         ))<br />       )<br />       ((= name "SOLID")<br />         (setq lst (list "【实体】" laynm))<br />       )<br />       ((= name "SPLINE")<br />         (setq lst (list "【样条曲线】" laynm (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))<br />                                              (strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))<br />                                              (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")<br />         ))<br />       )<br />       ((= name "TEXT")<br />         (setq lst (list "【文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))<br />                                          (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))<br />                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")<br />                                          (strcat "样式:" (vla-get-StyleName obj))<br />                                          (strcat "对齐:" (nth (vla-get-Alignment obj) '("Left" "Center" "Right" "Aligned" "Middle" "Fit" "TopLeft" "TopCenter" "TopRight"<br />                                                                                         "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")))<br />         ))<br />       )<br />       ((= name "TOLERANCE")<br />         (setq lst (list "【公差】" laynm (strcat "标注样式:" (vla-get-StyleName obj))<br />                                          (strcat "文字样式:" (vla-get-TextStyle obj))<br />                                          (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))<br />         ))<br />       )<br />       ((= name "TRACE")<br />         (setq lst (list "【宽线】" laynm))<br />       )<br />       ((= name "VERTEX")<br />         (setq lst (list "【顶点】" laynm (strcat "起始宽度:" (rtos (gxl-dxf ent 40) 2 0))<br />                                          (strcat "结束宽度:" (rtos (gxl-dxf ent 41) 2 0))<br />                                          (strcat "凸度:" (rtos (gxl-dxf ent 42) 2 1))<br />         ))<br />       )<br />       ((= name "XLINE")<br />         (setq lst (list "【构造线】" laynm))<br />       )<br />       (T<br />         (setq lst (list "【未知对象】" laynm))<br />       )<br />     )<br />     (apply 'strcat (mapcar '(lambda (x)(strcat x "\n")) lst))<br />   )<br /> (if (setq ent (nentselp pt)<br />             ent (if (and ent (= (type (last (last ent))) 'ename))<br />                   (last (last ent))<br />                   (car ent)<br />                 )<br />       ) <br /> (dis ent)<br />    )<br /> )<br /> (defun c:DynInfo  (/ loaded openview closeview)<br />   (defun openview  (/ arxs)<br />     (VL-ACAD-DEFUN 'InfoCallBak)<br />     (if (null mjdw)<br />       (progn<br /> (INITget 7 "Yes No  ")<br /> (setq Mjdw (getKword "\n以毫米为单位?[<Yes/No>]<No>:"))<br /> (if (= mjdw "Yes")<br />    (setq mjdw 1000)<br />    (setq mjdw 999)<br /> )<br />       )<br />     )<br />     (HFB_PointMonitor)<br />     (HFB_PointMonitor "InfoCallBak")<br />     (princ "\n动态信息查看打开！")<br />     (setq *dynViewEnt* t)<br />     )<br />   (defun closeview  ()<br />     (HFB_PointMonitor)<br />     (princ "\n动态信息查看关闭！")<br />     (setq *dynViewEnt* nil)<br />     )<br />   (cond ((= 16 (atoi (getvar 'acadver)))<br />   (if (not (member "dynarxfor2004-2006.arx" (arx)))<br />     (if (setq fn (findfile "dynarxfor2004-2006.arx"))<br />       (setq loaded (arxload fn "1"))<br />       (setq loaded "2")<br />       )<br />     (setq loaded "3") ;_ 已加载<br />     )<br />   )<br /> ((= 17 (atoi (getvar 'acadver)))<br />   (if (not (member "dynarxfor2007-2009.arx" (arx)))<br />     (if (setq fn (findfile "dynarxfor2007-2009.arx"))<br />       (setq loaded (arxload fn "1"))<br />       (setq loaded "2")<br />       )<br />     (setq loaded "3")<br />     )<br />   )<br /> ((= 18 (atoi (getvar 'acadver)))<br />   (if (= "x86" (getenv "PROCESSOR_ARCHITECTURE"))<br />     (if (not (member "dynarxfor2010-2012x32.arx" (arx)))<br />       (if (setq fn (findfile "dynarxfor2010-2012x32.arx"))<br />         (setq loaded (arxload fn "1"))<br />         (setq loaded "2")<br />         )<br />       (setq loaded "3")<br />       )<br />     (if (not (member "dynarxfor2010-2012x64.arx" (arx)))<br />       (if (setq fn (findfile "dynarxfor2010-2012x64.arx"))<br />         (setq loaded<br />         (arxload (findfile "dynarxfor2010-2012x64.arx")<br />           "1"))<br />         (setq loaded "2")<br />         )<br />       (setq loaded "3")<br />       )<br />     )<br />   )<br /> (t (setq loaded "2"))<br /> )<br />   (if (not (or (= "1" loaded) (= "2" loaded)))<br />     (if *dynViewEnt*<br /> (closeview)<br /> (openview)<br /> )<br />     )<br />   (princ)<br />   )<br />

lohas1118

支持，很给力

highflybir

二、让LISP也能JIG,JIG是arx或者.net编程的一个函数，用来在采点过程中与用户交互的一个动态拖拉技术。
JIG的优势在于：可以动态输入，功能齐全，与用户交互性较好，直观方便。

1. ;;;*********************************************************************
   
2. ;;;SSJIG用法:                                                               
   
3. ;;;(SSJIG 回调函数 [提示][关键字][控制类型][光标类型][基点][选择集])        
   
4. ;;;除第一个参数必须外，其他的可以缺省。                                 
   
5. ;;;---------------------------------------------------------------------
   
6. ;;;1.  回调函数应该为字符串，且代表存在的函数,回调函数只有一个参数，这个
   
7. ;;;参数为三维点，代表你现在鼠标所在位置.如果回调函数返回一个三维点，将更
   
8. ;;;改基点位置,如果再附加一个字符串,将更改你的回调函数为字符串代表的函数.
   
9. ;;;---------------------------------------------------------------------
   
10. ;;;2.  提示--STR 类型，拖动过程中提示的信息。                           
    
11. ;;;---------------------------------------------------------------------
    
12. ;;;3.  关键字--STR 类型，具体用法可参考initget的关键字说明               
    
13. ;;;---------------------------------------------------------------------
    
14. ;;;4.  控制类型: --INT 类型                                                
    
15. ;;;    kGovernedByOrthoMode           = 1,     正交模式是否设置            
    
16. ;;;    kNullResponseAccepted           = 2,     空回车响应输入请求         
    
17. ;;;    kDontEchoCancelForCtrlC           = 4,     Ctrl+C不作为取消            
    
18. ;;;    kDontUpdateLastPoint           = 8,     不更新lastpoint变量         
    
19. ;;;    kNoDwgLimitsChecking           = 16,    点不作限制，可在图形外      
    
20. ;;;    kNoZeroResponseAccepted           = 32,    不允许输入零               
    
21. ;;;    kNoNegativeResponseAccepted = 64,    不允许输入负值              
    
22. ;;;    kAccept3dCoordinates           = 128,   接受三维坐标点              
    
23. ;;;    kAcceptMouseUpAsPoint           = 256,   鼠标松开为输入点            
    
24. ;;;    kAnyBlankTerminatesInput           = 512,   任何空白中断输入            
    
25. ;;;    kInitialBlankTerminatesInput= 1024,  初始空白中断输入            
    
26. ;;;    kAcceptOtherInputString           = 2048,  接受其他字符               
    
27. ;;;    kGovernedByUCSDetect        = 4096,                              
    
28. ;;;    kNoZDirectionOrtho          = 8192,                              
    
29. ;;;    kImpliedFaceForUCSChange    = 16384,                             
    
30. ;;;    kUseBasePointElevation      = 32768,                             
    
31. ;;;    kAcqureDist                 = 65536, 输入作为距离，相当于getdist
    
32. ;;;    kAcqureAngle                = 131072,输入作为角度，相当于getangle
    
33. ;;;---------------------------------------------------------------------
    
34. ;;;5.  光标类型:--INT 类型                                             
    
35. ;;;    kNoSpecialCursor = -1,      // 普通类型                          
    
36. ;;;    kCrosshair = 0,             // 全屏十字光标                     
    
37. ;;;    kRectCursor = 1,            // 矩形                              
    
38. ;;;    kRubberBand = 2,            // 橡皮筋                           
    
39. ;;;    kNotRotated = 3,            // 未旋转形状                        
    
40. ;;;    kTargetBox = 4,             // 选取形状                          
    
41. ;;;    kRotatedCrosshair = 5,      // 旋转的形状.                       
    
42. ;;;    kCrosshairNoRotate = 6,     // 强制为未旋转的十字形状.           
    
43. ;;;    kInvisible = 7,             // 光标不可见.                       
    
44. ;;;    kEntitySelect = 8,          // 拾取目标形状.                     
    
45. ;;;    kParallelogram = 9,         // 平行四边形状.                     
    
46. ;;;    kEntitySelectNoPersp = 10,  // 选择框，透视图中不可用.           
    
47. ;;;    kPkfirstOrGrips = 11,       // 自动选择光标.                     
    
48. ;;;    kCrosshairDashed = 12       // 虚线的十字光标                    
    
49. ;;;---------------------------------------------------------------------
    
50. ;;;6.  基点: --LIST 类型，三维点表                                      
    
51. ;;;    用来动态输入时的基点（第一点）                                   
    
52. ;;;    如果指定了基点，则表明指定点为第一点,否则读取变量LASTPOINT        
    
53. ;;;---------------------------------------------------------------------
    
54. ;;;7.  选择集:--ENAME 类型或者 PICKSRT类型，暂时保留                    
    
55. ;;;    (如果指定了选择集，则对这个选择集更新)                           
    
56. ;;;---------------------------------------------------------------------
    
57. ;;;SSJIG函数的返回值，正常情况下返回三维点坐标，如果设置了可接受任意字符
    
58. ;;;则输入字符结束后返回输入的字符串,如果设置了关键字，而用户输入了关键字
    
59. ;;;则返回关键字。其他情况则返回整数值，代表意义如下：                  
    
60. ;;;    kModeless       = -17,                                          
    
61. ;;;    kNoChange       = -6,                                            
    
62. ;;;    kCancel         = -4,                                            
    
63. ;;;    kOther          = -3,                                            
    
64. ;;;    kNull           = -1,                                            
    
65. ;;;*********************************************************************
    
66. 
    
67. 
    
68. ;;;*********************************************************************
    
69. ;;;JIG测试移动选择集                                                        
    
70. ;;;*********************************************************************
    
71. (defun c:ttt(/ ss pt lst p0 ret i x ret)
    
72.   (setq *error*_Old *error*)                                                ;保存出错处理函数
    
73.   (setq *error* *error*_New)                                                ;设置新的出错处理
    
74.   ;;回调函数 for SSJig
    
75.   (defun CallBack (dynpt)
    
76.     (setq i (+ i 10000))
    
77.     (setq x (entmakex
    
78.               (list
    
79.                 '(0 . "LINE")
    
80.                 (cons 420 i)
    
81.                 (cons 10 (trans pt 1 0))
    
82.                 (cons 11 dynpt)
    
83.               )
    
84.             )
    
85.     )
    
86.     (if x (setq ss (ssadd x ss)))
    
87.     (foreach obj lst
    
88.       (vla-move obj (vlax-3d-point p0) (vlax-3d-point dynpt))
    
89.       ;;(vla-update obj)                                                ;无需用vla-update更新
    
90.     )
    
91.     (setq p0 dynpt)
    
92.     ss
    
93.   )
    
94.   
    
95.   (vla-StartUndoMark CurDoc)                                                ;(command ".undo" "be")
    
96.   (setq vv (ssadd))
    
97.   (setq ss (ssget))
    
98.   (setq pt (getpoint "\n基点:"))
    
99.   (setq p0 (trans pt 1 0))
    
100.   (setq lst (GetObjects ss))
     
101.   (setvar "lastPoint" p0)
     
102.   (setq i 0)
     
103.   
     
104.   ;;|
     
105.   (setq ret (ssJIG "CallBack"                                                ;回调函数名
     
106.                    "\n下一点(the next point): "                                ;提示符
     
107.                    "Set Exit"                                                ;关键字
     
108.                    (+ 1                                                        ;支持正交模式
     
109.                       2                                                        ;允许空回车
     
110.                       4                                                        ;Ctrl+C不作为取消
     
111.                       16                                                ;不限制点在图形外
     
112.                       128                                                ;接受3d坐标
     
113.                       2048                                              ;接受任意字符
     
114.                       65536                                                 ;输入作为距离  131072输入作为角度
     
115.                    )
     
116.                    2                                                        ;橡皮线效果
     
117.                    p0                                                        ;基点
     
118.             )
     
119.   );;|;
     
120. 
     
121.   ;|
     
122.   (setq ret (HFB_PointMonitor "CallBack" ss))                                ;比较同HFB_PointMonitor函数效果
     
123.   (setq ret (getpoint pt "\n第二点(2nd point): "))
     
124.   (HFB_PointMonitor);;|;
     
125. 
     
126.   ;;(setq ret (dyndraw "CallBack" "\n下一点:" "Set" (+ 1 2 4 16 128 2048 8192) 2 p0))        ;Compare to Alexander Rivilis's
     
127.   ;;(setq ret (draggen ss p0  "CallBack"  0 0 T   "\n下一点(the next point):"))              ;Compare to DragGen mothed
     
128.   ;;(Fsxm-Jig "CallBack" "指定顶点")                                                        ;Compare to FSXM's
     
129.   (cond
     
130.     ( (= (type ret) 'LIST)
     
131.       (if (= (type (cdr ret)) 'STR)
     
132.         (princ (strcat "\n你选择了关键字(You entered a keyword):" (cdr ret)  "\n"))
     
133.         (princ (strcat "\n最后返回点坐标是(The last position is): " (vl-princ-to-string ret)))
     
134.       )
     
135.     )
     
136.     ( (= (type ret) 'STR)
     
137.       (princ (strcat "\n你输入了字符(You entered a string): " ret "\n"))
     
138.     )
     
139.     (t
     
140.       (princ (strcat "\n其他返回值(Return other value):" (itoa ret) "\n"))
     
141.     )
     
142.   )
     
143.   (vla-EndUndoMark curdoc)                                                ;(command ".undo" "e")
     
144.   (gc)
     
145.   (princ)
     
146. )

;;;*********************************************************************<br /> ;;;SSJIG用法:                                                                <br /> ;;;(SSJIG 回调函数 [提示][关键字][控制类型][光标类型][基点][选择集])        <br /> ;;;除第一个参数必须外，其他的可以缺省。                                 <br /> ;;;---------------------------------------------------------------------<br /> ;;;1.  回调函数应该为字符串，且代表存在的函数,回调函数只有一个参数，这个<br /> ;;;参数为三维点，代表你现在鼠标所在位置.如果回调函数返回一个三维点，将更<br /> ;;;改基点位置,如果再附加一个字符串,将更改你的回调函数为字符串代表的函数.<br /> ;;;---------------------------------------------------------------------<br /> ;;;2.  提示--STR 类型，拖动过程中提示的信息。                           <br /> ;;;---------------------------------------------------------------------<br /> ;;;3.  关键字--STR 类型，具体用法可参考initget的关键字说明                <br /> ;;;---------------------------------------------------------------------<br /> ;;;4.  控制类型: --INT 类型                                                <br /> ;;;    kGovernedByOrthoMode           = 1,     正交模式是否设置            <br /> ;;;    kNullResponseAccepted           = 2,     空回车响应输入请求          <br /> ;;;    kDontEchoCancelForCtrlC           = 4,     Ctrl+C不作为取消            <br /> ;;;    kDontUpdateLastPoint           = 8,     不更新lastpoint变量         <br /> ;;;    kNoDwgLimitsChecking           = 16,    点不作限制，可在图形外      <br /> ;;;    kNoZeroResponseAccepted           = 32,    不允许输入零                <br /> ;;;    kNoNegativeResponseAccepted = 64,    不允许输入负值              <br /> ;;;    kAccept3dCoordinates           = 128,   接受三维坐标点              <br /> ;;;    kAcceptMouseUpAsPoint           = 256,   鼠标松开为输入点            <br /> ;;;    kAnyBlankTerminatesInput           = 512,   任何空白中断输入            <br /> ;;;    kInitialBlankTerminatesInput= 1024,  初始空白中断输入            <br /> ;;;    kAcceptOtherInputString           = 2048,  接受其他字符                <br /> ;;;    kGovernedByUCSDetect        = 4096,                              <br /> ;;;    kNoZDirectionOrtho          = 8192,                              <br /> ;;;    kImpliedFaceForUCSChange    = 16384,                             <br /> ;;;    kUseBasePointElevation      = 32768,                             <br /> ;;;    kAcqureDist                 = 65536, 输入作为距离，相当于getdist <br /> ;;;    kAcqureAngle                = 131072,输入作为角度，相当于getangle<br /> ;;;---------------------------------------------------------------------<br /> ;;;5.  光标类型:--INT 类型                                              <br /> ;;;    kNoSpecialCursor = -1,      // 普通类型                          <br /> ;;;    kCrosshair = 0,             // 全屏十字光标                      <br /> ;;;    kRectCursor = 1,            // 矩形                              <br /> ;;;    kRubberBand = 2,            // 橡皮筋                            <br /> ;;;    kNotRotated = 3,            // 未旋转形状                        <br /> ;;;    kTargetBox = 4,             // 选取形状                          <br /> ;;;    kRotatedCrosshair = 5,      // 旋转的形状.                       <br /> ;;;    kCrosshairNoRotate = 6,     // 强制为未旋转的十字形状.           <br /> ;;;    kInvisible = 7,             // 光标不可见.                       <br /> ;;;    kEntitySelect = 8,          // 拾取目标形状.                     <br /> ;;;    kParallelogram = 9,         // 平行四边形状.                     <br /> ;;;    kEntitySelectNoPersp = 10,  // 选择框，透视图中不可用.           <br /> ;;;    kPkfirstOrGrips = 11,       // 自动选择光标.                     <br /> ;;;    kCrosshairDashed = 12       // 虚线的十字光标                    <br /> ;;;---------------------------------------------------------------------<br /> ;;;6.  基点: --LIST 类型，三维点表                                      <br /> ;;;    用来动态输入时的基点（第一点）                                   <br /> ;;;    如果指定了基点，则表明指定点为第一点,否则读取变量LASTPOINT        <br /> ;;;---------------------------------------------------------------------<br /> ;;;7.  选择集:--ENAME 类型或者 PICKSRT类型，暂时保留                    <br /> ;;;    (如果指定了选择集，则对这个选择集更新)                            <br /> ;;;---------------------------------------------------------------------<br /> ;;;SSJIG函数的返回值，正常情况下返回三维点坐标，如果设置了可接受任意字符<br /> ;;;则输入字符结束后返回输入的字符串,如果设置了关键字，而用户输入了关键字<br /> ;;;则返回关键字。其他情况则返回整数值，代表意义如下：                   <br /> ;;;    kModeless       = -17,                                           <br /> ;;;    kNoChange       = -6,                                            <br /> ;;;    kCancel         = -4,                                            <br /> ;;;    kOther          = -3,                                            <br /> ;;;    kNull           = -1,                                            <br /> ;;;*********************************************************************<br /> <br /> <br /> ;;;*********************************************************************<br /> ;;;JIG测试移动选择集                                                        <br /> ;;;*********************************************************************<br /> (defun c:ttt(/ ss pt lst p0 ret i x ret)<br />   (setq *error*_Old *error*)                                                ;保存出错处理函数<br />   (setq *error* *error*_New)                                                ;设置新的出错处理<br />   ;;回调函数 for SSJig<br />   (defun CallBack (dynpt)<br />     (setq i (+ i 10000))<br />     (setq x (entmakex<br />               (list<br />                 '(0 . "LINE")<br />                 (cons 420 i)<br />                 (cons 10 (trans pt 1 0))<br />                 (cons 11 dynpt)<br />               )<br />             )<br />     )<br />     (if x (setq ss (ssadd x ss)))<br />     (foreach obj lst<br />       (vla-move obj (vlax-3d-point p0) (vlax-3d-point dynpt))<br />       ;;(vla-update obj)                                                ;无需用vla-update更新<br />     )<br />     (setq p0 dynpt)<br />     ss<br />   )<br />   <br />   (vla-StartUndoMark CurDoc)                                                ;(command ".undo" "be")<br />   (setq vv (ssadd))<br />   (setq ss (ssget))<br />   (setq pt (getpoint "\n基点:"))<br />   (setq p0 (trans pt 1 0))<br />   (setq lst (GetObjects ss))<br />   (setvar "lastPoint" p0)<br />   (setq i 0)<br />   <br />   ;;|<br />   (setq ret (ssJIG "CallBack"                                                ;回调函数名<br />                    "\n下一点(the next point): "                                ;提示符<br />                    "Set Exit"                                                ;关键字<br />                    (+ 1                                                        ;支持正交模式<br />                       2                                                        ;允许空回车<br />                       4                                                        ;Ctrl+C不作为取消<br />                       16                                                ;不限制点在图形外<br />                       128                                                ;接受3d坐标<br />                       2048                                              ;接受任意字符<br />                       65536                                                 ;输入作为距离  131072输入作为角度<br />                    )<br />                    2                                                        ;橡皮线效果<br />                    p0                                                        ;基点<br />             )<br />   );;|;<br /> <br />   ;|<br />   (setq ret (HFB_PointMonitor "CallBack" ss))                                ;比较同HFB_PointMonitor函数效果<br />   (setq ret (getpoint pt "\n第二点(2nd point): "))<br />   (HFB_PointMonitor);;|;<br /> <br />   ;;(setq ret (dyndraw "CallBack" "\n下一点:" "Set" (+ 1 2 4 16 128 2048 8192) 2 p0))        ;Compare to Alexander Rivilis's<br />   ;;(setq ret (draggen ss p0  "CallBack"  0 0 T   "\n下一点(the next point):"))              ;Compare to DragGen mothed<br />   ;;(Fsxm-Jig "CallBack" "指定顶点")                                                        ;Compare to FSXM's<br />   (cond<br />     ( (= (type ret) 'LIST)<br />       (if (= (type (cdr ret)) 'STR)<br />         (princ (strcat "\n你选择了关键字(You entered a keyword):" (cdr ret)  "\n"))<br />         (princ (strcat "\n最后返回点坐标是(The last position is): " (vl-princ-to-string ret)))<br />       )<br />     )<br />     ( (= (type ret) 'STR)<br />       (princ (strcat "\n你输入了字符(You entered a string): " ret "\n"))<br />     )<br />     (t<br />       (princ (strcat "\n其他返回值(Return other value):" (itoa ret) "\n"))<br />     )<br />   )<br />   (vla-EndUndoMark curdoc)                                                ;(command ".undo" "e")<br />   (gc)<br />   (princ)<br /> )

下面以QJChen的一个双向动态阵列为例子，演示如何将以前用(grread)做的程序稍加修改就变成了JIG了。
在此感谢Qjchen，如有冒犯版权，多加原谅。原帖地址如下：
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=85752

highflybir

三、DragGen函数让你的拖动大量物体时候更给力。
      XFormSS函数让你的对大量物体进行矩阵变换时快速有效。

1. ;;;*********************************************************************
   
2. ;;;Draggen用法:                                                         
   
3. ;;;(DragGen 选择集/图元 [基点] [回调函数] [光标类型] [拖动模式] [执行]  
   
4. ;;;除第一个参数必须外，其他的可以缺省。                                 
   
5. ;;;选择集/图元，基点和回调函数同SSJIG的用法。                           
   
6. ;;;光标类型--INT 类型，只有三种,0,十字;1,无;2,选取状                    
   
7. ;;;拖动模式--INT 类型，0,平移;1,旋转;2,缩放;3镜像;以后再添加            
   
8. ;;;执行与否--如果此参数空或为nil,仅显示拖动效果,而不实际执行变换        
   
9. ;;;此函数用以对大量选择集进行拖动等变换效果，尤为明显，快于SSJIG.      
   
10. ;;;关键字和控制位的设置请在前面加initget，同getpoint之类的函数。        
    
11. ;;;---------------------------------------------------------------------
    
12. ;;;回调函数返回值，如果返回点，依据拖动模式对选择集作几何变换.         
    
13. ;;;如果返回选择集/图元,则对他们作更新。如果返回一个标准的CAD变换矩阵，则
    
14. ;;;对选择集/图元做指定的矩阵变换。（如错切，镜像，透视等）              
    
15. ;;;---------------------------------------------------------------------
    
16. ;;;函数最终返回值为当前点位置和变换的矩阵表。                           
    
17. ;;;这个函数要求用户对矩阵变换有一定了解。                              
    
18. ;;;需要特殊说明的是：回调函数传入的点，是一个UCS下的点坐标。            
    
19. ;;;*********************************************************************
    
20. 
    
21. ;;;自定义的回调函数 for DragGen
    
22. (defun CallBack1 (DynPt)
    
23.   (redraw)
    
24.   (grdraw pt dynpt -1)
    
25.   (trans dynpt 1 0)
    
26. )
    
27. (vl-acad-defun 'CallBack1)
    
28. 
    
29. 
    
30. ;;;*********************************************************************
    
31. ;;;测试Draggen--移动                                                        
    
32. ;;;*********************************************************************
    
33. (defun C:TCC(/ ss p0 ret pt)
    
34.   (if (and (setq ss (ssget))
    
35.            (RedrawSel ss 3)
    
36.            (setq pt (getpoint "\n指定基点:"))
    
37.       )
    
38.     (progn
    
39.       (setq p0 (trans pt 1 0))
    
40.       (setvar "lastPoint" pt)
    
41.       (prompt "\n指定第二个点:")   
    
42.       (setq ret (draggen ss p0 "CallBack1" 0 0 T))
    
43.       (princ ret)
    
44.       (RedrawSel ss 4)
    
45.     )
    
46.   )
    
47.   (redraw)
    
48.   (princ)
    
49. )
    
50. 
    
51. ;;;*********************************************************************
    
52. ;;;测试Draggen--旋转                                                        
    
53. ;;;*********************************************************************
    
54. (defun C:TRR(/ ss p0 ret pt)
    
55.   (if (and (setq ss (ssget))
    
56.            (RedrawSel ss 3)
    
57.            (setq pt (getpoint "\n指定基点:"))
    
58.       )
    
59.     (progn
    
60.       (setq p0 (trans pt 1 0))
    
61.       (setvar "lastPoint" pt)
    
62.       (initget "Copy Reference")
    
63.       (prompt "\n指定旋转角度，或 [复制(C)/参照(R)]:")
    
64.       (setq ret (draggen ss p0 "CallBack1" 1 0 T))
    
65.       (princ ret)
    
66.       (RedrawSel ss 4)
    
67.     )
    
68.   )
    
69.   (redraw)
    
70.   (gc)
    
71.   (princ)
    
72. )
    
73. 
    
74. ;;;*********************************************************************
    
75. ;;;测试Draggen--图元更新                                                  
    
76. ;;;*********************************************************************
    
77. (defun C:TGG(/ ss p0 pt lst ret)
    
78.   ;;自定义回调函数  for draggen --更新选择集
    
79.   (defun CallBack (DynPt)
    
80.     (redraw)
    
81.     (grdraw pt dynpt -1)
    
82.     (foreach obj lst
    
83.       (vla-move obj (vlax-3d-point p0) (vlax-3d-point (trans dynpt 1 0)))
    
84.     )
    
85.     (setq p0 (trans dynpt 1 0))
    
86.     ss
    
87.   )
    
88. 
    
89.   (vla-StartUndoMark curDoc)
    
90.   ;;程序执行部分
    
91.   (if (and (setq ss (ssget))
    
92.            (RedrawSel ss 3)
    
93.            (setq pt (getpoint "\n指定基点:"))
    
94.       )
    
95.     (progn
    
96.       (setq p0 (trans pt 1 0))
    
97.       (setvar "lastPoint" pt)
    
98.       (setq lst (GetObjects ss))
    
99.       (setq ret (draggen ss p0 "CallBack" 0 0 T "\n指定第二个点:"))
    
100.       (princ ret)
     
101.       (RedrawSel ss 4)
     
102.     )
     
103.   )
     
104.   (vla-EndUndoMark curdoc)
     
105.   (redraw)
     
106.   (gc)
     
107.   (princ)
     
108. )
     
109. 
     
110. ;;;*********************************************************************
     
111. ;;;测试Draggen--矩阵变换                                                
     
112. ;;;*********************************************************************
     
113. (defun C:TMM(/ ss p0 pt ret)
     
114.   ;;自定义回调函数  for draggen --矩阵变换
     
115.   (defun CallBack (DynPt / vec)
     
116.     (redraw)
     
117.     (grdraw pt dynpt -1)
     
118.     (setq vec (mapcar '- (trans dynpt 1 0) p0))
     
119.     (list
     
120.       (list 1. 0. 0. (car vec))
     
121.       (list 0. 1. 0. (cadr vec))
     
122.       (list 0. 0. 1. 0.)
     
123.       (list 0. 0. 0. 1.)
     
124.     )
     
125.   )
     
126.   
     
127.   ;;程序执行部分
     
128.   (if (and (setq ss (ssget))
     
129.            (RedrawSel ss 3)
     
130.            (setq pt (getpoint "\n指定基点:"))
     
131.       )
     
132.     (progn
     
133.       (setq p0 (trans pt 1 0))
     
134.       (setvar "lastPoint" pt)
     
135.       (prompt "\n指定第二个点:")
     
136.       (setq ret (draggen ss p0 "CallBack" 0 0 T))
     
137.       (princ ret)
     
138.       (RedrawSel ss 4)
     
139.     )
     
140.   )
     
141.   (redraw)
     
142.   (gc)
     
143.   (princ)
     
144. )
     
145. 
     
146. ;;;*********************************************************************
     
147. ;;;测试XForm                                                               
     
148. ;;;此函数用来对大量选择集的变换。因为vla-transformby,vla-move,vla-rotate
     
149. ;;;对这样的需求在速度上不能满足要求时，需要用一个arx来高效地执行。      
     
150. ;;;另外，也用于command命令不能使用的场合。                              
     
151. ;;;经测试速度，对大量图元的变换，用此能提高速度20倍，甚至更多。         
     
152. ;;;用法:(Xfrom Selection Matrix_List)                                   
     
153. ;;;            Selection   ------非空选择集        PICKSET              
     
154. ;;;            Matrix_List ------变换矩阵表(4X4)   LIST                 
     
155. ;;;两个参数不能缺省，变换矩阵为标准的CAD等比矩阵.                       
     
156. ;;;返回T代表成功变换，nil变换失败，此时请检测选择集中是否有被锁定的图元,
     
157. ;;;或者变换矩阵为标准的CAD矩阵，为统一比例变换的矩阵。                  
     
158. ;;;*********************************************************************
     
159. (defun C:TXX (/ sel pt1 pt2 vec)
     
160.   (if (and (setq sel (ssget))
     
161.            (setq pt1 (getpoint "\n基点:"))
     
162.            (setq pt2 (getpoint "\n目标点:"))  
     
163.       )
     
164.     (progn
     
165.       (redraw)
     
166.       (setq vec (mapcar '- pt2 pt1))
     
167.       (setq vec (trans vec 1 0 T))
     
168.       (grdraw pt1 pt2 1)
     
169.       (XformSS sel
     
170.             (list
     
171.               (list 1. 0. 0. (car vec))
     
172.               (list 0. 1. 0. (cadr vec))
     
173.               (list 0. 0. 1. 0.)
     
174.               (list 0. 0. 0. 1.)
     
175.             )  
     
176.       )
     
177.     )
     
178.   )
     
179. )

;;;*********************************************************************<br /> ;;;Draggen用法:                                                         <br /> ;;;(DragGen 选择集/图元 [基点] [回调函数] [光标类型] [拖动模式] [执行]  <br /> ;;;除第一个参数必须外，其他的可以缺省。                                 <br /> ;;;选择集/图元，基点和回调函数同SSJIG的用法。                           <br /> ;;;光标类型--INT 类型，只有三种,0,十字;1,无;2,选取状                    <br /> ;;;拖动模式--INT 类型，0,平移;1,旋转;2,缩放;3镜像;以后再添加            <br /> ;;;执行与否--如果此参数空或为nil,仅显示拖动效果,而不实际执行变换        <br /> ;;;此函数用以对大量选择集进行拖动等变换效果，尤为明显，快于SSJIG.       <br /> ;;;关键字和控制位的设置请在前面加initget，同getpoint之类的函数。        <br /> ;;;---------------------------------------------------------------------<br /> ;;;回调函数返回值，如果返回点，依据拖动模式对选择集作几何变换.          <br /> ;;;如果返回选择集/图元,则对他们作更新。如果返回一个标准的CAD变换矩阵，则<br /> ;;;对选择集/图元做指定的矩阵变换。（如错切，镜像，透视等）              <br /> ;;;---------------------------------------------------------------------<br /> ;;;函数最终返回值为当前点位置和变换的矩阵表。                           <br /> ;;;这个函数要求用户对矩阵变换有一定了解。                               <br /> ;;;需要特殊说明的是：回调函数传入的点，是一个UCS下的点坐标。            <br /> ;;;*********************************************************************<br /> <br /> ;;;自定义的回调函数 for DragGen<br /> (defun CallBack1 (DynPt)<br />   (redraw)<br />   (grdraw pt dynpt -1)<br />   (trans dynpt 1 0)<br /> )<br /> (vl-acad-defun 'CallBack1)<br /> <br /> <br /> ;;;*********************************************************************<br /> ;;;测试Draggen--移动                                                        <br /> ;;;*********************************************************************<br /> (defun C:TCC(/ ss p0 ret pt)<br />   (if (and (setq ss (ssget))<br />            (RedrawSel ss 3)<br />            (setq pt (getpoint "\n指定基点:"))<br />       )<br />     (progn<br />       (setq p0 (trans pt 1 0))<br />       (setvar "lastPoint" pt)<br />       (prompt "\n指定第二个点:")   <br />       (setq ret (draggen ss p0 "CallBack1" 0 0 T))<br />       (princ ret)<br />       (RedrawSel ss 4)<br />     )<br />   )<br />   (redraw)<br />   (princ)<br /> )<br /> <br /> ;;;*********************************************************************<br /> ;;;测试Draggen--旋转                                                        <br /> ;;;*********************************************************************<br /> (defun C:TRR(/ ss p0 ret pt)<br />   (if (and (setq ss (ssget))<br />            (RedrawSel ss 3)<br />            (setq pt (getpoint "\n指定基点:"))<br />       )<br />     (progn<br />       (setq p0 (trans pt 1 0))<br />       (setvar "lastPoint" pt)<br />       (initget "Copy Reference")<br />       (prompt "\n指定旋转角度，或 [复制(C)/参照(R)]:")<br />       (setq ret (draggen ss p0 "CallBack1" 1 0 T))<br />       (princ ret)<br />       (RedrawSel ss 4)<br />     )<br />   )<br />   (redraw)<br />   (gc)<br />   (princ)<br /> )<br /> <br /> ;;;*********************************************************************<br /> ;;;测试Draggen--图元更新                                                  <br /> ;;;*********************************************************************<br /> (defun C:TGG(/ ss p0 pt lst ret)<br />   ;;自定义回调函数  for draggen --更新选择集<br />   (defun CallBack (DynPt)<br />     (redraw)<br />     (grdraw pt dynpt -1)<br />     (foreach obj lst<br />       (vla-move obj (vlax-3d-point p0) (vlax-3d-point (trans dynpt 1 0)))<br />     )<br />     (setq p0 (trans dynpt 1 0))<br />     ss<br />   )<br /> <br />   (vla-StartUndoMark curDoc)<br />   ;;程序执行部分<br />   (if (and (setq ss (ssget))<br />            (RedrawSel ss 3)<br />            (setq pt (getpoint "\n指定基点:"))<br />       )<br />     (progn<br />       (setq p0 (trans pt 1 0))<br />       (setvar "lastPoint" pt)<br />       (setq lst (GetObjects ss))<br />       (setq ret (draggen ss p0 "CallBack" 0 0 T "\n指定第二个点:"))<br />       (princ ret)<br />       (RedrawSel ss 4)<br />     )<br />   )<br />   (vla-EndUndoMark curdoc)<br />   (redraw)<br />   (gc)<br />   (princ)<br /> )<br /> <br /> ;;;*********************************************************************<br /> ;;;测试Draggen--矩阵变换                                                <br /> ;;;*********************************************************************<br /> (defun C:TMM(/ ss p0 pt ret)<br />   ;;自定义回调函数  for draggen --矩阵变换<br />   (defun CallBack (DynPt / vec)<br />     (redraw)<br />     (grdraw pt dynpt -1)<br />     (setq vec (mapcar '- (trans dynpt 1 0) p0))<br />     (list<br />       (list 1. 0. 0. (car vec))<br />       (list 0. 1. 0. (cadr vec))<br />       (list 0. 0. 1. 0.)<br />       (list 0. 0. 0. 1.)<br />     )<br />   )<br />   <br />   ;;程序执行部分<br />   (if (and (setq ss (ssget))<br />            (RedrawSel ss 3)<br />            (setq pt (getpoint "\n指定基点:"))<br />       )<br />     (progn<br />       (setq p0 (trans pt 1 0))<br />       (setvar "lastPoint" pt)<br />       (prompt "\n指定第二个点:")<br />       (setq ret (draggen ss p0 "CallBack" 0 0 T))<br />       (princ ret)<br />       (RedrawSel ss 4)<br />     )<br />   )<br />   (redraw)<br />   (gc)<br />   (princ)<br /> )<br /> <br /> ;;;*********************************************************************<br /> ;;;测试XForm                                                                <br /> ;;;此函数用来对大量选择集的变换。因为vla-transformby,vla-move,vla-rotate<br /> ;;;对这样的需求在速度上不能满足要求时，需要用一个arx来高效地执行。      <br /> ;;;另外，也用于command命令不能使用的场合。                              <br /> ;;;经测试速度，对大量图元的变换，用此能提高速度20倍，甚至更多。         <br /> ;;;用法:(Xfrom Selection Matrix_List)                                   <br /> ;;;            Selection   ------非空选择集        PICKSET              <br /> ;;;            Matrix_List ------变换矩阵表(4X4)   LIST                 <br /> ;;;两个参数不能缺省，变换矩阵为标准的CAD等比矩阵.                       <br /> ;;;返回T代表成功变换，nil变换失败，此时请检测选择集中是否有被锁定的图元,<br /> ;;;或者变换矩阵为标准的CAD矩阵，为统一比例变换的矩阵。                  <br /> ;;;*********************************************************************<br /> (defun C:TXX (/ sel pt1 pt2 vec)<br />   (if (and (setq sel (ssget))<br />            (setq pt1 (getpoint "\n基点:"))<br />            (setq pt2 (getpoint "\n目标点:"))  <br />       )<br />     (progn<br />       (redraw)<br />       (setq vec (mapcar '- pt2 pt1))<br />       (setq vec (trans vec 1 0 T))<br />       (grdraw pt1 pt2 1)<br />       (XformSS sel<br />             (list<br />               (list 1. 0. 0. (car vec))<br />               (list 0. 1. 0. (cadr vec))<br />               (list 0. 0. 1. 0.)<br />               (list 0. 0. 0. 1.)<br />             )  <br />       )<br />     )<br />   )<br /> )

qjchen

敬仰不止
以前我都只能是用外国人的程序实现，现在高飞鸟兄带来更好的程序
谢谢~

chpmould

支持，很给力,对LISP来说是一种弥补.

sen.sam

感觉grread函数外国人用得出神入化，有了版主的函数，我们也可以做出出神入化的动态效果

carrot1983

非常强悍，一直想学习C#就是为了解决两大难题：
1. grread函数的局限。
2. DCL无法实现非模态。

谢谢高飞鸟