多参数动态移动图元
(defun $dyn-move$ (lst / $ents-dui-qi-pt$ $grvecs$$move$ blck-not-sc block-r code
color data do_rotate do_scale
ents grread-pt-old mode
move offset phjg pt0
pt-old pts scale scalefactor
tishiyu xunhuan zt zimu
*error* fhgs ents->block ESC-DEL? fd-ents
)
;动态移动，动态插入块，动态插入图元，动态移动图元，移动图元
;|
;调用方法：
(and (setq ss (ssget))
(setq ents(vl-remove-if
(function listp)
(mapcar (function cadr) (ssnamex SS))
)
)
($dyn-move$
(list (cons "图元列表" ents)
(cons "矢量图" nil)
(cons "颜色" 1)
;(cons "追踪点" (list 0 0 0))
(cons "矢量图偏移距离" (list 1 100))
(cons "系数" 3)
(cons "块保持正方向" 0)
(cons "对齐方式" 0)
(cons "返回格式" "坐标")
(cons "ESC" "是")
(cons "附带删除" fd-ents)
(CONS "键盘字母"
(LIST "A" "a" "F" "f" "E" "e" "C" "c" "D" "d")
)
;(cons "保持原比例的块图元"(ssToentlst (ssget)))
)
)
)
|;
(defun *error* (msg)
(if(and ENTS (or (= msg "函数已取消") (= msg "函数被取消")))
(progn
(if msg
(PROGN (PRINT)
(princ (strcat "$dyn-move$遇到错误: " msg))
)
)
(IF (or(not ESC-DEL?) ;没有传参的模式，默认行为，兼容历史程序
(= ESC-DEL? "是")
) ;传入参数中是否需要支持esc键删除图元的要求
(PROGN(MAPCAR (function (lambda (xx)
(if (AND (= (type xx) 'ENAME) (ENTGET XX))
(entdel xx)
)
(if (AND xx (= (type xx) 'VLA-OBJECT))
(vla-delete xx)
)
)
)
ENTS
)
(IF(AND ents->block (ENTGET ents->block))
(ENTDEL ents->block)
)
)
)
(redraw)
)
)
;;; (vl-catch-all-apply (function (lambda () (c:var nil nil))));强制将变量还原
(vl-catch-all-apply (function (lambda () (c:var2 nil nil (list (CONS"DEL" fd-ents))))));强制将变量还原
(princ)
)
(defun $ents-dui-qi-pt$ (entlstmod / maxpo0minpo0
pt-f pts x-max x-min y-max
y-min
)
;求图元的对齐点坐标
(mapcar
(function(lambda (x / minpo maxpo box)
(IF (= (TYPE X) 'ENAME)
(SETQ X (vlax-ename->vla-object X))
)
(if (and
(not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-GetBoundingBox
(list x 'minpo 'maxpo)
)
)
)
(setq minpo (vlax-safearray->list minpo))
(setq maxpo (vlax-safearray->list maxpo))
)
(progn
(if (and minpo0 (car minpo) (car minpo0))
(setq
minpo0(list (min (car minpo) (car minpo0))
(min (cadr minpo) (cadr minpo0))
0
)
)
(setq minpo0 (list (car minpo) (cadr minpo)))
)
(if maxpo0
(setq
maxpo0(list (max (car maxpo) (car maxpo0))
(max (cadr maxpo) (cadr maxpo0))
0
)
)
(setq maxpo0 (list (car maxpo) (cadr maxpo)))
)
)
(progn
(if (not err-print)
(progn
(setq err-print 't)
(print "vla-GetBoundingBox error,可能字体有问题")
)
)
)
)
))
entlst
)
(and (SETQ PTS (VL-REMOVE NIL (LIST minpo0 maxpo0)))
(SETQ X-MIN (APPLY 'MIN (MAPCAR 'CAR PTS)))
(SETQ X-MAX (APPLY 'MAX (MAPCAR 'CAR PTS)))
(SETQ Y-MIN (APPLY 'MIN (MAPCAR 'CADR PTS)))
(SETQ Y-MAX (APPLY 'MAX (MAPCAR 'CADR PTS)))
)
(COND ((= MOD 1)
(SETQ PT-F (LIST X-MIN Y-MIN)) ;左下
)
((= MOD 2)
(SETQ PT-F (LIST X-MAX Y-MIN)) ;右下
)
((= MOD 3)
(SETQ PT-F (LIST X-MAX Y-MAX)) ;右上
)
((= MOD 4)
(SETQ PT-F (LIST X-MIN Y-MAX)) ;左上
)
((= MOD 5)
(SETQ PT-F (LIST (* (+ X-MIN X-MAX) 0.5) Y-MIN)) ;下中
)
((= MOD 6)
(SETQ PT-F
(LIST (* (+ X-MIN X-MAX) 0.5) (* (+ Y-MIN Y-MAX) 0.5))
) ;右中
)
((= MOD 7)
(SETQ PT-F (LIST (* (+ X-MIN X-MAX) 0.5) Y-MAX)) ;上中
)
((= MOD 8)
(SETQ PT-F (LIST X-MIN (* (+ Y-MIN Y-MAX) 0.5))) ;左中
)
((= MOD 0)
(SETQ PT-F (mapcar '(lambda (x y)
(* (+ x y) 0.5)
)
minpo0
maxpo0
)
)
)
)
PT-F
)
(defun $Move$(entlst PT-F PT-T MOD /)
(ifPT-F
()
(setq PT-F ($ents-dui-qi-pt$ ENTS MODE))
)
(mapcar
(function(lambda (x)
(vl-catch-all-apply
'vla-move
(LIST (vl-catch-all-apply 'vlax-ename->vla-object (LIST X))
(vl-catch-all-apply 'vlax-3D-point (LIST PT-F))
(vl-catch-all-apply 'vlax-3D-point (LIST PT-T))
)
)
))
entlst
)
PT-T
)
(defun do_Rotate (entlst PT +-? block-r)
(mapcar
(function
(lambda(x / obj dxf)
(SETQ obj (vlax-ename->vla-object X))
(and x (setq dxf (entget x)))
(if (= +-? "-")
(VL-CATCH-ALL-APPLY
'vla-Rotate
(LIST obj
(VL-CATCH-ALL-APPLY 'vlax-3D-point (LIST PT))
(* pi 0.05)
)
)
(VL-CATCH-ALL-APPLY
'vla-Rotate
(LIST obj
(VL-CATCH-ALL-APPLY 'vlax-3D-point (LIST PT))
(- 0 (* pi 0.05))
)
)
)
(if (AND dxf (= (cdr (assoc 0 dxf)) "INSERT"))
(if(= block-r 0) ;1代表支持旋转，0代表保持正方向，不旋转的意思(无值自然是支持旋转，记住这个)
(if (VL-CATCH-ALL-APPLY
'vlax-property-available-p
(list obj 'InsertionPoint)
)
(VL-CATCH-ALL-APPLY
'vla-Rotate
(list
x
(VL-CATCH-ALL-APPLY
'vla-get-InsertionPoint
(list obj)
)
(if(= +-? "-")
(- 0 (* pi 0.05))
(* pi 0.05)
)
)
)
)
)
)
)
)
entlst
)
)
(defun do_Scale (entlst PT +-? ScaleFactor blck-not-sc)
(mapcar (function(lambda (x)
(IF (= (TYPE X) 'ENAME)
(SETQ X (vlax-ename->vla-object X))
)
(if (= +-? "+")
(vla-ScaleEntity
x
(vlax-3D-point pt)
ScaleFactor
)
(vla-ScaleEntity
x
(vlax-3D-point pt)
(/ 1.0 ScaleFactor)
)
)
))
entlst
)
(ifblck-not-sc
(mapcar
(function(lambda (x / dxf)
(setq dxf (entget x))
(IF (= (TYPE X) 'ENAME)
(SETQ X (vlax-ename->vla-object X))
)
(vla-ScaleEntity
x
(vlax-3D-point (cdr (assoc 10 dxf)))
(if (= +-? "+")
(/ 1.0 ScaleFactor)
ScaleFactor
)
)
))
blck-not-sc
)
)
)
(defun $grvecs$ (data pt pt0 scale color offset / pt1 r1 scalelist)
;矢量图行显示
(setq pt1 pt)
(SETQ scalelist (list scale 1000.0))
(setq r1 (getvar "viewsize"))
(setq r1 (* (car scalelist) (/ r1 (cadr scalelist))))
(redraw)
(if(AND pt0 color)
(grdraw pt0 pt1 color)
)
(IFDATA
(grvecs
(apply
'append
(mapcar
(function(lambda (x)
(list color
(mapcar '+
(mapcar '*
(mapcar '+ (car x) offset)
(list r1 r1)
)
pt1
)
(mapcar '+
(mapcar '*
(mapcar '+ (cadr x) offset)
(list r1 r1)
)
pt1
)
)
))
data
)
)
)
)
)
(and lst (setq ents (cdr (assoc "图元列表" lst))))
(and (= (type (cdr (assoc "矢量图" lst))) 'list)
(setq data (cdr (assoc "矢量图" lst)))
)
(and (= (type (cdr (assoc "颜色" lst))) 'int)
(setq color (cdr (assoc "颜色" lst)))
)
(and (= (type (cdr (assoc "追踪点" lst))) 'list)
(setq pt0 (cdr (assoc "追踪点" lst)))
)
(and (= (type (cdr (assoc "矢量图偏移距离" lst))) 'list)
(setq offset (cdr (assoc "矢量图偏移距离" lst)))
)
(or(and (= (type (cdr (assoc "系数" lst))) 'int)
(setq scale (cdr (assoc "系数" lst)))
)(setq scale 1.0))
(and (= (type (cdr (assoc "块保持正方向" lst))) 'int)
;0保持正方向(不允许旋转)，1不保持正方向(允许旋转)(无值自然是支持旋转，记住这个)
(setq block-r (cdr (assoc "块保持正方向" lst)))
)
(setq ESC-DEL?(cdr(assoc "ESC" lst)))
(if (not (setq fd-ents(cdr(assoc "附带删除" lst))))
(setq fd-ents nil)
)
(setq fhgs(cdr(assoc "返回格式" lst)))
(or (and (setq mode (cdr (assoc "对齐方式" lst)))
(member mode (list '0 '1 '2 '3 '4 '5 '6 '7 '8))
)
(setq mode 0)
)
(if (cdr (assoc "键盘字母" lst))
(setq zimu (cdr (assoc "键盘字母" lst)))
(setq zimu (LIST "A" "D" "F" "E" "C" "a" "d" "f" "e" "c"));这里是为了兼容历史其他程序的，因为好多历史其他程序默认没有传入这个参数，但是，程序是支持了旋转和缩放的，如果不加上这个默认，好多历史的代码会导致无法旋转了
)
(setq blck-not-sc (cdr (assoc "保持原比例的块图元" lst)))
(setq ScaleFactor 1.25)
(and ents (= (type ents) 'ename) (setq ents (list ents)))
(if (and ents (= (type ents) 'list))
(progn
(setq ents->block nil)
(if (> (length ents) 1000)
(progn (setq ents->block ($制作块$ ents "*U" 0 1));转换为块（如果影响到上级调用了，请告知客户，不要将图形画那么多线条，上级调用方也是可以再次过滤分析的，“返回格式”的参数传入“表”值程序就会返回炸开后的图元）
(setq ents (list ents->block))
);图元数量太多了，直接转换为块
)
(PRINT)
(setq tishiyu "")
(if (or (member "A" zimu)
(member "a" zimu)
(member "F" zimu)
(member "f" zimu)
)
(setq tishiyu (strcat tishiyu "旋转 "))
)
(if (or (member "E" zimu)
(member "e" zimu)
(member "C" zimu)
(member "c" zimu)
)
(setq tishiyu (strcat tishiyu "缩放 "))
)
(if (or (member "D" zimu) (member "d" zimu))
(setq tishiyu (strcat tishiyu "对齐 "))
)
(prinC tishiyu)
(SETQ ENTS (VL-REMOVE NIL ENTS))
(COND
((> (LENGTH ENTS) 900) (SETQ PHJG 5))
((> (LENGTH ENTS) 800) (SETQ PHJG 4))
((> (LENGTH ENTS) 600) (SETQ PHJG 3))
((> (LENGTH ENTS) 400) (SETQ PHJG 2))
((> (LENGTH ENTS) 200) (SETQ PHJG 1))
((> (LENGTH ENTS) 100) (SETQ PHJG 0.5))
(T (SETQ PHJG 0.25))
) ;平滑度间隔
(setq grread-pt-old (cadr (GRREAD (GRREAD 15 2))))
(SETQ PT-OLD NIL)
(setq zt NIL)
(setq move nil)
(setq xunhuan t)
(while xunhuan
(setq code nil)
(setq code (grread T 15))
(cond
((= (car code) 5) ;移动
(IF PT-OLD
(if (> (DISTANCE (cadr code) PT-OLD) PHJG)
(setq PT-OLD ($move$ ents PT-OLD (cadr code) mode))
)
(setq PT-OLD ($move$ ents PT-OLD (cadr code) mode))
)
(if (> (DISTANCE (cadr code) grread-pt-old) 10)
(setq move t)
) ;做个标记，防止误操作，有的电脑还没有来得及移动鼠标就开始按下按键了
($grvecs$ data PT-OLD pt0 scale color offset)
(SETQ PTS (CONS (CADR code) PTS))
)
((= (car code) 3) ;左键
(setq PT-OLD ($move$ ents PT-OLD (cadr code) mode))
(setq xunhuan nil)
(if ents->block(setq ents(sn:Explode ents->block)));如果有转换为块的动作，就再次将块炸开为图元列表
(setq zt T)
)
((and(or (equal code '(2 68)) (equal code '(2 100)))
(or (member "D" zimu) (member "d" zimu))
)
;用户按下了键盘D键
(SETQ MODE (1+ MODE))
(IF (> MODE 8)
(SETQ MODE 1)
)
(setq PT-OLD ($ents-dui-qi-pt$ ENTS MODE))
)
((OR (MEMBER (car code) (LIST '11 '25))
(equal code '(2 13))
(equal code '(2 32))
) ;右键，右键，回车，空格
(setq PT-OLD ($move$ ents PT-OLD (cadr code) mode))
(setq xunhuan nil) ;让while结束循环
)
((and
move
(or (equal code '(2 65)) (equal code '(2 97)))
(OR (NOT tishiyu) (or (member "A" zimu) (member "a" zimu)))
)
; A or a
(do_Rotate ents PT-OLD "-" (cdr (assoc "块保持正方向" lst)))
(setq move nil)
)
((and
move
(or (equal code '(2 70)) (equal code '(2 102)))
(OR (NOT tishiyu) (or (member "F" zimu) (member "f" zimu)))
)
; F or f
(do_Rotate ents PT-OLD "+" (cdr (assoc "块保持正方向" lst)))
(setq move nil)
)
((and
move
(or (equal code '(2 69)) (equal code '(2 101)))
(OR (NOT tishiyu) (or (member "E" zimu) (member "e" zimu)))
)
; E or e
(do_Scale ents PT-OLD "+" ScaleFactor blck-not-sc)
(setq PT-OLD ($ents-dui-qi-pt$ ENTS MODE))
(setq move nil)
)
((and
move
(or (equal code '(2 67)) (equal code '(2 99)))
(OR (NOT tishiyu) (or (member "C" zimu) (member "c" zimu)))
)
; C or c
(do_Scale ents PT-OLD "-" ScaleFactor blck-not-sc)
(setq PT-OLD ($ents-dui-qi-pt$ ENTS MODE))
(setq move nil)
)
)
(setq code nil)
)
(list (cons "状态" zt)
(cons "坐标" PT-T)
(cons "图元列表" ents)
)
)
)
(IF (or(not fhgs);如果没有传入这个参数【默认行为，兼容历史程序】
(= fhgs "坐标");如果有传参进来，同时其值等于“坐标”
)
PT-OLD
(list (cons "坐标" PT-OLD) (cons "图元" ENTS))
;坐标返回去给上一级
)
)
高飞鸟的动态arx函数库
是目前最好的
可惜只支持到2014
CAD自带的arx函数库也挺好
没有版本问题
就是功能略简单
除此之外我试过的其它方法
包括各种dll和arx
都存在各种无法接受的硬伤
比如不支持按住鼠标中键平移视窗等 grread模拟动态
对大量图元的预览显示较慢
这是函数的硬伤
除此之外
最大的难点是实现捕捉
除了预置捕捉
还有右键捕捉菜单
和手输的临时指定捕捉
杜总的这个代码显然没有考虑这些
对需要精确定位的情况
就不是很合适了
zmzk 发表于 2024-5-27 22:24
运行不起来呢
如果缺少函数，列出来，我补充，当然我很多帖子，可能函数在其他帖子里面有 感谢分享，感谢杜总~~~~ 啊，大牛写的程序，菜鸡表示看不懂。 按键没反应 感谢杜总的分享！ 运行不起来呢 不明觉厉，膜拜大神，先收藏了 测试能运行的 除了D键可以换基点，A、F、E、C键按了都没反应
页:
[1]
2