心随我动--为LISP定制的动态输入，动态拖拉和动态信息函数（更新至12.15）

Highflybird

源码已经贴在ObjectArx版块处！！
http://bbs.xdcad.net/thread-667837-1-1.html

arx程序和LISP样例：

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:DynamicLisp.rar 
下载次数:233  文件大小:296 KB 
下载权限: 不限 以上  [免费赚D豆]

===========================================
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之类的函数时光标所在位置，并对其反应，形成各种特殊的效果，譬如动态拖拉，动态信息等等。
    这个函数的优点在于，回调函数不一定要在命令状态下就可以运行，就像非模态一样。
[pcode=lisp,true]

(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 'height  height)
      )
      (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)
)[/pcode]

Highflybird

二、让LISP也能JIG,JIG是arx或者.net编程的一个函数，用来在采点过程中与用户交互的一个动态拖拉技术。
JIG的优势在于：可以动态输入，功能齐全，与用户交互性较好，直观方便。
[pcode=lisp,true]
;;;*********************************************************************
;;;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)
)[/pcode]

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:Arraytest.lsp 
下载次数:31  文件大小:5.79 KB 
下载权限: 不限 以上  [免费赚D豆]

下面以QJChen的一个双向动态阵列为例子，演示如何将以前用(grread)做的程序稍加修改就变成了JIG了。
在此感谢Qjchen，如有冒犯版权，多加原谅。

Highflybird

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

[pcode=lisp,true]
;;;*********************************************************************
;;;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.)
            )  
      )
    )
  )
)[/pcode]

xshrimp

想用了代替grread,但是我记得测试的时候,有时候不太稳定,cad直接崩溃过,不知道楼主有没有遇到过?

Highflybird

xshrimp 发表于 2013-5-7 11:03

                               
登录/注册后可看大图

想用了代替grread,但是我记得测试的时候,有时候不太稳定,cad直接崩溃过,不知道楼主有没有遇到过?

有可能，把你崩溃的地方贴上来。我好改进。

夏生生

鸟版，可否做个不输入命令即可显示图元信息的实例，就显示直线的图层的简单例子即可，谢谢

xiaoyuzj503

楼主超牛。

:funk:

牢固

夏生生 发表于 2013-5-20 02:21
鸟版，可否做个不输入命令即可显示图元信息的实例，就显示直线的图层的简单例子即可，谢谢

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

游客，本帖隐藏的内容需要积分高于 50 才可浏览，您当前积分为 0

夏生生

牢固 发表于 2013-5-20 22:51
动态信息查询,由一个经典的yad动态信息查询函数改编而来!
**** 本内容被作者隐藏 ****

等我积分够了再看！！！

夏生生

几天没登上来，才登上，自己再努努力将积分提上来，不是灌水提分{:soso_e100:}

GTJ116600

Highflybird版主真厉害

cre8or

积分怎样才涨阿 我真不知道

pengfei2010

动态查询真的太强大了，lisp也比想象中强大

wxytiger

winxp，Autocad2008,可以正常加载使用，但退出cad时，经常提示arx文件错误，有时会导致cad出现致命错误信息。

l18c19

好程序，值得学习提高！