多参数动态移动图元

dcl1214 · 发表于 2024-5-27 14:00

(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$ (entlst mod / maxpo0 minpo0
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 /)
(if PT-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
)
(if blck-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)
)
(IF DATA
(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 "[A/F]旋转 "))
)
(if (or (member "E" zimu)
(member "e" zimu)
(member "C" zimu)
(member "c" zimu)
)
(setq tishiyu (strcat tishiyu "[E/C]缩放 "))
)
(if (or (member "D" zimu) (member "d" zimu))
(setq tishiyu (strcat tishiyu "[D]对齐 "))
)
(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))
;坐标返回去给上一级
)
)

(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$ (entlst  mod     /     maxpo0  minpo0 
         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 /) 
    (if  PT-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 
    ) 
    (if  blck-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) 
    ) 
    (IF  DATA 
      (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 "[A/F]旋转 ")) 
      ) 
      (if (or (member "E" zimu) 
        (member "e" zimu) 
        (member "C" zimu) 
        (member "c" zimu) 
    ) 
  (setq tishiyu (strcat tishiyu "[E/C]缩放 ")) 
      ) 
      (if (or (member "D" zimu) (member "d" zimu)) 
  (setq tishiyu (strcat tishiyu "[D]对齐 ")) 
      ) 
      (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)) 
            ;坐标返回去给上一级 
  ) 
)

masterlong · 发表于 2024-5-29 11:12

高飞鸟的动态arx函数库
是目前最好的
可惜只支持到2014

CAD自带的arx函数库也挺好
没有版本问题
就是功能略简单

除此之外我试过的其它方法
包括各种dll和arx
都存在各种无法接受的硬伤
比如不支持按住鼠标中键平移视窗等

masterlong · 发表于 2024-5-29 10:45

grread模拟动态
对大量图元的预览显示较慢
这是函数的硬伤
除此之外
最大的难点是实现捕捉
除了预置捕捉
还有右键捕捉菜单
和手输的临时指定捕捉
杜总的这个代码显然没有考虑这些
对需要精确定位的情况
就不是很合适了

dcl1214 · 发表于 2024-5-28 10:47

zmzk 发表于 2024-5-27 22:24
运行不起来呢

如果缺少函数，列出来，我补充，当然我很多帖子，可能函数在其他帖子里面有

angel066499 · 发表于 2024-5-27 16:27

感谢分享，感谢杜总~~~~

cchessbd · 发表于 2024-5-27 16:31

啊，大牛写的程序，菜鸡表示看不懂。

liuyj · 发表于 2024-5-27 16:52

按键没反应

guosheyang · 发表于 2024-5-27 18:11

感谢杜总的分享！

zmzk · 发表于 2024-5-27 22:24

运行不起来呢

tranque · 发表于 2024-5-28 09:58

不明觉厉，膜拜大神，先收藏了

小菜123 · 发表于 2024-5-28 11:52

测试能运行的

liuyj · 发表于 2024-5-28 12:46

除了D键可以换基点，A、F、E、C键按了都没反应

账号		自动登录	找回密码
密码			注册

[经验] 多参数动态移动图元