随意角度自动比例修订云线

baogeu88

修订云线是大家比较常见的一个功能，有时候根据不同专业的作图需要，修订云线往往需要需要根据图纸不停地变化角度，而且云线比例也需要根据我们的选择范围进行调整。为了方便工作，最好能把这几个功能集成起来，也能方便大家的绘图。

感谢14#楼的建议！增加默认水平方向和修复会影响到矩形的角度的bug。详见v1.1版本。

lml2023

修改了一下
(1)加了图层
（2）把其他改为  q

2. ;;任意云线TY
   
3. (defun c:TY(/ x0 y0 x1 y1)
   
4.         (setvar "cmdecho" 0 )
   
5. (setq oldlayer (getvar "clayer"));;加层
   
6. (command-S "_layer" "n" "0-100-修改云线" "c" "6" "0-100-修改云线"  "N" "0-100-修改云线" "") ;;加层,如果"N"后加“P”则为不打印图层
   
7. (setvar "clayer" "0-100-修改云线");;加层
   
8.   (vl-load-com)
   
9.        
   
10.         ------------------------
    
11.         ;设置水平方向默认值
    
12.        
    
13.         (setq fx (getstring "\n输入修订云线偏转方向（默认水平-y;其他旋转角度-q）<空格-y>:"))
    
14.        
    
15.         (if (= fx "")
    
16.                 (setq fx "y")                       
    
17.         )
    
18.         (princ fx)
    
19.         ----------------------
    
20.        
    
21.         (SetQ      
    
22.                 p0 (GetPoint "\n 指定第一个修订角点：")                        
    
23.         )
    
24.        
    
25.         ;显示方向，方便查看
    
26.         (if (= fx "y")
    
27.                 (Command "rectang" p0 "r"  0  pause )
    
28.                 (progn
    
29.                         (princ "\n指定角度方向")
    
30.                         (command "line" p0 pause "")
    
31.                         (setq xl (entlast))
    
32.                         (setq xdata (entget xl))
    
33.                         (setq pend (cdr (assoc 11 xdata)))
    
34.                         (grdraw p0 pend 2)       
    
35.                         (setq angl (bao-rtd (angle p0 pend)))
    
36.                         (entdel xl);显示完成，删除
    
37.                         (princ "\n点选云线框角点")
    
38.                         (Command "rectang" p0 "r"  angl  pause )
    
39.                 )
    
40.         )
    
41.         -------------------------------------------------       
    
42.         ;设定比例弧长
    
43.         (setq xx (entlast))
    
44.         (setq edata (entget xx))
    
45.        
    
46.   (setq plst (bao_get_vertexs  xx)) ;获取矩形四个顶点坐标
    
47.         (setq pp1 (car plst)
    
48.                 pp2 (cadr plst)
    
49.                 pp3 (caddr plst)
    
50.                 pp4 (cadddr plst)               
    
51.         )
    
52.         (setq dis1 (distance pp1 pp2)
    
53.                 dis2 (distance pp2 pp3)
    
54.         )
    
55.        
    
56.         (if(<= dis1 dis2)
    
57.                 (SetQ alenth (/ dis1 8))
    
58.                 (SetQ alenth (/ dis2 8))               
    
59.         )
    
60.        
    
61.         (Command "revcloud" "a" alenth alenth "s" "c" "o" "l" "")
    
62.        
    
63.         -------------------------
    
64.         ;返回矩形默认水平作图方向
    
65.         (Command "rectang" p0 "r"  0  pp3 )
    
66.         (setq xx (entlast))
    
67.         (entdel xx)
    
68.         ------------------------------
    
69.         (setvar "cmdecho" 1)
    
70.         (princ)
    
71. )
    
72. ;;弧度转换为度
    
73. (defun bao-rtd (ang) (/ (* ang 180.0) pi))
    
74. ;;度转换为弧度
    
75. (defun bao-dtr (ang) (* (/ ang 180.0) pi))
    
76. 
    
77. ;;获取矩形顶点
    
78. (defun bao_get_vertexs (en)
    
79.         (mapcar 'cdr (vl-remove-if-not
    
80.                                                                  '(lambda (x) (= (car x) 10))
    
81.                                                                  (entget en)
    
82.                                                          )       
    
83.         )
    
84. )
    

;;任意云线TY<br /> (defun c:TY(/ x0 y0 x1 y1)<br />         (setvar "cmdecho" 0 )<br /> (setq oldlayer (getvar "clayer"));;加层<br /> (command-S "_layer" "n" "0-100-修改云线" "c" "6" "0-100-修改云线"  "N" "0-100-修改云线" "") ;;加层,如果"N"后加“P”则为不打印图层<br /> (setvar "clayer" "0-100-修改云线");;加层<br />   (vl-load-com)<br />         <br />         ------------------------<br />         ;设置水平方向默认值<br />         <br />         (setq fx (getstring "\n输入修订云线偏转方向（默认水平-y;其他旋转角度-q）<空格-y>:"))<br />         <br />         (if (= fx "")<br />                 (setq fx "y")                        <br />         )<br />         (princ fx)<br />         ----------------------<br />         <br />         (SetQ      <br />                 p0 (GetPoint "\n 指定第一个修订角点：")                         <br />         )<br />         <br />         ;显示方向，方便查看<br />         (if (= fx "y")<br />                 (Command "rectang" p0 "r"  0  pause )<br />                 (progn<br />                         (princ "\n指定角度方向")<br />                         (command "line" p0 pause "")<br />                         (setq xl (entlast))<br />                         (setq xdata (entget xl))<br />                         (setq pend (cdr (assoc 11 xdata)))<br />                         (grdraw p0 pend 2)        <br />                         (setq angl (bao-rtd (angle p0 pend)))<br />                         (entdel xl);显示完成，删除<br />                         (princ "\n点选云线框角点")<br />                         (Command "rectang" p0 "r"  angl  pause )<br />                 )<br />         )<br />         -------------------------------------------------        <br />         ;设定比例弧长<br />         (setq xx (entlast))<br />         (setq edata (entget xx))<br />         <br />   (setq plst (bao_get_vertexs  xx)) ;获取矩形四个顶点坐标<br />         (setq pp1 (car plst)<br />                 pp2 (cadr plst)<br />                 pp3 (caddr plst)<br />                 pp4 (cadddr plst)                <br />         )<br />         (setq dis1 (distance pp1 pp2)<br />                 dis2 (distance pp2 pp3)<br />         )<br />         <br />         (if(<= dis1 dis2)<br />                 (SetQ alenth (/ dis1 8))<br />                 (SetQ alenth (/ dis2 8))                <br />         )<br />         <br />         (Command "revcloud" "a" alenth alenth "s" "c" "o" "l" "")<br />         <br />         -------------------------<br />         ;返回矩形默认水平作图方向<br />         (Command "rectang" p0 "r"  0  pp3 )<br />         (setq xx (entlast))<br />         (entdel xx)<br />         ------------------------------<br />         (setvar "cmdecho" 1)<br />         (princ)<br /> )<br /> ;;弧度转换为度<br /> (defun bao-rtd (ang) (/ (* ang 180.0) pi))<br /> ;;度转换为弧度<br /> (defun bao-dtr (ang) (* (/ ang 180.0) pi))<br /> <br /> ;;获取矩形顶点<br /> (defun bao_get_vertexs (en)<br />         (mapcar 'cdr (vl-remove-if-not <br />                                                                  '(lambda (x) (= (car x) 10)) <br />                                                                  (entget en)<br />                                                          )        <br />         )<br /> )<br />

nyistjz

发现有个BUG，以任意角度画云线后，会影响到矩形命令的操作，导致绘制角度出错。
另外，常规情况下，大家用水平向布置的情况较多，是否可以默认为水平向，有选择后，才进行任意角度的绘制？

baogeu88

nyistjz 发表于 2020-6-11 15:25
发现有个BUG，以任意角度画云线后，会影响到矩形命令的操作，导致绘制角度出错。
另外，常规情况下，大家 ...

非常感谢提出宝贵的意见

czb203

非常不错，支持楼主再接再厉~~~

fxlt619

能加上引线+文字说明就好了

快乐贝贝

能否加一个备注引线呢？
这个备注可以进行设置的
这样就好了

yoyoho

谢谢 !  baogeu88 分享程序!!!!

1028695446

我也来发一个哦，不过是动态的，把2个程序组合下就是了

669423907

谢谢楼主分享好程序

石井鱼

不错的程序，想法很好

932276639

不错的程序，想法很好

zgssd

只是原捕捉设置都没有了