求修改个程序-批量标注坐标！！

spp_wall

      现在的问题是  这个批量标注  出的图不够美观  希望高手修改下

    1：在直线段还是没有问题的  就是有角度的情况下就不美观了   是否能做到 每个坐标都垂直于多段线

如下图中   蓝色的就是程序出来的效果    白色的就是最终要达到的效果

vectra

1. (defun c:smer
   
2.        (/ ang ang2 i long ps_cmdecho ps_luprec ps_osmode pt pt1 pts radius somode sunmer words)
   
3.   (setq        ps_cmdecho (getvar "cmdecho")
   
4.         ps_osmode  (getvar "osmode")
   
5.         ps_luprec  (getvar "luprec")
   
6.   )
   
7.   (setvar "cmdecho" 0)
   
8.   (setvar "osmode" 0)
   
9.   (setvar "luprec" 0)
   
10.   (command "-layer" "n" "桩号标注" "c" "4" "桩号标注" "")
    
11. 
    
12.   (initvar 'words "输入文字大小(2~6)" 2.0)
    
13.   (initvar 'radius "输入引线起点圆的半径(建议1mm)" 1.0)
    
14.   (initvar 'long "输入引线长度" (* words 14))
    
15. 
    
16.   (setq        sunmer (ssget '((0 . "*POLYLINE")))
    
17.         i      0
    
18.   )
    
19.   (while (< i (sslength sunmer))
    
20.     (setq pts (massoc (entget (ssname sunmer i)) 10))
    
21.     (repeat (length pts)
    
22.       (command "layer" "s" "桩号标注" "")
    
23.       (setq pt (cdar pts))
    
24.       (if (not (null (cdr pts)))
    
25.         (setq ang (angle pt (cdadr pts)))
    
26.       )
    
27.       (setq
    
28.         ang2 (- ang (* 0.5 pi))
    
29.         pt1  (polar pt ang2 long)
    
30.       )
    
31.       (command "circle" pt radius)
    
32.       (command "line" pt pt1 "")
    
33. 
    
34.       (command "text"
    
35.                (polar (polar pt ang2 2) (+ ang2 (* pi 0.5)) (* 0.5 words))
    
36.                words
    
37.                (radtodeg ang2)
    
38.                (strcat "X=" (rtos (car pt) 2 4))
    
39.       )
    
40.       (command "text"
    
41.                (polar (polar pt ang2 2) (- ang2 (* pi 0.5)) (* 1.5 words))
    
42.                words
    
43.                (radtodeg ang2)
    
44.                (strcat "Y=" (rtos (cadr pt) 2 4))
    
45.       )
    
46. 
    
47.       (setq pts (cdr pts))
    
48.     )
    
49.     (setq i (1+ i))
    
50.   )
    
51.   (setvar "cmdecho" ps_cmdecho)
    
52.   (setvar "osmode" ps_osmode)
    
53.   (setvar "luprec" ps_luprec)
    
54. )
    
55. 
    
56. (defun initvar (symbol msg default / r)
    
57.   (if (null (vl-symbol-value symbol))
    
58.     (set symbol default)
    
59.   )
    
60.   (setq r (getdist (strcat msg "<" (rtos (vl-symbol-value symbol) 2) ">:")))
    
61.   (if (not (null r))
    
62.     (set symbol r)
    
63.   )
    
64. )
    
65. (defun radtodeg        (rad)
    
66.   (* 180.0 (/ rad pi))
    
67. )
    
68. (defun massoc (lst key)
    
69.   (vl-remove-if '(lambda (x) (/= key (car x))) lst)
    
70. )
    
71. 
    

(defun c:smer<br />        (/ ang ang2 i long ps_cmdecho ps_luprec ps_osmode pt pt1 pts radius somode sunmer words)<br />   (setq        ps_cmdecho (getvar "cmdecho")<br />         ps_osmode  (getvar "osmode")<br />         ps_luprec  (getvar "luprec")<br />   )<br />   (setvar "cmdecho" 0)<br />   (setvar "osmode" 0)<br />   (setvar "luprec" 0)<br />   (command "-layer" "n" "桩号标注" "c" "4" "桩号标注" "")<br /> <br />   (initvar 'words "输入文字大小(2~6)" 2.0)<br />   (initvar 'radius "输入引线起点圆的半径(建议1mm)" 1.0)<br />   (initvar 'long "输入引线长度" (* words 14))<br /> <br />   (setq        sunmer (ssget '((0 . "*POLYLINE")))<br />         i      0<br />   )<br />   (while (< i (sslength sunmer))<br />     (setq pts (massoc (entget (ssname sunmer i)) 10))<br />     (repeat (length pts)<br />       (command "layer" "s" "桩号标注" "")<br />       (setq pt (cdar pts))<br />       (if (not (null (cdr pts)))<br />         (setq ang (angle pt (cdadr pts)))<br />       )<br />       (setq<br />         ang2 (- ang (* 0.5 pi))<br />         pt1  (polar pt ang2 long)<br />       )<br />       (command "circle" pt radius)<br />       (command "line" pt pt1 "")<br /> <br />       (command "text"<br />                (polar (polar pt ang2 2) (+ ang2 (* pi 0.5)) (* 0.5 words))<br />                words<br />                (radtodeg ang2)<br />                (strcat "X=" (rtos (car pt) 2 4))<br />       )<br />       (command "text"<br />                (polar (polar pt ang2 2) (- ang2 (* pi 0.5)) (* 1.5 words))<br />                words<br />                (radtodeg ang2)<br />                (strcat "Y=" (rtos (cadr pt) 2 4))<br />       )<br /> <br />       (setq pts (cdr pts))<br />     )<br />     (setq i (1+ i))<br />   )<br />   (setvar "cmdecho" ps_cmdecho)<br />   (setvar "osmode" ps_osmode)<br />   (setvar "luprec" ps_luprec)<br /> )<br /> <br /> (defun initvar (symbol msg default / r)<br />   (if (null (vl-symbol-value symbol))<br />     (set symbol default)<br />   )<br />   (setq r (getdist (strcat msg "<" (rtos (vl-symbol-value symbol) 2) ">:")))<br />   (if (not (null r))<br />     (set symbol r)<br />   )<br /> )<br /> (defun radtodeg        (rad)<br />   (* 180.0 (/ rad pi))<br /> )<br /> (defun massoc (lst key)<br />   (vl-remove-if '(lambda (x) (/= key (car x))) lst)<br /> )<br /> <br />

spp_wall

vectra 发表于 2013-10-7 12:50

谢谢  还能再完善么  
1：XY坐标的文字离多段线的距离是否能调整   那个代码是？
2：是否能选择坐标的位置  比如多段线的左侧或者右侧

xyp1964

spp_wall

xyp1964 发表于 2013-10-9 13:11

这个是逐点标注吧！

还有 不知道 我怎么无法使用 院长你的工具箱  都是按你要求的安装办法  但是输入XCAD没反应

luojie110

先下载学习一下

f4800

vectra 发表于 2013-10-7 12:50

大师
这段源码标注的文字是水平的  
怎么修改为增加可选项 ，

有水平或垂直标注的选择？
多谢了



源码如下：
多谢

• (defun c:zbbz (/ LC:TEXTLENGTH TEXTSTYLE-BAK TEXTSIZE-BAK TEXTHIGH XSWS PT1 PT2 STRLST TEXTLENGTH PT3 LST)
•   (defun LC:TextLength (String / Tbox)
•     (setq Tbox (textbox (list (cons 1 String))))
•     (distance (car Tbox) (cadr Tbox))
•   )
•   (setq TEXTSTYLE-bak(getvar "TEXTSTYLE"))
•   (setvar "TEXTSTYLE" "Standard")
•   (setq textsize-bak (Getvar "textsize")) ;字高系统变量
•   (setq texthigh (getreal "\n  请输入文字高度<1.5>: "))
•   (if (null texthigh) (setq texthigh 1.5))
•   (Setvar "textsize" texthigh)
•   (setq xsws (getint "\n 请输入小数位数<3>: "))
•   (if (null xsws) (setq xsws 3))
•   (while (setq pt1 (getpoint "\n 指定注记点: "))
•     (setq pt2 (getpoint "注记位置: "))  
•     (setq strlst (mapcar'strcat'("Y= " "X= " "H= ")(mapcar '(lambda (x) (rtos x 2 xsws)) pt1)))
•     (setq textlength (apply 'MAX (mapcar '(lambda (x) (LC:TextLength x)) strlst)));文字最大长度
•     (setq pt3 (if (> (car pt2) (car pt1))
•                   (polar pt2 0 (+ textlength 1))
•                   (polar pt2 pi (+ textlength 1))
•               )
•     )
•     (setq lst (list pt1 pt2 pt3))
•     (entmake (list '(0 . "TEXT")'(41 . 1.0)(cons 1 (cadr strlst)) (cons 10 (polar (polar (IF (>= (car pt2) (car pt1)) pt2 pt3) 0 0.5) (* 0.5 pi) (* texthigh 0.2))) (cons 40 texthigh)))
•     (entmake (list '(0 . "TEXT")'(41 . 1.0) (cons 1 (car strlst)) (cons 10 (polar (polar (IF (>= (car pt2) (car pt1)) pt2 pt3) 0 0.5) (* 1.5 pi) (+ (* texthigh 0.2) texthigh))) (cons 40 texthigh)))
•     (entmake (list '(0 . "TEXT") '(41 . 1.0)(cons 1 (last strlst)) (cons 10 (polar (polar (IF (>= (car pt2) (car pt1)) pt2 pt3) 0 0.5) (* 1.5 pi) (+ (* texthigh 0.4) (* texthigh 2.0)))) (cons 40 texthigh)))
•     (entmake (append (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")(cons 90 (length lst)))(mapcar '(lambda (pt) (cons 10 pt)) lst)))
•   )
•   (Setvar "textsize" textsize-bak) ;还原字高系统变量
•   (setvar "TEXTSTYLE" TEXTSTYLE-bak) ;还原字体系统变量
• )