社区 › AutoLISP/Visual LISP 编程技术 › 有没有随意拖拽坐标标注的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版

查看完整版本: 有没有随意拖拽坐标标注的LISP？