求：圈动链带 线、文字动

duotu007

langjs 发表于 2014-6-30 20:09
能加个F8沿Y轴移动。至于捕捉和批量，编程太复杂了还是算了吧

freehand8008

langjs 发表于 2014-6-30 20:09
能加个F8沿Y轴移动。至于捕捉和批量，编程太复杂了还是算了吧

能加一个是一个，得空麻烦给加一个吧，谢谢了

langjs

稍微修改一下，带正交的，带批量的程序来了。捕捉就算了，那玩意太复杂



;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
;;; 移动程序    by:langjs
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:tt (/ code d d0 data dis0 ent ent1 entc enttx gr i loop lst lst0 n name nameent nent pt pt0 pt1 pt2 pt3 ptlst r ss ss0 ss1 x
               x0 x1 y0 y1 )
  (defun #err001 (s)
    (command ".UNDO" "E") (command ".UNDO" "") (setq *error* $orr))
  (defun reent (ent ptlst / i nent x)
    (setq i -1  nent '())
    (foreach x ent
      (setq nent (append   nent
      (list (if (and (= (car x) 10) (/= (nth (setq i (1+ i))ptlst ) nil)) (cons 10 (nth i ptlst)) x ))))))
  (defun emod (ent i n)
    (subst (cons i n) (assoc i ent) ent ))
  (setvar "cmdecho" 0)
  (command ".UNDO" "BE")
  (setq $orr *error*)
  (setq *error* #err001)
  (prompt "\n选择圆:")
  (setq ss0 (ssget ":S" '((0 . "CIRCLE")))lst0 '())
  (repeat (setq j (sslength ss0))
    (setq ent (entget (setq namec (ssname ss0 (setq j (1- j)))))  pt (cdr (assoc 10 ent))
          r (cdr (assoc 40 ent))  lst '()  i 0  )
    (redraw namec 3)
    (repeat 359
      (setq lst (cons (* (/ i 180.0) pi) lst) i (1+ i)))
    (setq lst (mapcar' (lambda (i) (polar pt i (+ r 1))) lst ))
    (setq entc ent  ss (ssget "F" (list (polar pt 0.0 r) (polar pt pi r)) '((0 . "TEXT")))
          enttx (entget (ssname ss 0))  ss (ssget "CP" lst '((0 . "TEXT,CIRCLE,LWPOLYLINE"))) lst '())
    (repeat (setq i (sslength ss))
      (setq ent (entget (ssname ss (setq i (1- i)))))
      (if (= (cdr (assoc 0 ent)) "LWPOLYLINE")
        (progn
          (if (< (distance pt (setq pt1 (cdr (assoc 10 ent)))) (distance pt (setq pt2 (cdr (assoc 10 (reverse ent))))))
            (setq pt1 pt2))
          (setq d (angle pt pt1)pt2 (polar pt d r)pt3 (polar pt d (* 0.5 (+ (distance pt pt1) (distance pt pt2)))))
          (if (or(< d (* 0.5 pi))(> d (* 1.5 pi)))
            (setq pt3 (polar pt3 (- d (* 0.5 pi)) 200.0)) (setq pt3 (polar pt3 (+ d (* 0.5 pi)) 200.0)))
          (if (setq ss1 (ssget "F" (list (polar pt3 d 300) (polar pt3 (+ pi d) 300)) '((0 . "TEXT"))))
            (setq ent1 (entget (ssname ss1 0))  lst (cons (list pt1 ent ent1) lst))))))
    (setq lst0 (cons (list entc enttx lst) lst0)))
  (if (= (length lst0) 1)  (setq pt0 (cdr (assoc 10 (car (car lst0))))) (setq pt0 (getpoint "\n指定基点:")) )
  (entmake (list '(0 . "LINE") (cons 10 pt0) (cons 11 pt0)))
  (setq name (entlast)        nameent (entget name)        loop t )
  (prompt "\n指定位置:")
  (while loop
    (setq gr (grread t 15 0)  code (car gr)  data (cadr gr))
    (cond  ((= code 2)
        (redraw)
        (if (= data 15)
          (progn (if (= (getvar "ORTHOMODE") 0)
              (progn(prompt "<正交 开>")(setvar "orthomode" 1)) (progn(prompt "<正交 关>")(setvar "orthomode" 0))))))
      ((= code 3)(setq loop nil)        (entdel name)(command ".UNDO" "E"))
      ((= code 5)(if (= (getvar "ORTHOMODE") 1)
          (progn (setq x0 (car pt0) y0 (cadr pt0)  x1 (car data) y1 (cadr data))
            (if (> (abs (- x0 x1)) (abs (- y0 y1))) (setq data (list x1 y0)) (setq data (list x0 y1)))))
        (setq dis0 (distance pt0 data)   d0 (angle pt0 data))
        (entmod (emod nameent 11 (polar pt0 d0 dis0)))
        (foreach j lst0
          (setq entc (car j)enttx (cadr j)lst (caddr j)        pt (polar (cdr (assoc 10 entc)) d0 dis0)
                entc (emod entc 10 pt)        enttx (emod enttx 10 pt)enttx (emod enttx 11 pt))
          (entmod entc)  (entmod enttx)
          (foreach i lst
            (setq pt1 (car i)  ent (cadr i)  ent1 (caddr i)  d (angle pt pt1)
                  pt2 (polar pt d r)  ent (reent ent (list pt1 pt2)))
            (entmod ent)
            (setq pt3 (polar pt d (* 0.5 (+ (distance pt pt1) (distance pt pt2)))))
            (if (or  (< d (* 0.5 pi)) (> d (* 1.5 pi)))
              (setq pt3 (polar pt3 (- d (* 0.5 pi)) 100.0))(setq pt3 (polar pt3 (+ d (* 0.5 pi)) 100.0)  d (+ d pi)))
            (setq ent1 (emod ent1 10 pt3)  ent1 (emod ent1 11 pt3)  ent1 (emod ent1 50 d))
            (entmod ent1))))
      ((or (= code 11) (= code 25) )
        (setq loop nil)        (entdel name)        (command ".UNDO" "E")        (command ".UNDO" ""))
      (t )) t )
  (setq *error* $orr)
  (princ)
)

freehand8008

langjs 发表于 2014-7-1 10:24
稍微修改一下，带正交的，带批量的程序来了。捕捉就算了，那玩意太复杂

GOOD!GOOD!GOOD!