请大神给合并2个源码

wjnnan

一直想弄个自己的简单的审图批注，在论坛里搜罗的两个lisp，无奈自己能力还不够，自己合并不了，请哪位大神给合并一下

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

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

要求见下图

etoxp

感觉必要性不是很大，自己直接画一个云线，直接在旁边写字，再画一根引线不就可以了吗，也不麻烦啊。

要不就要在修改文字时，文字外线框要能自动调大小的，那样还算有点用。不过实现起来应该比较麻烦。

xyp1964