【飞鸟集】心随我动--为LISP定制的动态输入,拖拉和动态信息函数(更新至20130731)
本帖最后由 highflybir 于 2013-8-1 09:09 编辑源码已经贴在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之类的函数时光标所在位置，并对其反应，形成各种特殊的效果，譬如动态拖拉，动态信息等等。
这个函数的优点在于，回调函数不一定要在命令状态下就可以运行，就像非模态一样。
(vl-load-com)
(if (null CurDoc)
(setq CurDoc
(vla-get-ActiveDocument (vlax-get-acad-object)))
)
;;;*********************************************************************
;;;HFB_PointMonitor用法:
;;;(HFB_PointMonitor [回调函数] [选择集/图元])
;;;不带参数的(HFB_PointMonitor)为关闭监视事件
;;;第一个参数为回调函数名称，应该为字符串，且存在的函数
;;;回调函数只有一个参数，这个参数为三维点，代表你现在鼠标所在位置.如果返
;;;回值为选择集或者图元，将更改鼠标捕捉排除的物体为你返回值所代表的物体.
;;;如果返回值为字符串，说明将把字符串的信息附加到CAD的tooltip上。
;;;第二个参数可以缺省，缺省的话，将不排除鼠标捕捉,不过你以后仍可指定.
;;;*********************************************************************
;;;*********************************************************************
;;;图元信息显示
;;;*********************************************************************
(defun c:Info(/ ret)
(defun InfoCallback (dynpt / txt lst dat)
(setq txt (vl-princ-to-string (mapcar 'rtos dynpt)))
(setq txt (strcat "\n当前点的坐标是：" txt))
(if (setq lst (nentselp dynpt))
(progn
(setq dat (entget (car lst)))
(strcat txt "\n这个图元的类型是：" (cdr (assoc 0 dat)))
)
txt
)
)
(setq ret (HFB_PointMonitor "InfoCallback"))
(prompt "\n如果要关闭监视，请用函数(HFB_PointMonitor)")
(princ)
)
;;;*********************************************************************
;;;自定义光标
;;;*********************************************************************
(defun C:MyCursorOn(/ ret ent) ;打开光标
(defun CursorCallback (dynpt / height insPnt)
(if (not (vlax-erased-p txtobj))
(progn
(setq height (/ (getvar 'viewsize) 50))
(setq insPnt (mapcar '+ dynpt (list (/ height 2) (/ height 2) 0)))
(vlax-put txtobj 'InsertionPoint inspnt)
(vlax-put txtobj 'heightheight)
)
(HFB_PointMonitor)
)
)
(setq ent (entmakex
(list
'(0 . "text")
'(1 . "highflybird")
'(62 . 3)
(cons 10 (getvar 'lastpoint))
(cons 40 (/ (getvar 'viewsize) 50)) ;for a standard dwg
)
)
)
(setq txtobj (vlax-ename->vla-object ent))
(setq ret (HFB_PointMonitor "CursorCallback" ent))
(prompt "\n如果要关闭自定义光标，请用命令MyCursorOff.")
(princ)
)
(defun C:MyCursorOff(/ ret) ;关闭光标
(HFB_PointMonitor)
(and (not (vlax-erased-p txtobj)) (vla-erase txtobj))
(setq txtobj nil)
(princ)
)
;;;*********************************************************************
;;;带回调函数的GetXXX测试(模拟move命令)
;;;*********************************************************************
(defun C:GetXXX(/ OBJLST P0 PT SS)
(setq *error*_Old *error*) ;保存出错处理函数
(setq *error* *error*_New) ;设置新的出错处理
(defun PointCallback (dynpt) ;回调函数
(foreach obj objlst
(vla-move obj (vlax-3d-point p0) (vlax-3d-point dynpt));移动物体
)
(setq p0 dynpt)
)
(vla-StartUndoMark CurDoc) ;撤销编组开始
(if (and (setq ss (ssget))
(setq pt (getpoint "\n第一点(1st Point): "))
)
(progn
(setq objlst (GetObjects ss))
(setq p0 (trans pt 1 0)) ;需要转化到世界坐标系
;;设置回调函数名和需要排除捕捉的选择集
(setq ret (HFB_PointMonitor "PointCallback" ss)) ;第一个参数是回调函数名，第二个参数是可以省略（如果不需要排除捕捉的话）
;;现在就可以看到动态效果了
(setq ret (getpoint pt "\n第二点(2nd point): ")) ;此处可以是lisp的交互函数，例如getpoint,getangle之类。
;;最后关闭监视
(HFB_PointMonitor)
(princ ret)
)
)
(vla-EndUndoMark curdoc) ;编组结束
(princ)
) 给力.
CAD2004加载不成功. 2006加载成功. 本帖最后由 Gu_xl 于 2013-5-20 22:54 编辑
动态信息查询,由一个经典的yad动态信息查询函数改编而来!
;;;飞鸟集]心随我动--为LISP定制的动态输入，动态拖拉和动态信息函数之应用---动态信息查询
;;;由一个经典的yad动态信息查询函数改编而来！改编： Gu_xl 2011.11.19
(defun InfoCallBak (PT /TOANG DIS ENT)
(defun toang(ang i)
(if (= i 1)
(* ang (/ 180 pi))
(* ang (/ pi 180))
)
)
(defun gxl-dxf (ent i)
(cdr (assoc i (entget ent)))
)
(defun dis (ENT / MJBL OBJ LAYNM NAME LST)
(if (= mjdw 1000) (setq mjbl 1000000) (setq mjbl 1))
(setq obj (vlax-ename->vla-object ent))
(setq laynm (strcat "图层:" (gxl-dxf ent 8)) name (gxl-dxf ent 0))
(cond
((= name "3DFACE")
(setq lst (list "【三维面】" laynm))
)
((= name "3DSOLID")
(setq lst (list "【三维实体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
)
((= name "ACAD_PROXY_ENTITY")
(setq lst (list "【代理】" laynm))
)
((= name "ARC")
(setq lst (list "【圆弧】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
(strcat "圆心角:" (rtos (toang (vla-get-TotalAngle obj) 1) 2 1) "度")
(strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
(strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
(strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 0))
(strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
))
)
((= name "ATTDEF")
(setq lst (list "【属性定义】" laynm (strcat "标签:" (vla-get-TagString obj))
(strcat "提示:" (vla-get-PromptString obj))
(strcat "缺省值:" (vla-get-TextString obj))
(strcat "高度:" (rtos (vla-get-Height obj) 2 0))
(strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
(strcat "文字样式:" (vla-get-StyleName obj))
))
)
((= name "ATTRIB")
(setq lst (list "【属性】" laynm (strcat "标签:" (vla-get-TagString obj))
(strcat "缺省值:" (vla-get-TextString obj))
(strcat "高度:" (rtos (vla-get-Height obj) 2 0))
(strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
(strcat "文字样式:" (vla-get-StyleName obj))
))
)
((= name "BODY")
(setq lst (list "【体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
)
((= name "CIRCLE")
(setq lst (list "【圆】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
(strcat "周长:" (rtos (vla-get-Circumference obj) 2 0))
(strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
))
)
((= name "DIMENSION")
(setq lst (list "【尺寸标注】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
(strcat "文字样式:" (vla-get-TextStyle obj))
(strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
(strcat "替带文字:" (if (= (gxl-dxf ent 1) "") "无" (gxl-dxf ent 1)))
))
)
((= name "ELLIPSE")
(setq lst (list "【椭圆】" laynm (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 0))
(strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 0))
(strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
(strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
(strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
))
)
((= name "HATCH")
(setq lst (list "【图案填充】" laynm (strcat "图案名称:" (vla-get-PatternName obj))
(strcat "角度:" (rtos (toang (vla-get-PatternAngle obj) 1) 2 1))
(strcat "比例:" (rtos (vla-get-PatternScale obj) 2 0))
(strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))
(strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))
))
)
((= name "IMAGE")
(setq lst (list "【图像】" laynm (strcat "图像大小:" (rtos (car (gxl-dxf ent 13)) 2 0) "X" (rtos (cadr (gxl-dxf ent 13)) 2 0))))
)
((= name "INSERT")
(setq lst (list "【图块】" laynm (strcat "名称:" (gxl-dxf ent 2))
(strcat "X比例:" (rtos (gxl-dxf ent 41) 2 1))
(strcat "Y比例:" (rtos (gxl-dxf ent 42) 2 1))
(strcat "Z比例:" (rtos (gxl-dxf ent 43) 2 1))
(strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
))
)
((= name "LEADER")
(setq lst (list "【引线】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
(strcat "引线类型:" (gxl-dxf (list (cons 0 "折线") (cons 1 "样条曲线")) (gxl-dxf ent 72)))
))
)
((= name "LINE")
(setq lst (list "【直线】" laynm (strcat "长度:" (rtos (vla-get-length obj) 2 0))
(strcat "角度:" (rtos (toang (vla-get-angle obj) 1) 2 1) "度")
))
)
((= name "LWPOLYLINE")
(setq lst (list "【多段线】" laynm (strcat "常量宽度:" (if (gxl-dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 0) "变宽度"))
(strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
(strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
))
)
((= name "MLINE")
(setq lst (list "【多线】" laynm (strcat "多线样式:" (vla-get-StyleName obj))
(strcat "比例因子:" (rtos (gxl-dxf ent 40) 2 1))
(strcat "对齐:" (nth (gxl-dxf ent 70) '("上" "零" "下")))
))
)
((= name "MTEXT")
(setq lst (list "【多行文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
(strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
(strcat "样式:" (vla-get-StyleName obj))
))
)
((or (= name "OLEFRame") (= name "OLE2FRame"))
(setq lst (list "【OLE边框】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
)
((= name "POINT")
(setq lst (list "【点】" laynm))
)
((= name "POLYLINE")
(setq lst (list "【三维多段线】" laynm))
)
((= name "RAY")
(setq lst (list "【射线】" laynm))
)
((= name "REGION")
(setq lst (list "【面域】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
)
((= name "SHAPE")
(setq lst (list "【形】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
(strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
(strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
))
)
((= name "SOLID")
(setq lst (list "【实体】" laynm))
)
((= name "SPLINE")
(setq lst (list "【样条曲线】" laynm (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
(strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))
(strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
))
)
((= name "TEXT")
(setq lst (list "【文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
(strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
(strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
(strcat "样式:" (vla-get-StyleName obj))
(strcat "对齐:" (nth (vla-get-Alignment obj) '("Left" "Center" "Right" "Aligned" "Middle" "Fit" "TopLeft" "TopCenter" "TopRight"
"MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")))
))
)
((= name "TOLERANCE")
(setq lst (list "【公差】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
(strcat "文字样式:" (vla-get-TextStyle obj))
(strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
))
)
((= name "TRACE")
(setq lst (list "【宽线】" laynm))
)
((= name "VERTEX")
(setq lst (list "【顶点】" laynm (strcat "起始宽度:" (rtos (gxl-dxf ent 40) 2 0))
(strcat "结束宽度:" (rtos (gxl-dxf ent 41) 2 0))
(strcat "凸度:" (rtos (gxl-dxf ent 42) 2 1))
))
)
((= name "XLINE")
(setq lst (list "【构造线】" laynm))
)
(T
(setq lst (list "【未知对象】" laynm))
)
)
(apply 'strcat (mapcar '(lambda (x)(strcat x "\n")) lst))
)
(if (setq ent (nentselp pt)
ent (if (and ent (= (type (last (last ent))) 'ename))
(last (last ent))
(car ent)
)
)
(dis ent)
)
)
(defun c:DynInfo(/ loaded openview closeview)
(defun openview(/ arxs)
(VL-ACAD-DEFUN 'InfoCallBak)
(if (null mjdw)
(progn
(INITget 7 "Yes No")
(setq Mjdw (getKword "\n以毫米为单位?[<Yes/No>]<No>:"))
(if (= mjdw "Yes")
(setq mjdw 1000)
(setq mjdw 999)
)
)
)
(HFB_PointMonitor)
(HFB_PointMonitor "InfoCallBak")
(princ "\n动态信息查看打开！")
(setq *dynViewEnt* t)
)
(defun closeview()
(HFB_PointMonitor)
(princ "\n动态信息查看关闭！")
(setq *dynViewEnt* nil)
)
(cond ((= 16 (atoi (getvar 'acadver)))
(if (not (member "dynarxfor2004-2006.arx" (arx)))
(if (setq fn (findfile "dynarxfor2004-2006.arx"))
(setq loaded (arxload fn "1"))
(setq loaded "2")
)
(setq loaded "3") ;_ 已加载
)
)
((= 17 (atoi (getvar 'acadver)))
(if (not (member "dynarxfor2007-2009.arx" (arx)))
(if (setq fn (findfile "dynarxfor2007-2009.arx"))
(setq loaded (arxload fn "1"))
(setq loaded "2")
)
(setq loaded "3")
)
)
((= 18 (atoi (getvar 'acadver)))
(if (= "x86" (getenv "PROCESSOR_ARCHITECTURE"))
(if (not (member "dynarxfor2010-2012x32.arx" (arx)))
(if (setq fn (findfile "dynarxfor2010-2012x32.arx"))
(setq loaded (arxload fn "1"))
(setq loaded "2")
)
(setq loaded "3")
)
(if (not (member "dynarxfor2010-2012x64.arx" (arx)))
(if (setq fn (findfile "dynarxfor2010-2012x64.arx"))
(setq loaded
(arxload (findfile "dynarxfor2010-2012x64.arx")
"1"))
(setq loaded "2")
)
(setq loaded "3")
)
)
)
(t (setq loaded "2"))
)
(if (not (or (= "1" loaded) (= "2" loaded)))
(if *dynViewEnt*
(closeview)
(openview)
)
)
(princ)
)
支持，很给力 本帖最后由 highflybir 于 2011-11-18 09:54 编辑
二、让LISP也能JIG,JIG是arx或者.net编程的一个函数，用来在采点过程中与用户交互的一个动态拖拉技术。
JIG的优势在于：可以动态输入，功能齐全，与用户交互性较好，直观方便。
;;;*********************************************************************
;;;SSJIG用法:
;;;(SSJIG 回调函数 [提示][关键字][控制类型][光标类型][基点][选择集])
;;;除第一个参数必须外，其他的可以缺省。
;;;---------------------------------------------------------------------
;;;1.回调函数应该为字符串，且代表存在的函数,回调函数只有一个参数，这个
;;;参数为三维点，代表你现在鼠标所在位置.如果回调函数返回一个三维点，将更
;;;改基点位置,如果再附加一个字符串,将更改你的回调函数为字符串代表的函数.
;;;---------------------------------------------------------------------
;;;2.提示--STR 类型，拖动过程中提示的信息。
;;;---------------------------------------------------------------------
;;;3.关键字--STR 类型，具体用法可参考initget的关键字说明
;;;---------------------------------------------------------------------
;;;4.控制类型: --INT 类型
;;; kGovernedByOrthoMode = 1, 正交模式是否设置
;;; kNullResponseAccepted = 2, 空回车响应输入请求
;;; kDontEchoCancelForCtrlC = 4, Ctrl+C不作为取消
;;; kDontUpdateLastPoint = 8, 不更新lastpoint变量
;;; kNoDwgLimitsChecking = 16, 点不作限制，可在图形外
;;; kNoZeroResponseAccepted = 32, 不允许输入零
;;; kNoNegativeResponseAccepted = 64, 不允许输入负值
;;; kAccept3dCoordinates = 128, 接受三维坐标点
;;; kAcceptMouseUpAsPoint = 256, 鼠标松开为输入点
;;; kAnyBlankTerminatesInput = 512, 任何空白中断输入
;;; kInitialBlankTerminatesInput= 1024,初始空白中断输入
;;; kAcceptOtherInputString = 2048,接受其他字符
;;; kGovernedByUCSDetect = 4096,
;;; kNoZDirectionOrtho = 8192,
;;; kImpliedFaceForUCSChange = 16384,
;;; kUseBasePointElevation = 32768,
;;; kAcqureDist = 65536, 输入作为距离，相当于getdist
;;; kAcqureAngle = 131072,输入作为角度，相当于getangle
;;;---------------------------------------------------------------------
;;;5.光标类型:--INT 类型
;;; kNoSpecialCursor = -1, // 普通类型
;;; kCrosshair = 0, // 全屏十字光标
;;; kRectCursor = 1, // 矩形
;;; kRubberBand = 2, // 橡皮筋
;;; kNotRotated = 3, // 未旋转形状
;;; kTargetBox = 4, // 选取形状
;;; kRotatedCrosshair = 5, // 旋转的形状.
;;; kCrosshairNoRotate = 6, // 强制为未旋转的十字形状.
;;; kInvisible = 7, // 光标不可见.
;;; kEntitySelect = 8, // 拾取目标形状.
;;; kParallelogram = 9, // 平行四边形状.
;;; kEntitySelectNoPersp = 10,// 选择框，透视图中不可用.
;;; kPkfirstOrGrips = 11, // 自动选择光标.
;;; kCrosshairDashed = 12 // 虚线的十字光标
;;;---------------------------------------------------------------------
;;;6.基点: --LIST 类型，三维点表
;;; 用来动态输入时的基点（第一点）
;;; 如果指定了基点，则表明指定点为第一点,否则读取变量LASTPOINT
;;;---------------------------------------------------------------------
;;;7.选择集:--ENAME 类型或者 PICKSRT类型，暂时保留
;;; (如果指定了选择集，则对这个选择集更新)
;;;---------------------------------------------------------------------
;;;SSJIG函数的返回值，正常情况下返回三维点坐标，如果设置了可接受任意字符
;;;则输入字符结束后返回输入的字符串,如果设置了关键字，而用户输入了关键字
;;;则返回关键字。其他情况则返回整数值，代表意义如下：
;;; kModeless = -17,
;;; kNoChange = -6,
;;; kCancel = -4,
;;; kOther = -3,
;;; kNull = -1,
;;;*********************************************************************
;;;*********************************************************************
;;;JIG测试移动选择集
;;;*********************************************************************
(defun c:ttt(/ ss pt lst p0 ret i x ret)
(setq *error*_Old *error*) ;保存出错处理函数
(setq *error* *error*_New) ;设置新的出错处理
;;回调函数 for SSJig
(defun CallBack (dynpt)
(setq i (+ i 10000))
(setq x (entmakex
(list
'(0 . "LINE")
(cons 420 i)
(cons 10 (trans pt 1 0))
(cons 11 dynpt)
)
)
)
(if x (setq ss (ssadd x ss)))
(foreach obj lst
(vla-move obj (vlax-3d-point p0) (vlax-3d-point dynpt))
;;(vla-update obj) ;无需用vla-update更新
)
(setq p0 dynpt)
ss
)
(vla-StartUndoMark CurDoc) ;(command ".undo" "be")
(setq vv (ssadd))
(setq ss (ssget))
(setq pt (getpoint "\n基点:"))
(setq p0 (trans pt 1 0))
(setq lst (GetObjects ss))
(setvar "lastPoint" p0)
(setq i 0)
;;|
(setq ret (ssJIG "CallBack" ;回调函数名
"\n下一点(the next point): " ;提示符
"Set Exit" ;关键字
(+ 1 ;支持正交模式
2 ;允许空回车
4 ;Ctrl+C不作为取消
16 ;不限制点在图形外
128 ;接受3d坐标
2048 ;接受任意字符
65536 ;输入作为距离131072输入作为角度
)
2 ;橡皮线效果
p0 ;基点
)
);;|;
;|
(setq ret (HFB_PointMonitor "CallBack" ss)) ;比较同HFB_PointMonitor函数效果
(setq ret (getpoint pt "\n第二点(2nd point): "))
(HFB_PointMonitor);;|;
;;(setq ret (dyndraw "CallBack" "\n下一点:" "Set" (+ 1 2 4 16 128 2048 8192) 2 p0)) ;Compare to Alexander Rivilis's
;;(setq ret (draggen ss p0"CallBack"0 0 T "\n下一点(the next point):")) ;Compare to DragGen mothed
;;(Fsxm-Jig "CallBack" "指定顶点") ;Compare to FSXM's
(cond
( (= (type ret) 'LIST)
(if (= (type (cdr ret)) 'STR)
(princ (strcat "\n你选择了关键字(You entered a keyword):" (cdr ret)"\n"))
(princ (strcat "\n最后返回点坐标是(The last position is): " (vl-princ-to-string ret)))
)
)
( (= (type ret) 'STR)
(princ (strcat "\n你输入了字符(You entered a string): " ret "\n"))
)
(t
(princ (strcat "\n其他返回值(Return other value):" (itoa ret) "\n"))
)
)
(vla-EndUndoMark curdoc) ;(command ".undo" "e")
(gc)
(princ)
)
下面以QJChen的一个双向动态阵列为例子，演示如何将以前用(grread)做的程序稍加修改就变成了JIG了。
在此感谢Qjchen，如有冒犯版权，多加原谅。原帖地址如下：
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=85752
本帖最后由 highflybir 于 2011-11-18 01:01 编辑
三、DragGen函数让你的拖动大量物体时候更给力。
XFormSS函数让你的对大量物体进行矩阵变换时快速有效。
;;;*********************************************************************
;;;Draggen用法:
;;;(DragGen 选择集/图元 [基点] [回调函数] [光标类型] [拖动模式] [执行]
;;;除第一个参数必须外，其他的可以缺省。
;;;选择集/图元，基点和回调函数同SSJIG的用法。
;;;光标类型--INT 类型，只有三种,0,十字;1,无;2,选取状
;;;拖动模式--INT 类型，0,平移;1,旋转;2,缩放;3镜像;以后再添加
;;;执行与否--如果此参数空或为nil,仅显示拖动效果,而不实际执行变换
;;;此函数用以对大量选择集进行拖动等变换效果，尤为明显，快于SSJIG.
;;;关键字和控制位的设置请在前面加initget，同getpoint之类的函数。
;;;---------------------------------------------------------------------
;;;回调函数返回值，如果返回点，依据拖动模式对选择集作几何变换.
;;;如果返回选择集/图元,则对他们作更新。如果返回一个标准的CAD变换矩阵，则
;;;对选择集/图元做指定的矩阵变换。（如错切，镜像，透视等）
;;;---------------------------------------------------------------------
;;;函数最终返回值为当前点位置和变换的矩阵表。
;;;这个函数要求用户对矩阵变换有一定了解。
;;;需要特殊说明的是：回调函数传入的点，是一个UCS下的点坐标。
;;;*********************************************************************
;;;自定义的回调函数 for DragGen
(defun CallBack1 (DynPt)
(redraw)
(grdraw pt dynpt -1)
(trans dynpt 1 0)
)
(vl-acad-defun 'CallBack1)
;;;*********************************************************************
;;;测试Draggen--移动
;;;*********************************************************************
(defun C:TCC(/ ss p0 ret pt)
(if (and (setq ss (ssget))
(RedrawSel ss 3)
(setq pt (getpoint "\n指定基点:"))
)
(progn
(setq p0 (trans pt 1 0))
(setvar "lastPoint" pt)
(prompt "\n指定第二个点:")
(setq ret (draggen ss p0 "CallBack1" 0 0 T))
(princ ret)
(RedrawSel ss 4)
)
)
(redraw)
(princ)
)
;;;*********************************************************************
;;;测试Draggen--旋转
;;;*********************************************************************
(defun C:TRR(/ ss p0 ret pt)
(if (and (setq ss (ssget))
(RedrawSel ss 3)
(setq pt (getpoint "\n指定基点:"))
)
(progn
(setq p0 (trans pt 1 0))
(setvar "lastPoint" pt)
(initget "Copy Reference")
(prompt "\n指定旋转角度，或 [复制(C)/参照(R)]:")
(setq ret (draggen ss p0 "CallBack1" 1 0 T))
(princ ret)
(RedrawSel ss 4)
)
)
(redraw)
(gc)
(princ)
)
;;;*********************************************************************
;;;测试Draggen--图元更新
;;;*********************************************************************
(defun C:TGG(/ ss p0 pt lst ret)
;;自定义回调函数for draggen --更新选择集
(defun CallBack (DynPt)
(redraw)
(grdraw pt dynpt -1)
(foreach obj lst
(vla-move obj (vlax-3d-point p0) (vlax-3d-point (trans dynpt 1 0)))
)
(setq p0 (trans dynpt 1 0))
ss
)
(vla-StartUndoMark curDoc)
;;程序执行部分
(if (and (setq ss (ssget))
(RedrawSel ss 3)
(setq pt (getpoint "\n指定基点:"))
)
(progn
(setq p0 (trans pt 1 0))
(setvar "lastPoint" pt)
(setq lst (GetObjects ss))
(setq ret (draggen ss p0 "CallBack" 0 0 T "\n指定第二个点:"))
(princ ret)
(RedrawSel ss 4)
)
)
(vla-EndUndoMark curdoc)
(redraw)
(gc)
(princ)
)
;;;*********************************************************************
;;;测试Draggen--矩阵变换
;;;*********************************************************************
(defun C:TMM(/ ss p0 pt ret)
;;自定义回调函数for draggen --矩阵变换
(defun CallBack (DynPt / vec)
(redraw)
(grdraw pt dynpt -1)
(setq vec (mapcar '- (trans dynpt 1 0) p0))
(list
(list 1. 0. 0. (car vec))
(list 0. 1. 0. (cadr vec))
(list 0. 0. 1. 0.)
(list 0. 0. 0. 1.)
)
)
;;程序执行部分
(if (and (setq ss (ssget))
(RedrawSel ss 3)
(setq pt (getpoint "\n指定基点:"))
)
(progn
(setq p0 (trans pt 1 0))
(setvar "lastPoint" pt)
(prompt "\n指定第二个点:")
(setq ret (draggen ss p0 "CallBack" 0 0 T))
(princ ret)
(RedrawSel ss 4)
)
)
(redraw)
(gc)
(princ)
)
;;;*********************************************************************
;;;测试XForm
;;;此函数用来对大量选择集的变换。因为vla-transformby,vla-move,vla-rotate
;;;对这样的需求在速度上不能满足要求时，需要用一个arx来高效地执行。
;;;另外，也用于command命令不能使用的场合。
;;;经测试速度，对大量图元的变换，用此能提高速度20倍，甚至更多。
;;;用法:(Xfrom Selection Matrix_List)
;;; Selection ------非空选择集 PICKSET
;;; Matrix_List ------变换矩阵表(4X4) LIST
;;;两个参数不能缺省，变换矩阵为标准的CAD等比矩阵.
;;;返回T代表成功变换，nil变换失败，此时请检测选择集中是否有被锁定的图元,
;;;或者变换矩阵为标准的CAD矩阵，为统一比例变换的矩阵。
;;;*********************************************************************
(defun C:TXX (/ sel pt1 pt2 vec)
(if (and (setq sel (ssget))
(setq pt1 (getpoint "\n基点:"))
(setq pt2 (getpoint "\n目标点:"))
)
(progn
(redraw)
(setq vec (mapcar '- pt2 pt1))
(setq vec (trans vec 1 0 T))
(grdraw pt1 pt2 1)
(XformSS sel
(list
(list 1. 0. 0. (car vec))
(list 0. 1. 0. (cadr vec))
(list 0. 0. 1. 0.)
(list 0. 0. 0. 1.)
)
)
)
)
)
敬仰不止
以前我都只能是用外国人的程序实现，现在高飞鸟兄带来更好的程序
谢谢~
支持，很给力,对LISP来说是一种弥补. 感觉grread函数外国人用得出神入化，有了版主的函数，我们也可以做出出神入化的动态效果 非常强悍，一直想学习C#就是为了解决两大难题：
1. grread函数的局限。
2. DCL无法实现非模态。
谢谢高飞鸟