有没有随意拖拽坐标标注的LISP？

wzm56209487 · 发表于 2013-8-12 15:41:31

大神们就是nb

13826031454 · 发表于 2013-8-16 02:41:27

顶顶顶顶顶顶

yutianweidi · 发表于 2013-8-16 03:51:53

;拉伸坐标标注
;用鼠标点起尺寸或坐标标注块然后拉伸，当你点取了其它物体时要求你重选
;当你按回车时或点了空格时退出

(DEFUN c:AF()
  (while (setq ed1 (entsel "\n请选择坐标标注或尺寸标注:"))
(setq pt1 (cadr ed1))  ;取出点取的坐标
(setq en1 (car ed1))
(setq ed2 (entget en1))

(setq dd 2)
(setq ss1 (ssadd))
(setq ss2 (ssadd))
(if(= (strcase (cdr (assoc 0 ed2))) "DIMENSION")
(progn
   (setq pt2 (cdr (assoc 11 ed2)))  ;文字中点
   (setq pt3 (cdr (assoc 14 ed2)))  ;标注右侧点
   (setq pt10 (cdr (assoc 10 ed2)))  ;插入点坐标
   (setq dx  (abs (- (car pt2) (car pt3))))
   (setq dy  (abs (- (cadr pt2) (cadr pt3))))
   (if(> dx dy)
   (progn
      (if(> (car pt2) (car pt3))
      (progn
         (setq pt4 (list (+ (car pt2) dd) (+ (cadr pt2) dd))) ;窗口左上角点
         (setq pt5 (list (- (car pt3) dd) (- (cadr pt2) dd))) ;窗口右下角点
      )  ;水平
      (progn
         (setq pt4 (list (+ (car pt3) dd) (+ (cadr pt2) dd)))
         (setq pt5 (list (- (car pt2) dd) (- (cadr pt2) dd)))
      )
      )
   )
   (progn
      (if(> (cadr pt2) (cadr pt3))
      (progn
         (setq pt4 (list (+ (car pt2) dd) (+ (cadr pt2) dd)))
         (setq pt5 (list (- (car pt3) dd) (- (cadr pt3) dd)))
      )
      (progn
         (setq pt4 (list (+ (car pt3) dd) (+ (cadr pt3) dd)))
         (setq pt5 (list (- (car pt2) dd) (- (cadr pt2) dd)))
      )  ;progn
      ) ;if
   )  ;progn
   )  ;if
;以上是处理坐标标注以下是处理尺寸标注
   (if(and (/= (car pt2) (car pt3)) (/= (cadr pt2) (cadr pt3)))
   (progn  ;处理尺寸标注
      (if(> (abs (- (car pt2) (car pt10)))  (abs (- (cadr pt2) (cadr pt10))))
      (progn  ;水平向
      (setq pt4 (polar pt2 (/ pi 20) dd))
      (setq pt5 (polar pt2 (* pi 1.05) dd))
      )
      (progn ;垂直向
      (setq pt4 (polar pt2 (* pi 0.45) dd))
      (setq pt5 (polar pt2 (* pi 1.45) dd))
      )
      )
   )
   )
   (setq pt4 (trans pt4 2 1))
   (setq pt5 (trans pt5 2 1))
;    (setq pt1 (trans pt1 2 1))
   (setq ss1 (ssget "c" pt4 pt5));
   (setq i (sslength ss1))
   (setq j 0)
   (setq k 0)
   (if(> i 1)
      (progn
      (setq ss2 (ssdel en1 ss1))
      (setq k 1)
      )
   )
   (if(> i 0)
      (if(= k 0)
      (command "stretch" "c" pt4 pt5 "" pt1 pause)
      (command "stretch" "c" pt4 pt5  "r" ss2 "" pt1 pause)
      )
   )
   )  ;progn
   (progn
   (princ "\n你应该选择坐标标注，若想退出按回车或空选!!")
   )
) ;if
  )  ;while
)
---------------------------------------------------------
;双向标注
(DEFUN c:AG()
  (setq layername (getvar  "clayer"))
  (setq mylayer    (substr layername 1 2))
(if(< (strlen mylayer) 2) (setq mylayer "dim")
         (progn
            (setq mylayer  (strcat mylayer "dim"))
            (if(not (tblsearch "LAYER" mylayer))
               (setq mylayer "dim")
            )
         )
   )
  (command "layer" "u" mylayer  "")
  (command  "layer" "t"  mylayer "")
  (command  "layer"  "s"  mylayer  "")
  (command "layer" "on" mylayer "")
  (while(setq pt1 (getpoint "\n请输入标注起点坐标:"))
(while(not (setq pt2 (getpoint pt1 "\n请输入标注终点坐标:"))) (setq i 1))
(setq fjosmode (getvar "osmode"))
(setvar "osmode" 0)
(setq x1 (car pt1)  y1 (cadr pt1))
(setq x2 (car pt2)  y2 (cadr pt2))
(if(< (abs (- x2 x1)) (* 0.1 (abs (- y2 y1))))
(command "dimordinate" pt1 pt2)

(if(< (abs (- y2 y1)) (* 0.1 (abs (- x2 x1))))
   (command "dimordinate" pt1 pt2)
   (progn
      (setq pt3 (list x1 y2))
      (command "dimordinate" pt1 pt3)
      (setq pt3 (list x2 y1))
      (command "dimordinate" pt1 pt3)
   )
)
)
(setvar "osmode" fjosmode)
  )
(command "layer" "s" layername "")
)

mycad · 发表于 2013-8-16 17:18:28

顶！！！！！！！！

mj0000 · 发表于 2013-9-5 13:34:12

顶下，看G版程序

原地踏步 · 发表于 2013-9-19 11:08:01

学习一下反应器。

xhq1954425 · 发表于 2013-9-19 15:29:15

厉害！真是厉害！

emk · 发表于 2013-9-20 10:17:10

路过瞧一瞧,G版的要看的

86023383 · 发表于 2013-9-20 17:27:59

好东西！！！！！！！

阿然 · 发表于 2013-9-22 09:14:32

回复看gu版

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