仿sketchup动态复制程序(如何支持属性块？)

小毛草 · 发表于 2022-7-30 17:25:11

;_仿sketchup动态复制程序
(defun c:ddc (/ #err4 $orr p1 p2 s e cn a1 d1 ns cnn)
;__________________
(defun ttt (ss n / m)
(defun #err4 (s)
(command ".UNDO" "E")
(setvar "osmode" snap)
(setq *error* $orr)
)
(setq snap (getvar "osmode"))
(setvar "cmdecho" 0)
(setq $orr *error*
*error* #err4
)
(setq ee e
ns (ssadd)
)
(while (setq ee (entnext ee))
(setq ns (ssadd ee ns))
)
(command "erase" ns "")
(command "copy" ss "" "m" "non" p1)
(if (member (substr n (strlen n)) '("/" "*"))
(progn
(setq m 0)
(repeat (atoi n)
(setq m (1+ m))
(cond
((= "/" (substr n (strlen n)))
(command "non"(mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n))))) p1 p2))
)
((= "*" (substr n (strlen n)))
(command "non"(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2))
)
)
)
)
(command "non" (setq p2 (polar p1 a1 (atof n))))
)
(command)
)
;__________________
(princ "\n动态复制程序")
(princ "\n选择要复制的物体:")
(setq s (ssget))
(setq p1 (getpoint "\n复制的起点:"))
(command "undo" "be" "line" p1 p1 "" )
(setq e (entlast) )
(command "copy" s "" "non" p1 pause)
(setq p2 (getvar "lastpoint")
a1 (angle p1 p2)
d1 (distance p1 p2)
)
(setq cn "1*")
(while cn
(ttt s cn)
(initget 128)
(princ "\n输入坐标=复制终点输入数值=修改间距 ")
(princ "\n输入数值n并以 / 结束=间距内等分n次复制输入数值n并以 * 结束=按间距复制n次 ")
(setq cnn (getpoint "\n请按提示输入<退出>:"))
(if (= 'LIST (type cnn))
(setq p2 cnn
a1 (angle p1 p2)
d1 (distance p1 p2)
)
(setq cn cnn)
)
)
(entdel e)
(command "undo" "e")
(princ)
)

;_仿sketchup动态复制程序 
(defun   c:ddc (/ #err4 $orr p1 p2 s e cn a1 d1 ns cnn) 
 ;__________________ 
  (defun ttt (ss n / m) 
  (defun #err4 (s) 
    (command ".UNDO" "E") 
    (setvar "osmode" snap) 
    (setq *error* $orr) 
  ) 
  (setq snap (getvar "osmode")) 
  (setvar "cmdecho" 0) 
  (setq $orr *error* 
        *error* #err4 
  ) 
    (setq ee e 
      ns (ssadd) 
    ) 
    (while (setq ee (entnext ee)) 
      (setq ns (ssadd ee ns)) 
    ) 
    (command "erase" ns "") 
    (command "copy" ss "" "m" "non" p1) 
    (if (member (substr n (strlen n)) '("/" "*"))       
      (progn 
  (setq m 0) 
  (repeat  (atoi n) 
    (setq m (1+ m)) 
    (cond 
      ((= "/" (substr n (strlen n))) 
       (command "non"(mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n))))) p1 p2)) 
      ) 
      ((= "*" (substr n (strlen n))) 
       (command "non"(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)) 
      ) 
    ) 
  ) 
      ) 
      (command "non" (setq p2 (polar p1 a1 (atof n)))) 
    ) 
    (command) 
  ) 
 ;__________________ 
  (princ "\n动态复制程序") 
  (princ "\n选择要复制的物体:") 
  (setq s (ssget)) 
  (setq p1 (getpoint "\n复制的起点:")) 
  (command "undo" "be" "line" p1 p1 "" ) 
  (setq e (entlast) ) 
  (command "copy" s "" "non" p1 pause) 
  (setq  p2 (getvar "lastpoint") 
  a1 (angle p1 p2) 
  d1 (distance p1 p2) 
  ) 
  (setq cn "1*") 
  (while cn 
    (ttt s cn) 
    (initget 128) 
    (princ "\n输入坐标=复制终点                         输入数值=修改间距 ") 
    (princ "\n输入数值n并以 / 结束=间距内等分n次复制    输入数值n并以 * 结束=按间距复制n次 ") 
    (setq cnn (getpoint "\n请按提示输入<退出>:")) 
    (if  (= 'LIST (type cnn)) 
      (setq p2 cnn 
      a1 (angle p1 p2) 
      d1 (distance p1 p2) 
      ) 
      (setq cn cnn) 
    ) 
  ) 
  (entdel e) 
  (command "undo" "e") 
  (princ) 
)

一直不得要领，麻烦那位大神改一下？这个还是比较好用的，用习惯了的话，可以实时修改！

G〆h · 发表于 2022-7-31 16:35:52

试了下，常规图形，图块，天正图块都能正常实现，动态属性块不能。是有些问题要改进。
我平常用的，只是无法动态修改
(defun C:CO ()
(vl-cmdf "COPY" (LM:ssget "\ncopy阵列选择对象：" nil) "" (getpoint "选择起点：") "A" (getint "\ncopy阵列数量:") "F" )
)
;带提示的ssget
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(if arg
(setq sel (vl-catch-all-apply 'ssget arg))
(setq sel (vl-catch-all-apply 'ssget ))
)
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

小毛草 · 发表于 2022-7-31 17:43:18

你平常用的不能动态调整，不如上面的好用！

G〆h · 发表于 2023-7-15 09:21:51

顶下楼主的贴，希望有大神出手完善，非常实用的功能。不能因为小有点问题就明珠蒙尘。

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

[源码] 仿sketchup动态复制程序(如何支持属性块？)