本帖最后由 wjnnan 于 2014-7-1 12:37 编辑
一直想弄个自己的简单的审图批注,在论坛里搜罗的两个lisp,无奈自己能力还不够,自己合并不了,请哪位大神给合并一下- ;004-审图云线
- ;矩形画修订云线-审图版 by edata 2013-12-14
- ;写这个程序的目的是平时审图的时候需要标记,
- ;部分来源;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108694&fromuid=338795,
- ;部分函数来自明经.
- ;默认比例100,可以使用时更改.云线图层默认不打印,其余全局变量按需自行更改,
- ;可以选择绘制矩形,或者拾取多段线.
- ;文字始终水平方向,具体位置和方向需要指定.
- (defun c:xd(/ ss ANG DS EN EN2 EN3 ENTEXT IN_PT LST LST2 LST3 MPT NTEXTLST P1 P3 PT PT1 PT2 TEXTLST TEXTPT X Y minpoint maxpoint)
- (vl-load-com)
- (defun *error*_New (msg)
- (if *error*_Old (setq *error* *error*_Old))
- (if cmd_old (setvar "cmdecho" cmd_old))
- (if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
- (princ )
- )
- (vla-EndUndoMark
- (vla-get-ActiveDocument (vlax-get-acad-object))
- )
- (princ)
- )
- (setq *error*_Old *error*) ;保存出错处理函数
- (setq *error* *error*_New)
- (vla-startUndoMark(vla-get-ActiveDocument (vlax-get-acad-object)))
- ;全局变量设置
- (or xd_scale(setq xd_scale 100));整体比例
- (or xd_cloud(setq xd_cloud 6)) ;云线默认弧长
- (or xd_txth(setq xd_txth 5));云线默认字高
- (or xd_la(setq xd_la "修订云线-edata"));默认云线图层名
- (or xd_col(setq xd_col 1));默认云线图层颜色1
- (or xd_print(setq xd_print 0));默认云线图层不打印
- (or xd_style(setq xd_style "TSSD_Rein"));默认样式名
- (or xd_font(setq xd_font "tssdeng.shx"));默字体名
- (or xd_big_font(setq xd_big_font "hztxt.shx"));默认大字体名
- (initget "b")
- (if (and (if (setq p1(getpoint (strcat"\n指定第一点<B 当前比例"(rtos xd_scale 2 0) ">/<选择对象>:")))(progn
- (if (or (= p1 "b")(= p1 "B"))(progn(setq xd_scale(getint (strcat"\n请输入比例<当前"(rtos xd_scale 2 0) ">:"))) (c:xd)(exit))(setq p3(getcorner p1 "\n指定对角点:")))
- )(progn
- (princ "\n请选择多段线:")
- (setq ss(ssget ":E:S" '((0 . "LWPOLYLINE"))))
- )
- ))
- (progn
- (if (=(tblobjname "LAYER" xd_la) nil)
- (entmake (list '(0 . "LAYER")
- '(100 . "AcDbSymbolTableRecord")
- '(100 . "AcDbLayerTableRecord")
- '(70 . 0)
- '(6 . "Continuous")
- (cons 2 xd_la)
- (cons 62 xd_col)
- (cons 290 xd_print)
- )
- ))
- (if (=(tblobjname "STYLE" xd_style) nil)
- (progn
- (entmake (list '(0 . "STYLE")
- '(100 . "AcDbSymbolTableRecord")
- '(100 . "AcDbTextStyleTableRecord")
- (cons 2 xd_style)
- '(70 . 0)
- '(40 . 0)
- '(41 . 0)
- (cons 3 xd_font)
- (cons 4 xd_big_font)))))
- (defun 2pt4pt(p1 p3 / p2 p4 pts )
- (setq pts(vl-sort (list p1 p3)
- (function (lambda (e1 e2)
- (and (< (car e1) (car e2))(< (cadr e1) (cadr e2)) ) ) )))
- (setq p1(car pts)
- p3(cadr pts))
- (setq p2(list (car p3)(cadr p1))
- p4(list (car p1)(cadr p3))
- )
- (list p1 p2 p3 p4)
- )
- (if ss (progn
- (princ "\n选择模式:")
- (setq lst(vertexs (ssname ss 0)))
- (entdel (ssname ss 0))
- )
- (setq lst (2pt4pt p1 p3)))
-
- (setq en(entmakex (append
- (list '(0 . "LWPOLYLINE")
- '(100 . "AcDbEntity")
- '(100 . "AcDbPolyline")
- (cons 8 xd_la)
- (cons 90 (length lst))
- (cons 70 1)
- )
- (mapcar '(lambda (pt)(cons 10 pt)) lst ))))
- (if (>= (vla-get-length (vlax-ename->vla-object en)) (* 12 xd_scale))
- (progn
- (setq cmd_old(getvar "cmdecho"))
- (setvar "cmdecho" 0)
- (vl-cmdf "_revcloud" "a" (* xd_cloud xd_scale) "" "s" "c" "o" "" en "N")
- (if cmd_old (setvar "cmdecho" cmd_old))
- )
- (princ "\n矩形太小,无法生成修订云线!"))
- (setq en (entlast))
- (vla-getboundingbox (vlax-ename->vla-object en) 'minpoint 'maxpoint)
- (setq p1 (vlax-safearray->list maxpoint)
- p3 (vlax-safearray->list minpoint))
- (setq mpt(mapcar '(lambda(x y)(/ (+ x y) 2.)) p1 p3))
-
- (entmod (subst(cons 8 xd_la)(assoc 8 (entget en))(entget en)))
-
- (if (and (setq pt1(getpoint mpt "\n指定引线点:"))
- (/= (ISPTINPM pt1 lst) t)
- )
- (progn
- (setq en2(entmakex(list (cons 0 "line")(cons 8 xd_la) (cons 10 mpt)(cons 11 pt1))))
- (setq in_pt(vlax-safearray->list(vlax-variant-value(vla-IntersectWith
- (vlax-ename->vla-object en)
- (vlax-ename->vla-object en2) acExtendNoNe))))
- (if in_pt (entmod (subst(cons 10 in_pt)(assoc 10 (entget en2))(entget en2))))
-
-
- (if (setq pt2 (getpoint pt1"\n指定文字方向:"))
- (progn
- (setq ang (angle pt1 (list(car pt2)(cadr pt1))))
- (if en2(entdel en2))
- (setq lst2(list in_pt pt1 (list(car pt2)(cadr pt1))))
- (setq en3(entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")(cons 8 xd_la) (cons 90 (length lst2)))
- (mapcar '(lambda (pt)(cons 10 pt)) lst2 )) ))
-
- (setq entext(entmakex (list '(0 . "TEXT")
- (cons 1 "输入文字")
- (cons 10 (polar pt1 (* pi 0.5) (* 0.625 xd_scale)))
- (cons 7 xd_style)
- (cons 8 xd_la)
- (cons 41 0.7)
- (cons 40 (* xd_txth xd_scale))
- (cons 73 0)
- (cons 72 (cond((> (car pt1) (car pt2))2)(t 0)))
- (cons 11 (polar pt1 (* pi 0.5) (* 0.625 xd_scale)))
- )))
- (vl-cmdf "_ddedit" entext "" )
- (setq textlst(textbox (entget entext)))
- (setq ntextlst(2pt4pt (car textlst)(cadr textlst)))
- (setq ds(distance (car ntextlst)(cadr ntextlst)))
- (setq textpt(polar pt1 ang ds))
- (setq lst3(list in_pt pt1 textpt))
- (if en3(entdel en3))
- (entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")(cons 8 xd_la) (cons 90 (length lst3)))
- (mapcar '(lambda (pt)(cons 10 pt)) lst3 ))
- ))(progn(if en2(entdel en2)) (princ "\n未指定文字方向!"))))(princ "\n未指定引线!"))
- );end_progn
- (princ"\n Nothing!")
- )
- (vla-EndUndoMark
- (vla-get-ActiveDocument (vlax-get-acad-object))
- )
- (if *error*_Old (setq *error* *error*_Old))
- (gc)
-
- (princ)
-
- )
- (defun ISPTINPM (XPT POINTS / x y )
- (equal pi(abs(apply '+(mapcar'(lambda (X Y)(rem (- (angle XPT X) (angle XPT Y)) pi))
- (reverse (cdr (reverse (cons (last POINTS) POINTS))))
- POINTS
- )
- )
- )
- 1e-6
- ) ;end_equal
- )
- ;;返回多段线顶点表
- (defun vertexs (ename / plist pp n)
- (setq obj (vlax-ename->vla-object ename))
- (setq plist (vlax-safearray->list
- (vlax-variant-value
- (vla-get-coordinates obj))))
- (setq n 0)
- (repeat (/ (length plist) 2)
- (setq pp (append pp (list (list (nth n plist)(nth (1+ n) plist)))))
- (setq n (+ n 2))
- )
- pp
- )
- (prompt "\n矩形修定云线带引线文字by edata@2013.12.14! 命令 xd")
- (princ)
-
- ;016-插入日期及时间
- (defun c:IT ( / da lst)
- (princ "\n 插入日期及时间")
- (setq da (rtos(getvar "cdate")2 8)
- lst(mapcar '(lambda(x)(substr da (car x) (cadr x))) '((1 4) (5 2) (7 2) (10 2)(12 2)(14 2)(16 2))))
- (COMMAND "STYLE" "tssd_rein" "Tssdeng.shx,hztxt"
- "250" "0.7" "0" "n" "n" "n")
- (setq pt1 (getpoint "\n\t放置点 : "))
- (vl-cmdf ".text" "j" "mc" pt1 "0"
- (apply 'strcat (mapcar '(lambda(x y)(strcat x y)) lst '("年" "月" "日" "时" "分")))
- )
- (princ)
- )
要求见下图
|