维坦

 
;;; 双击反应器 2007-11-19
;;; http://www.ViTarn.com/
;;; 命令: (>DoubleClickAttach (car (entsel)) T)
(defun >DoubleClickDefine ()
  (vl-load-com)
  ; 建立反应器对象
  (or
    *MY_Mouse_Reactor*
    (setq *MY_Mouse_Reactor* (vlr-mouse-Reactor "MY_Mouse" '((:vlr-beginDoubleClick . >DoubleClickCallback))))
  )
  ; 尝试加载/卸载ARX
  (vl-catch-all-apply 'arxunload '("acdblclkedit.arx"))
  (vl-catch-all-apply 'arxload '("acdblclkedit.arx"))
  ; 定义双击回调函数
  (defun >DoubleClickCallback (reactor point / selp point ent)
    ; 双击时的坐标 转化到当前坐标系
    (setq point (trans (car point) 0 1))
    (if (setq selp (nentselp point))
      (progn
        ; 如果是块 取块的图元名
	(if (> (length selp) 2)
	  (setq ent (last (last selp)))
	  (setq ent (car selp))
	)
	; 是否自定义双击 取决于ldata中的"DoubleClick"
	(if (vlax-ldata-get ent "DoubleClick")
	  (progn
	    ; 令系统自带的双击功能失效
	    (vl-catch-all-apply 'arxunload '("acdblclkedit.arx"))
	    ; 取消选取的对象 这是令双击失效的关键
	    (sssetfirst nil)
	    ; 自定义处理
	    (>DoubleClickExecute ent point)
	    ; 恢复系统自带的双击功能
	    (vl-catch-all-apply 'arxload '("acdblclkedit.arx"))
	  )
	)
      )
    )
  )
)
;;; 双击反应器自动加载
(or
  *MY_Mouse_Reactor*
  (>DoubleClickDefine)
)
;;; 双击事件自定义处理函数
(defun >DoubleClickExecute (ent point)
  (prompt (strcat (VL-PRINC-TO-STRING ent) " " (VL-PRINC-TO-STRING point) "\n"))
)
;;; 清除图形中的全部双击反应器
(defun >DoubleClickClearAll (/ ss i e)
  (setq *MY_Mouse_Reactor* nil)
  (setq ss (ssget "x"))
  (setq i 0)
  (repeat (sslength ss)
    (vlax-ldata-delete (ssname ss i) "DoubleClick")
    (setq i (1+ i))
  )
)
;;; 绑定图元双击反应器
(defun >DoubleClickAttach (ent on)
  (if on
    (vlax-ldata-put ent "DoubleClick" T)
    (vlax-ldata-delete ent "DoubleClick")
  )
)
 

1. 
   zml84 said...
   08:34 - 十一月 19th, 2007

   你的博文代码着色，很不错，学习了。。