明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1580|回复: 2

[源码] 请大神给合并2个源码

[复制链接]
发表于 2014-7-1 10:23:28 | 显示全部楼层 |阅读模式
本帖最后由 wjnnan 于 2014-7-1 12:37 编辑

一直想弄个自己的简单的审图批注,在论坛里搜罗的两个lisp,无奈自己能力还不够,自己合并不了,请哪位大神给合并一下
  1. ;004-审图云线
  2. ;矩形画修订云线-审图版 by edata 2013-12-14
  3. ;写这个程序的目的是平时审图的时候需要标记,
  4. ;部分来源;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108694&fromuid=338795,
  5. ;部分函数来自明经.
  6. ;默认比例100,可以使用时更改.云线图层默认不打印,其余全局变量按需自行更改,
  7. ;可以选择绘制矩形,或者拾取多段线.
  8. ;文字始终水平方向,具体位置和方向需要指定.
  9. (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)
  10.   (vl-load-com)
  11.   (defun *error*_New (msg)
  12.   (if *error*_Old (setq *error* *error*_Old))
  13.     (if cmd_old (setvar "cmdecho" cmd_old))
  14.   (if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
  15.     (princ )
  16.   )
  17.   (vla-EndUndoMark      
  18.     (vla-get-ActiveDocument (vlax-get-acad-object))
  19.   )  
  20.   (princ)
  21. )
  22. (setq *error*_Old *error*)    ;保存出错处理函数
  23. (setq *error* *error*_New)
  24. (vla-startUndoMark(vla-get-ActiveDocument (vlax-get-acad-object)))
  25.   ;全局变量设置
  26.   (or xd_scale(setq xd_scale 100));整体比例
  27.   (or xd_cloud(setq xd_cloud 6)) ;云线默认弧长
  28.   (or xd_txth(setq xd_txth 5));云线默认字高
  29.   (or xd_la(setq xd_la "修订云线-edata"));默认云线图层名
  30.   (or xd_col(setq xd_col 1));默认云线图层颜色1
  31.   (or xd_print(setq xd_print 0));默认云线图层不打印
  32.   (or xd_style(setq xd_style "TSSD_Rein"));默认样式名
  33.   (or xd_font(setq xd_font "tssdeng.shx"));默字体名
  34.   (or xd_big_font(setq xd_big_font "hztxt.shx"));默认大字体名
  35.   (initget "b")
  36.   (if (and (if (setq p1(getpoint (strcat"\n指定第一点<B 当前比例"(rtos xd_scale 2 0) ">/<选择对象>:")))(progn
  37.      (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指定对角点:")))
  38.      )(progn
  39.         (princ "\n请选择多段线:")
  40.        (setq ss(ssget ":E:S" '((0 . "LWPOLYLINE"))))
  41.        )
  42.        ))   
  43.     (progn      
  44.       (if (=(tblobjname "LAYER" xd_la) nil)
  45.         (entmake (list '(0 . "LAYER")
  46.          '(100 . "AcDbSymbolTableRecord")
  47.          '(100 . "AcDbLayerTableRecord")
  48.          '(70 . 0)
  49.          '(6 . "Continuous")
  50.    (cons 2 xd_la)
  51.          (cons 62 xd_col)
  52.          (cons 290 xd_print)
  53.     )
  54.   ))
  55.       (if (=(tblobjname "STYLE" xd_style) nil)
  56.         (progn
  57.         (entmake (list '(0 . "STYLE")
  58.                        '(100 . "AcDbSymbolTableRecord")
  59.                        '(100 . "AcDbTextStyleTableRecord")
  60.                        (cons 2  xd_style)
  61.                        '(70 . 0)
  62.                        '(40 . 0)
  63.                        '(41 . 0)
  64.                        (cons 3  xd_font)
  65.                        (cons 4  xd_big_font)))))
  66. (defun 2pt4pt(p1 p3 / p2 p4 pts )
  67.       (setq pts(vl-sort (list p1 p3)
  68.              (function (lambda (e1 e2)
  69.                          (and (< (car e1) (car e2))(< (cadr e1) (cadr e2)) ) ) )))
  70.       (setq p1(car pts)
  71.       p3(cadr pts))
  72.       (setq p2(list (car p3)(cadr p1))
  73.       p4(list (car p1)(cadr p3))      
  74.       )
  75.       (list p1 p2 p3 p4)
  76.   )
  77.       (if ss (progn
  78.          (princ "\n选择模式:")
  79.          (setq lst(vertexs (ssname ss 0)))
  80.          (entdel (ssname ss 0))
  81.          )
  82.   (setq lst (2pt4pt p1 p3)))
  83.       
  84.       (setq en(entmakex (append
  85.         (list '(0 . "LWPOLYLINE")
  86.         '(100 . "AcDbEntity")
  87.         '(100 . "AcDbPolyline")
  88.         (cons 8 xd_la)
  89.         (cons 90 (length lst))
  90.         (cons 70 1)        
  91.         )
  92.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))))
  93.       (if (>= (vla-get-length (vlax-ename->vla-object en)) (* 12 xd_scale))
  94.   (progn
  95.     (setq cmd_old(getvar "cmdecho"))
  96.     (setvar "cmdecho" 0)
  97.       (vl-cmdf "_revcloud" "a" (* xd_cloud xd_scale) "" "s" "c" "o" "" en "N")
  98.     (if cmd_old (setvar "cmdecho" cmd_old))
  99.       )
  100.   (princ "\n矩形太小,无法生成修订云线!"))
  101.       (setq en (entlast))
  102.         (vla-getboundingbox (vlax-ename->vla-object en) 'minpoint 'maxpoint)
  103.   (setq p1 (vlax-safearray->list maxpoint)
  104.         p3 (vlax-safearray->list minpoint))
  105.       (setq mpt(mapcar '(lambda(x y)(/ (+ x y) 2.)) p1 p3))
  106.       
  107.       (entmod (subst(cons 8 xd_la)(assoc 8 (entget en))(entget en)))
  108.       
  109.       (if (and (setq pt1(getpoint mpt "\n指定引线点:"))
  110.          (/= (ISPTINPM pt1 lst) t)
  111.          )
  112.   (progn
  113.       (setq en2(entmakex(list (cons 0 "line")(cons 8 xd_la) (cons 10 mpt)(cons 11 pt1))))      
  114.       (setq in_pt(vlax-safearray->list(vlax-variant-value(vla-IntersectWith
  115.                  (vlax-ename->vla-object en)     
  116.   (vlax-ename->vla-object en2) acExtendNoNe))))
  117. (if in_pt (entmod (subst(cons 10 in_pt)(assoc 10 (entget en2))(entget en2))))
  118.       
  119.    
  120.       (if (setq pt2 (getpoint pt1"\n指定文字方向:"))
  121.   (progn
  122.       (setq ang (angle pt1 (list(car pt2)(cadr pt1))))
  123.       (if en2(entdel en2))
  124.       (setq lst2(list in_pt pt1 (list(car pt2)(cadr pt1))))
  125.       (setq en3(entmakex (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")(cons 8 xd_la)  (cons 90 (length lst2)))
  126.       (mapcar '(lambda (pt)(cons 10 pt)) lst2 ))  ))
  127.       
  128.       (setq entext(entmakex (list '(0 . "TEXT")
  129.          (cons 1 "输入文字")
  130.          (cons 10 (polar pt1 (* pi 0.5) (* 0.625 xd_scale)))
  131.          (cons 7 xd_style)
  132.          (cons 8 xd_la)
  133.          (cons 41 0.7)
  134.          (cons 40 (* xd_txth xd_scale))
  135.           (cons 73 0)
  136.           (cons 72 (cond((> (car pt1) (car pt2))2)(t 0)))            
  137.          (cons 11 (polar pt1 (* pi 0.5) (* 0.625 xd_scale)))
  138.           )))
  139.       (vl-cmdf "_ddedit" entext  "" )
  140.       (setq textlst(textbox (entget entext)))
  141.       (setq ntextlst(2pt4pt (car textlst)(cadr textlst)))
  142.       (setq ds(distance (car ntextlst)(cadr ntextlst)))
  143.       (setq textpt(polar pt1 ang ds))
  144.       (setq lst3(list in_pt pt1 textpt))
  145.       (if en3(entdel en3))
  146.       (entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")(cons 8 xd_la)  (cons 90 (length lst3)))
  147.       (mapcar '(lambda (pt)(cons 10 pt)) lst3 ))
  148.   ))(progn(if en2(entdel en2)) (princ "\n未指定文字方向!"))))(princ "\n未指定引线!"))
  149.       );end_progn
  150.     (princ"\n Nothing!")
  151.     )
  152.   (vla-EndUndoMark      
  153.     (vla-get-ActiveDocument (vlax-get-acad-object))
  154.   )
  155.   (if *error*_Old (setq *error* *error*_Old))
  156.   (gc)
  157.   
  158.   (princ)
  159.   
  160.   )
  161. (defun ISPTINPM (XPT POINTS / x y )
  162. (equal pi(abs(apply '+(mapcar'(lambda (X Y)(rem (- (angle XPT X) (angle XPT Y)) pi))
  163.                                (reverse (cdr (reverse (cons (last POINTS) POINTS))))
  164.                           POINTS
  165.                        )
  166.                )
  167.           )
  168.          1e-6
  169.   ) ;end_equal
  170. )
  171. ;;返回多段线顶点表
  172. (defun vertexs (ename / plist pp n)        
  173.   (setq obj (vlax-ename->vla-object ename))
  174.   (setq plist (vlax-safearray->list
  175.   (vlax-variant-value
  176.     (vla-get-coordinates obj))))
  177.   (setq n 0)
  178.   (repeat (/ (length plist) 2)
  179.     (setq pp (append pp (list (list (nth n plist)(nth (1+ n) plist)))))
  180.     (setq n (+ n 2))
  181.   )
  182.   pp
  183. )
  184. (prompt "\n矩形修定云线带引线文字by edata@2013.12.14! 命令 xd")
  185. (princ)


  186. ;016-插入日期及时间
  187. (defun c:IT ( / da lst)
  188.   (princ "\n 插入日期及时间")  
  189.   (setq da (rtos(getvar "cdate")2 8)
  190.         lst(mapcar '(lambda(x)(substr da (car x) (cadr x))) '((1 4) (5 2) (7 2) (10 2)(12 2)(14 2)(16 2))))
  191.   (COMMAND "STYLE"  "tssd_rein" "Tssdeng.shx,hztxt"
  192.        "250" "0.7" "0" "n" "n" "n")
  193.   (setq pt1 (getpoint "\n\t放置点 : "))
  194.   (vl-cmdf ".text" "j" "mc" pt1 "0"
  195.   (apply 'strcat (mapcar '(lambda(x y)(strcat x y)) lst '("年" "月" "日" "时" "分")))
  196. )
  197.     (princ)
  198. )
要求见下图

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2014-7-1 16:53:54 | 显示全部楼层
感觉必要性不是很大,自己直接画一个云线,直接在旁边写字,再画一根引线不就可以了吗,也不麻烦啊。

要不就要在修改文字时,文字外线框要能自动调大小的,那样还算有点用。不过实现起来应该比较麻烦。
发表于 2014-7-1 21:46:18 | 显示全部楼层

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-25 07:41 , Processed in 0.183190 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表