[LISP函数]：珍藏多年的LISP放出，欢迎大家

2sunny2 · 发表于 2008-9-24 12:01:18

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

珍藏多年的LISP放出，一个一个来,都是我自己常用的，欢迎大家
01 多种COPY，

;;;********************************************************图形矫正程序-jz
(defun c:cc (/ p1 p2 s e cn)
;__________________
(defun ttt (ss n / m)
(setq ee e
ns (ssadd)
)
(while (setq ee (entnext ee))
(setq ns (ssadd ee ns))
)
(command "erase" ns "")
(command "copy" ss "" "m" "non" p1)
(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
)
)
)
(t
(command "non"
(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)
)
)
)
)
(command)
)
;__________________
(princ "\n选择要复制的物体:")
(setq s (ssget))
(setq p1 (getpoint "\n复制的起点:"))
(setq p2 (getpoint p1 "\n复制的终点:"))
(setq e (entlast))
(command "copy" s "" "non" p1 "non" p2)
(while (/= 0
(atof (setq cn (getstring "\n份数(以 / 结束为等分):")))
)
(ttt s cn)
)
(princ)
)
(defun c:c1 (/ p1 p2 s e cn a1 d1 ns cnn)
;__________________
(defun ttt (ss n / m)
(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选择要复制的物体:")
(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)
)
(defun c:c2 (/ p1 p2 s e cn)
;__________________
(defun ttt (ss n / m)
(setq ee e
ns (ssadd)
)
(while (setq ee (entnext ee))
(setq ns (ssadd ee ns))
)
(command "erase" ns "")
(command "copy" ss "" "m" "non" p1)
(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
)
)
)
(t
(command "non"
(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)
)
)
)
)
(command)
)
;__________________
(princ "\n选择要复制的物体:")
(setq s (ssget))
(setq p1 (getpoint "\n复制的起点:"))
(setvar "lastpoint" p1)
;(setq p2 (getpoint p1 "\n复制的终点:"))
(setq e (entlast))
(command "copy" s "" "non" p1 pause)
(if (not (equal p1 (setq p2 (getvar "lastpoint"))))
(while (/= 0
(atof (setq cn (getstring "\n份数(以 / 结束为等分):")))
)
(ttt s cn)
)
)
(princ)
)
;;;|增强拷贝
(defun c:c3 (/ getpt getpt1 ss ptx pty db n x y gtin)
(setq getpt1 (acet-ss-drag-move
(setq ss (ssget))
(setq getpt (getpoint "\n&点取基点:"))
1
)
)
(setq ptx (- (car getpt1) (car getpt))
pty (- (cadr getpt1) (cadr getpt))
y 0
)
(vl-cmdf ".copy" ss "" getpt getpt1)
(while (setq gtin (- (getint "\n重复次数:") 1))
(vl-cmdf ".undo" "e")
(if (/= y 0)
(vl-cmdf ".u")
)
(setq n 1
x 0
db nil
)
(if (/= y 0)
(vl-cmdf ".u")
)
(vl-cmdf ".undo" "be")
(repeat gtin
(setq db (cons (list (+ (* n ptx) (car getpt1))
(+ (* n pty) (cadr getpt1))
0.0
)
db
)
)
(setq n (1+ n))
)
(repeat (length db)
(vl-cmdf ".copy" ss "" getpt (nth x (reverse db)))
(setq x (1+ x))
)
(vl-cmdf ".undo" "e")
(vl-cmdf ".undo" "be")
(setq y (1+ y))
)
(princ)
)

;;;********************************************************图形矫正程序-jz 
(defun c:cc (/ p1 p2 s e cn) 
 ;__________________ 
  (defun ttt (ss n / m) 
    (setq ee e 
          ns (ssadd) 
    ) 
    (while (setq ee (entnext ee)) 
      (setq ns (ssadd ee ns)) 
    ) 
    (command "erase" ns "") 
    (command "copy" ss "" "m" "non" p1) 
    (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 
           ) 
         ) 
        ) 
        (t 
         (command "non" 
                  (mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2) 
         ) 
        ) 
      ) 
    ) 
    (command) 
  ) 
 ;__________________ 
    (princ "\n选择要复制的物体:") 
  (setq s (ssget)) 
  (setq p1 (getpoint "\n复制的起点:")) 
  (setq p2 (getpoint p1 "\n复制的终点:")) 
  (setq e (entlast)) 
  (command "copy" s "" "non" p1 "non" p2) 
  (while (/= 0 
             (atof (setq cn (getstring "\n份数(以 / 结束为等分):"))) 
         ) 
    (ttt s cn) 
  ) 
  (princ) 
) 
 
 
 
(defun c:c1 (/ p1 p2 s e cn a1 d1 ns cnn) 
 ;__________________ 
  (defun ttt (ss n / m) 
    (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选择要复制的物体:") 
  (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) 
) 
 
 
(defun c:c2 (/ p1 p2 s e cn) 
 ;__________________ 
  (defun ttt (ss n / m) 
    (setq ee e 
          ns (ssadd) 
    ) 
    (while (setq ee (entnext ee)) 
      (setq ns (ssadd ee ns)) 
    ) 
    (command "erase" ns "") 
    (command "copy" ss "" "m" "non" p1) 
    (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 
           ) 
         ) 
        ) 
        (t 
         (command "non" 
                  (mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2) 
         ) 
        ) 
      ) 
    ) 
    (command) 
  ) 
 ;__________________ 
  (princ "\n选择要复制的物体:") 
  (setq s (ssget)) 
  (setq p1 (getpoint "\n复制的起点:")) 
  (setvar "lastpoint" p1) 
                                        ;(setq p2 (getpoint p1 "\n复制的终点:")) 
  (setq e (entlast)) 
  (command "copy" s "" "non" p1 pause) 
  (if (not (equal p1 (setq p2 (getvar "lastpoint")))) 
    (while (/= 0 
               (atof (setq cn (getstring "\n份数(以 / 结束为等分):"))) 
           ) 
      (ttt s cn) 
    ) 
  ) 
  (princ) 
) 
 
 
;;;|增强拷贝 
(defun c:c3 (/ getpt getpt1 ss ptx pty db n x y gtin) 
  (setq        getpt1 (acet-ss-drag-move 
                 (setq ss (ssget)) 
                 (setq getpt (getpoint "\n&点取基点:")) 
                 1 
               ) 
  ) 
  (setq        ptx (- (car getpt1) (car getpt)) 
        pty (- (cadr getpt1) (cadr getpt)) 
        y   0 
  ) 
  (vl-cmdf ".copy" ss "" getpt getpt1) 
  (while (setq gtin (- (getint "\n重复次数:") 1)) 
    (vl-cmdf ".undo" "e") 
    (if        (/= y 0) 
      (vl-cmdf ".u") 
    ) 
    (setq n  1 
          x  0 
          db nil 
    ) 
    (if        (/= y 0) 
      (vl-cmdf ".u") 
    ) 
    (vl-cmdf ".undo" "be") 
    (repeat gtin 
      (setq db (cons (list (+ (* n ptx) (car getpt1)) 
                           (+ (* n pty) (cadr getpt1)) 
                           0.0 
                     ) 
                     db 
               ) 
      ) 
      (setq n (1+ n)) 
    ) 
    (repeat (length db) 
      (vl-cmdf ".copy" ss "" getpt (nth x (reverse db))) 
      (setq x (1+ x)) 
    ) 
    (vl-cmdf ".undo" "e") 
    (vl-cmdf ".undo" "be") 
    (setq y (1+ y)) 
  ) 
  (princ) 
)

命令为：cc c1 c2 c3 对应不同COPY方法

zml84 · 发表于 2008-9-24 15:38:53

最好格式搞好，写个简介。

rzg1972 · 发表于 2008-9-24 18:20:42

非常感谢楼主，虽然不太明白。

mico_ye · 发表于 2008-9-25 10:17:08

不行呀

zx0sl · 发表于 2008-9-26 11:17:18

楼主自己写的，还是网上收集的啊

安杰 · 发表于 2008-9-26 19:57:07

搞什么

yoyoho · 发表于 2008-9-27 09:43:23

程序下下来研究
谢谢楼主!

bikeboy · 发表于 2008-9-28 18:09:21

好像还不错啊

c3a139 · 发表于 2008-10-4 13:04:28

有个说明更好一些

huyong · 发表于 2008-10-4 16:01:49

谢谢楼主，但C3复制有误，
“命令: c3
选择对象: 找到 1 个

选择对象:
&点取基点:; 错误: no function definition: ACET-SS-DRAG-MOVE

命令: ”
其他的不错。

and2008 · 发表于 2008-10-5 15:09:09

我试用了一下，4个命令都可以完成。cc和c2复制方式好像差不多，定义了复制的起终点几等分复制；c1是需要根据你输入复制间距进行复制；c3根据你输入的复制次数进行一次性多次复制。妥否？还需要楼主订正下。

liyl123 · 发表于 2008-10-7 11:43:27

貌似Express里面的copym

dzwmy · 发表于 2008-10-29 21:34:16

高手，学习了，受益匪浅

zlzxtfl · 发表于 2008-11-2 19:17:03

不错,有参考价值

leawe · 发表于 2008-11-4 00:25:57

不错,有参考价值

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

[LISP函数]：珍藏多年的LISP放出，欢迎大家

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子