【Gu_xl】【源码分享】自定义带捕捉的grread函数
本帖最后由 Gu_xl 于 2013-6-25 10:51 编辑最近论坛里不少人在讨论如何解决Grread函数的捕捉问题，grread函数不能捕捉，想要使用上捕捉，非常麻烦，高飞兄的那个arx动态函数很好的解决了这个问题！但是我这里是用lisp方法对grread函数重新自定义，构造出一个和grread函数一样功能的函数，同时它支持捕捉、支持正交，并支持在grread运行中进行捕捉、正交的开和关，这样Grread实现捕捉工作就变得简单了！
申明一下，这个函数核心源码并非我原创，是借鉴了前辈们的智慧结晶，核心源码是谁的，我现在也高不清楚了，有可能是CAB的，在此基础上，我加以改进后形成的成果，在此对前辈们表示感谢！
源码:
;;;gxl-Ge-grread 自定义带捕捉的GrRead函数
;;;参数:GR_MODE = 函数GrRead的参数表 如: (list ),参数个数按需要设置，可为nil
;;; STARTPT = 基点，计算垂足点、正交模式等坐标的基点,若为nil,则基点默认为系统变量LastPoint值
;;; SS = 捕捉避开的物体，可以是选择集或图元名
(DEFUN gxl-Ge-grread (GR_MODE STARTPT SS / GET_OSMODE
GETGRVECS DRAWVECS TIME
F3F8 STR_OSMODE
LST_OSMODE DRAFTOBJ AUTOSNAPMARKERSIZE
AUTOSNAPMARKERCOLOR DRAG
DRAGMODE GHOSTPT X0
Y0X1 Y1
Z1DISTPERPIXEL BOLD
)
;;;==================================================================
;;gxl-Sel-ReDrawSel 重画选择集中的对象，Sel 为选择集或图元名 mode 为方式码
;;;重画选择集中的对象，mode 为方式码，
;;;方式码 1 在屏幕重画该选择集对象
;;;方式码 2 隐藏该选择集对象
;;;方式码 3 “醒目显示”该选择集对象
;;;方式码 4 取消“醒目显示”该选择集对象
;;;==================================================================
(defun gxl-Sel-ReDrawSel(Sel mode / m n)
(if sel
(progn
(cond ((= 'pickset (type Sel))
(setq m (sslength Sel)
n 0)
(repeat m
(redraw (ssname Sel n) mode)
(setq n (1+ n))
)
)
((= 'ename (type Sel))
(redraw Sel mode)
)
)
)
)
) ;defun gxl-Sel-ReDrawSel
;;;分列字串
(defun gxl-StrParse ( str del / pos lst )
(while (setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst) str (substr str (+ pos 1 (strlen del))))
)
(if (= " " Del)
(vl-remove "" (reverse (cons str lst)))
(reverse (cons str lst))
)
)
;;;返回捕捉模式字串
(DEFUN get_osmode (/ cur_mode mode$)
(SETQ mode$ "")
(IF (< 0 (SETQ cur_mode (GETVAR "osmode")) 16384)
(MAPCAR (FUNCTION (LAMBDA (x)
(IF (NOT (ZEROP (LOGAND cur_mode (CAR x))))
(IF (ZEROP (STRLEN mode$))
(SETQ mode$ (CADR x))
(SETQ mode$ (STRCAT mode$ "," (CADR x)))
)
)
)
)
'((1 "_end")
(2 "_mid")
(4 "_cen")
(8 "_nod")
(16 "_qua")
(32 "_int")
(64 "_ins")
(128 "_per")
(256 "_tan")
(512 "_nea")
(1024 "_qui")
(2048 "_app")
(4096 "_ext")
(8192 "_par")
)
)
)
mode$
)
;;;返回捕捉标记Vecs
(DEFUN GetGrvecs (pt dragpt lst / KEY)
(SETQ key T)
(WHILE (AND key lst)
(IF (EQUAL (OSNAP dragpt (CAR lst)) pt 1E-6)
(SETQ key nil)
(SETQ lst (CDR lst))
)
)
(CDR (ASSOC (CAR lst)
'(("_end"
((-1 1) (-1 -1))
((-1 -1) (1 -1))
((1 -1) (1 1))
((1 1) (-1 1))
) ;正方形
("_mid"
((0 1.414) (-1.225 -0.707))
((-1.225 -0.707) (1.225 -0.707))
((1.225 -0.707) (0 1.414))
) ;三角形
("_cen"
((0 1) (-0.707 0.707))
((-0.707 0.707) (-1 0))
((-1 0) (-0.707 -0.707))
((-0.707 -0.707) (0 -1))
((0 -1) (0.707 -0.707))
((0.707 -0.707) (1 0))
((1 0) (0.707 0.707))
((0.707 0.707) (0 1))
) ;圆
("_nod"
((0 1) (-0.707 0.707))
((-0.707 0.707) (-1 0))
((-1 0) (-0.707 -0.707))
((-0.707 -0.707) (0 -1))
((0 -1) (0.707 -0.707))
((0.707 -0.707) (1 0))
((1 0) (0.707 0.707))
((0.707 0.707) (0 1))
((-1 1) (1 -1))
((-1 -1) (1 1))
) ;圆+十字交叉
("_qua"
((0 1.414) (-1.414 0))
((-1.414 0) (0 -1.414))
((0 -1.414) (1.414 0))
((1.414 0) (0 1.414))
) ;旋转45°的正方形
("_int"
((-1 1) (1 -1))
((-1 -1) (1 1))
((1 0.859) (-0.859 -1))
((-1 0.859) (0.859 -1))
((0.859 1) (-1 -0.859))
((-0.859 1) (1 -0.859))
) ;十字交叉
("_ins"
((-1 1) (-1 -0.1))
((-1 -0.1) (0 -0.1))
((0 -0.1) (0 -1.0))
((0 -1.0) (1 -1))
((1 -1) (1 0.1))
((1 0.1) (0 0.1))
((0 0.1) (0 1.0))
((0 1.0) (-1 1))
) ;两个正方形
("_per"
((-1 1) (-1 -1))
((-1 -1) (1 -1))
((0 -1) (0 0))
((0 0) (-1 0))
) ;半个正方形
("_tan"
((0 1) (-0.707 0.707))
((-0.707 0.707) (-1 0))
((-1 0) (-0.707 -0.707))
((-0.707 -0.707) (0 -1))
((0 -1) (0.707 -0.707))
((0.707 -0.707) (1 0))
((1 0) (0.707 0.707))
((0.707 0.707) (0 1))
((1 1) (-1 1))
) ;园+线
("_nea"
((-1 1) (1 -1))
((1 -1) (-1 -1))
((-1 -1) (1 1))
((1 1) (-1 1))
) ;两个三角形
("_qui") ; ???
("_app"
((-1 1) (-1 -1))
((-1 -1) (1 -1))
((1 -1) (1 1))
((1 1) (-1 1))
((-1 1) (1 -1))
((-1 -1) (1 1))
) ;正方形+十字交叉
("_ext"
((0.1 0) (0.13 0))
((0.2 0) (0.23 0))
((0.3 0) (0.33 0))
) ;三个点
("_par" ((0 1) (-1 -1)) ((1 1) (0 -1))) ;两条线
)
)
)
)
;;绘制捕捉标记
(DEFUN DrawVecs (Pt Vecs Size Color / lst xdir)
(setq xdir (getvar 'ucsxdir))
(setq vecs
(mapcar
'(lambda (x)
(mapcar '(lambda (a)
(setq a (trans a 0 xdir))
(setq a (list (caddr a) (car a)))
(list (+ (car pt) (* size (car a)))
(+ (cadr pt) (* size (cadr a)))))
x))
vecs))
(SETQ lst (MAPCAR 'CONS
(MAPCAR (FUNCTION (LAMBDA (x) Color)) Vecs)
Vecs
)
)
(GRVECS (APPLY 'APPEND lst))
)
;;;主程序开始
(VL-LOAD-COM)
(if STARTPT
(setvar 'lastpoint STARTPT)
(setq STARTPT (getvar 'lastpoint))
)
(SETQ time T)
(setq F3 (getvar "osmode"))
(setq F8 (getvar "ORTHOMODE"))
(SETQ str_osmode (get_osmode))
(SETQ lst_osmode (gxl-StrParse str_osmode ","))
(SETQ Draftobj (VLA-GET-DRAFTING
(VLA-GET-PREFERENCES (VLAX-GET-ACAD-OBJECT))
)
)
(SETQ AutoSnapMarkerSize (VLA-GET-AUTOSNAPMARKERSIZE Draftobj))
(SETQ AutoSnapMarkerColor (VLA-GET-AUTOSNAPMARKERCOLOR Draftobj))
(setq drag (apply 'GRREAD GR_mode)) ;_ 执行Gread函数
(setq dragmode (car drag))
(COND ((equal drag '(2 6));F3切换捕捉开关
(if (< f316384)
(progn (setq f3 (+ f3 16384))(prompt "\n<对象捕捉 关>"))
(progn (setq f3 (- f3 16384))(prompt "\n<对象捕捉 开>"))
)
(setvar "OSMODE" f3)(redraw)
)
((equal drag '(2 15));F8切换正交开关
(if (= f8 0)
(progn(setq f8 1)(prompt "\n<正交 开>"))
(progn(setq f8 0)(prompt "\n<正交 关>"))
)
(setvar "orthomode" f8)(redraw)
)
((= dragmode 5)
(REDRAW)
(GXL-SEL-REDRAWSEL ss 2) ;_ 隐藏选择集
(SETQ drag (CADR drag))
(IF (or (zerop (strlen str_osmode))
(null (SETQ ghostpt (OSNAP drag str_osmode)))
)
;;;此处修改正交模式下坐标
(if (and startpt (= 1 f8) (/= 2 (car drag)))
(progn
(setq x0 (car startpt)
y0 (cadr startpt)
x1 (car drag)
y1 (cadr drag)
z1 (caddr drag)
)
(if (> (abs (- x0 x1)) (abs (- y0 y1)))
(setq ghostpt (list x1 y0 z1))
(setq ghostpt (list x0 y1 z1))
)
)
(SETQ ghostpt drag)
)
;;Beacuse of mouse middle button scroll , calculate "DistPerPixel" every time
(PROGN (SETQ DistPerPixel (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE"))))
;;Bold
(SETQ Bold (MAPCAR '*
(LIST DistPerPixel DistPerPixel DistPerPixel)
(LIST (+ AutoSnapMarkerSize 0.5)
AutoSnapMarkerSize
(- AutoSnapMarkerSize 0.5)
)
)
)
(FOREACH itemBold
(DrawVecs
ghostpt
(GetGrvecs ghostpt drag lst_osmode)
item
AutoSnapMarkerColor
)
)
)
)
(GXL-SEL-REDRAWSEL ss 1) ;_ 显示选择集
)
((or (= dragmode 3)
(= dragmode 12)
)
(GXL-SEL-REDRAWSEL ss 2) ;_ 隐藏选择集
(IF (Null (SETQ ghostpt (OSNAP (CADR drag) (get_osmode))))
;;;此处修改正交模式下坐标
(if (and startpt (= 1 f8) (/= 2 (car drag)))
(progn
(setq x0 (car startpt)
y0 (cadr startpt)
x1 (caadr drag)
y1 (cadadr drag)
z1 (caddar (cdr drag))
)
(if (> (abs (- x0 x1)) (abs (- y0 y1)))
(setq ghostpt (list x1 y0 z1))
(setq ghostpt (list x0 y1 z1))
)
)
(SETQ ghostpt (CADR drag))
)
)
(REDRAW)
(GXL-SEL-REDRAWSEL ss 1) ;_ 显示选择集
(SETQ time nil)
)
(t
;;;此处修改正交模式下坐标
(if (and startpt (= 1 f8) (/= 2 (car drag)))
(progn
(setq x0 (car startpt)
y0 (cadr startpt)
x1 (caadr drag)
y1 (cadadr drag)
z1 (caddar (cdr drag))
)
(if (> (abs (- x0 x1)) (abs (- y0 y1)))
(setq ghostpt (list x1 y0 z1))
(setq ghostpt (list x0 y1 z1))
)
)
(SETQ ghostpt (CADR drag))
)
(REDRAW)
)
)
; )
(list dragmode ghostpt)
)
;;;测试1，动态移动
(defun c:tt(/ ss pt p oldpt)
(princ "\n选择移动物体: ")
(while (not (setq ss (ssget))))
(setq pt (getpoint "\n 选择基点"))
(if (null pt) (setq oldpt (getvar 'lastpoint)) (setq oldpt pt))
(while (/= 3 (car (setq gr (GXL-GE-GRREAD '(t 7 2) pt ss)))) ;_ 将移动的选择集排除在捕捉目标之外
(if (= 'list (type (setq p (cadr gr))))
(progn
(grdraw pt p 1)
(command "move" ss "" oldpt p)
(setq oldpt p)
)
)
)
)
;;;测试2
(defun c:test (/ en gr p enl)
(while (not (setq p (GETPOINT "\n点："))))
(while (/= 3 (car (setq gr (GXL-GE-GRREAD '(t 7 2) p en)))) ;_ 将直线排除在捕捉目标之外
(if (= 'list (type (cadr gr)))
(progn
(if en
(progn
(entmod (subst (cons 11 (trans (cadr gr) 1 0)) (assoc 11 enl) enl))
)
(progn
(vla-ADDLINE(vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3d-point (trans p 1 0)) (vlax-3d-point (trans (cadr gr) 1 0)))
(setq en (entlast) enl (entget en))
)
)
)
)
)
)
http://bbs.mjtd.com/xwb/images/bgimg/icon_logo.png 该贴已经同步到 Gu_xl的微博
国外早有grread的捕捉，国内见到最早的应该是ZML版主 有朋友苹果版ACAD由于没有DCL对话框, 输入密码时就容易暴露！
搜索后，刚巧有网友示范如何覆盖密码。。李麦大神也有发布思维应该不难。
但如果显示在图元我的问题是如何完美在任何立体视界居中就好象UCS icon 标志 (X,Y,Z)永远都对着荧幕正常显示！
如动画：
https://i.imgur.com/YFk8Nxn.gif
如果不要命令之类如(command "text" ...) (command "PLAN" "v")
我尝试entmake但有些视角却不行
有没有大神已经有发布过类似居中函数？
基本上如果在正常WCS以下方法应该是可行的...
(entmakex (list '(0 . "TEXT")
(cons 40 (vs 30))
'(72 . 1)'(50 0)
(cons 10 (getvar 'viewctr) )
(cons 1 str)
(cons 11(getvar 'viewctr) )
(cons 210(getvar 'viewdir) )
)
)
但如果图元已转换UCS空间，（先别说viewtwist等变量已一改变就更有难度了！）
好像缺少什么？
(getvar 'viewdir)
(trans (getvar 'viewctr) 2 0)
ucsxdir, ucsydir, ucsbase?
快速缩放鼠标中键， 211行会报错 (GRVECS (APPLY 'APPEND lst)) 可能是来不及绘制 强人
我的lisp学习就是在参考G版的源代码中逐渐成长起来的！
在此感谢G版的无私奉献 大量物体做动态本来就费劲！大量物体时肯定要使用高飞兄的那个函数才给力！ ，原来这个问题这么复杂，看着代码都头晕 g版高明，支持了 很好的GRREAD例子,这个一定支持 慢慢看....... 这个帖子要顶起来才对.... 楼主牛人，