墙线绘制源码解析（支持UCS，偏心或居中布置，厚度设置，自动填充）

林霄云

墙线绘制源码解析（支持UCS，偏心或居中布置，厚度设置，自动填充）
自最后的源码撰写后，过去已很多时候了。
引线标注点筋与线筋源码解析（支持UCS）
http://bbs.mjtd.com/forum.php?mo ... 872&fromuid=7303580

我身为结构，在代码中得到不仅有乐趣，更见得缜密或灵巧的思维，扎实或稀松的水平。此文虽为建筑结构所用画墙线，却也值得玩味些许。

引子
结构建模，需要结构布置。结构布置一般以建筑图为底图，在其上绘制梁与墙柱。哪里设墙柱，哪里设梁是结构布置问题，也是从绘图软件cad导入结构计算软件如pkpm的前提。故一需要画墙柱，二需要画梁，本人作此代码，以求快速建模。
思路
剪力墙主要是L型，一字型，其次是T型，I型和其他异性。故以L型墙线绘制为例进行解析代码。
1，通过偏移使墙有厚度。故率先获取其基准线的端点点表（基准线可以是中线或者边线）
2，根据参数进行偏移获得墙线，并自动填充
3，动态修改墙厚或者修改偏心

核心代码
取点表，L型 getwallpoint_a

2. (defun getwallpoint_a( / pt1 pt2 pt3 ptlist-w x )
   
3. ;WALLLINE-P方式
   
4. ;Designed by 林霄云 2014年2月25日
   
5. (setvar "OSNAPZ" 1)
   
6. (setq pt1 (getpoint "\nbasepoint:"))
   
7. (princ pt1)
   
8. (setq pt2 (getpoint pt1 "\nnextpoint:"))
   
9. (princ pt2)
   
10. (grdraw pt1 pt2 20 1)
    
11. (setq pt3 (getpoint pt1 "\nnextpoint:"))
    
12. 
    
13. (if pt3
    
14. (progn (princ pt3)(grdraw pt1 pt3 20 1) (setq ptlist-w (mapcar '(lambda(x) (trans x 1 0)) (list pt3 pt1 pt2)))  );progn
    
15. (setq ptlist-w (mapcar '(lambda(x) (trans x 1 0)) (list pt1 pt2)))
    
16. );pt3 修正pt3不存在的时候
    
17. )

(defun getwallpoint_a( / pt1 pt2 pt3 ptlist-w x )<br /> ;WALLLINE-P方式 <br /> ;Designed by 林霄云 2014年2月25日<br /> (setvar "OSNAPZ" 1)<br /> (setq pt1 (getpoint "\nbasepoint:"))<br /> (princ pt1)<br /> (setq pt2 (getpoint pt1 "\nnextpoint:"))<br /> (princ pt2)<br /> (grdraw pt1 pt2 20 1)<br /> (setq pt3 (getpoint pt1 "\nnextpoint:"))<br /> <br /> (if pt3<br /> (progn (princ pt3)(grdraw pt1 pt3 20 1) (setq ptlist-w (mapcar '(lambda(x) (trans x 1 0)) (list pt3 pt1 pt2)))  );progn<br /> (setq ptlist-w (mapcar '(lambda(x) (trans x 1 0)) (list pt1 pt2)))<br /> );pt3 修正pt3不存在的时候<br /> )

生成墙线make_wall

2. (defun make_wall(ptlist-w wid lr-flag / ss en en-a1 en-a2 wid-temp)
   
3. ;约定lr-flag取值为-1，0.5，1
   
4. (setq lr-flag (rem lr-flag 3))
   
5. (setq lr-flag (nth lr-flag '( -1.0 0.5 1.0)))
   
6. (setq wid-temp (* wid lr-flag))
   
7. 
   
8. (setup "col"); 设置图层
   
9. (setq en (make_pline  ptlist-w (getvar "clayer") nil))
   
10. ;生成辅助线
    
11. (setq en-a1 (en_offset_a en wid-temp t))
    
12. (setq en-a2 (en_offset_a en-a1 (* wid (- (sign wid-temp))) nil))
    
13. 
    
14. ;取en-a1 en-a2坐标点，形成新的pline。删除辅助线。
    
15. (setq ptlist-w (append (get_pline_vertex en-a1) (reverse (get_pline_vertex en-a2))))
    
16. (setq en (make_pline ptlist-w (getvar "clayer") t))
    
17. 
    
18. (setq ss (ssadd))
    
19. (setq ss (ssadd en ss))
    
20. 
    
21. (entdel en-a1)
    
22. (entdel en-a2)
    
23. 
    
24. (autohatch_en en)
    
25. (setq ss (ssadd (entlast) ss))
    
26. )

(defun make_wall(ptlist-w wid lr-flag / ss en en-a1 en-a2 wid-temp)<br /> ;约定lr-flag取值为-1，0.5，1<br /> (setq lr-flag (rem lr-flag 3))<br /> (setq lr-flag (nth lr-flag '( -1.0 0.5 1.0)))<br /> (setq wid-temp (* wid lr-flag))<br /> <br /> (setup "col"); 设置图层<br /> (setq en (make_pline  ptlist-w (getvar "clayer") nil))<br /> ;生成辅助线<br /> (setq en-a1 (en_offset_a en wid-temp t))<br /> (setq en-a2 (en_offset_a en-a1 (* wid (- (sign wid-temp))) nil))<br /> <br /> ;取en-a1 en-a2坐标点，形成新的pline。删除辅助线。<br /> (setq ptlist-w (append (get_pline_vertex en-a1) (reverse (get_pline_vertex en-a2))))<br /> (setq en (make_pline ptlist-w (getvar "clayer") t))<br /> <br /> (setq ss (ssadd))<br /> (setq ss (ssadd en ss))<br /> <br /> (entdel en-a1)<br /> (entdel en-a2)<br /> <br /> (autohatch_en en)<br /> (setq ss (ssadd (entlast) ss))<br /> )

调用主函数，实现动态

2. (defun C:wl( /  ptlist-w  ss flag num-pt wid-temp wid-flag)
   
3. ;WALLLINE-P方式
   
4. ;Designed by 林霄云 2014年2月25日
   
5. (setq ss (ssadd))
   
6. (setq flag t)
   
7. (setq num-pt 1)
   
8. (setq wid-flag nil )
   
9. 
   
10. (setq ptlist-w (getwallpoint_a))
    
11. 
    
12. (setq ss  (make_wall ptlist-w hnu:wallwid num-pt) )
    
13. 
    
14.       ;捕捉左键，进行缩放测试
    
15.       (prompt "\n左击循环方式调整墙位置 or U撤销 or 右击确认退出")
    
16.       (while (and (setq ptr (grread t 15 2))
    
17.                 flag
    
18.                  )   
    
19.                  ;(redraw)
    
20.       (cond ((= (car ptr) 3);_Mouse Left button
    
21.          (if ss
    
22.          (progn (ss_delete ss)(setq num-pt (1+ num-pt)) (setq ss (make_wall ptlist-w hnu:wallwid num-pt))) ;切换标志，删除，生成
    
23.          ) ;
    
24.            ))
    
25.        (cond ((= (car ptr) 2);键盘事件
    
26.                   
    
27.          (if (or (= (ascii "U") (cadr ptr)) (= (ascii "u") (cadr ptr))) (if ss (progn (ss_delete ss) (setq flag (not flag)))))
    
28.          (if  (<= (ascii "0")(setq wid-temp (cadr ptr))(ascii "9"))
    
29.           (if wid-flag  
    
30.           (progn (setq wid-flag (+ (* 10 wid-flag )(- wid-temp (ascii "0"))))(princ (itoa (- wid-temp (ascii "0"))))) ;处理其他数字
    
31.           (if ( = (ascii "0") wid-temp ) (setq wid-flag nil)  (progn (setq wid-flag (- wid-temp (ascii "0"))) (princ (strcat "\n临时新墙厚:" (itoa (- wid-temp (ascii "0")))))));处理第一个数字
    
32.           )
    
33.           ; (if wid-flag (princ (itoa wid-flag)));回显
    
34.           );处理输入数字情况
    
35.          (if (or (= 13 (cadr ptr)) (= 32 (cadr ptr)))
    
36.           (if wid-flag
    
37.           (progn (setq hnu:wallwid wid-flag)
    
38.                (princ (strcat "\n当前墙厚为:" (itoa wid-flag)))
    
39.                (if ss  (progn (ss_delete ss) (setq ss nil)))               
    
40.                (setq ss (make_wall ptlist-w wid-flag num-pt))
    
41.                (setq wid-flag nil)
    
42.                )
    
43.                (setq flag (not flag));退出循环
    
44.            )
    
45.            )   
    
46.            ))
    
47.            
    
48.       (cond ((or (= (car ptr) 11) (= (car ptr) 25))
    
49.       (if wid-flag
    
50.           (progn ;(setq hnu:wallwid wid-flag)
    
51.                (princ (strcat "\n当前墙厚为:" (itoa wid-flag)))
    
52.                (if ss  (progn (ss_delete ss) (setq ss nil)))               
    
53.                (setq ss (make_wall ptlist-w wid-flag num-pt))
    
54.                (setq wid-flag nil)
    
55.                )
    
56.                (setq flag (not flag));退出循环
    
57.            )
    
58.            )  ;_Mouse Right button
    
59.            );cond 右击事件      
    
60.            );while
    
61.       ;捕捉左键，进行缩放测试
    
62. (princ)
    
63. )

(defun C:wl( /  ptlist-w  ss flag num-pt wid-temp wid-flag)<br /> ;WALLLINE-P方式 <br /> ;Designed by 林霄云 2014年2月25日<br /> (setq ss (ssadd))<br /> (setq flag t)<br /> (setq num-pt 1)<br /> (setq wid-flag nil )<br /> <br /> (setq ptlist-w (getwallpoint_a))<br /> <br /> (setq ss  (make_wall ptlist-w hnu:wallwid num-pt) ) <br /> <br />       ;捕捉左键，进行缩放测试<br />       (prompt "\n左击循环方式调整墙位置 or U撤销 or 右击确认退出")<br />       (while (and (setq ptr (grread t 15 2))<br />                 flag<br />                  )   <br />                  ;(redraw)<br />       (cond ((= (car ptr) 3);_Mouse Left button <br />          (if ss <br />          (progn (ss_delete ss)(setq num-pt (1+ num-pt)) (setq ss (make_wall ptlist-w hnu:wallwid num-pt))) ;切换标志，删除，生成<br />          ) ;<br />            ))<br />        (cond ((= (car ptr) 2);键盘事件 <br />                   <br />          (if (or (= (ascii "U") (cadr ptr)) (= (ascii "u") (cadr ptr))) (if ss (progn (ss_delete ss) (setq flag (not flag)))))<br />          (if  (<= (ascii "0")(setq wid-temp (cadr ptr))(ascii "9")) <br />           (if wid-flag  <br />           (progn (setq wid-flag (+ (* 10 wid-flag )(- wid-temp (ascii "0"))))(princ (itoa (- wid-temp (ascii "0"))))) ;处理其他数字<br />           (if ( = (ascii "0") wid-temp ) (setq wid-flag nil)  (progn (setq wid-flag (- wid-temp (ascii "0"))) (princ (strcat "\n临时新墙厚:" (itoa (- wid-temp (ascii "0")))))));处理第一个数字<br />           )<br />           ; (if wid-flag (princ (itoa wid-flag)));回显<br />           );处理输入数字情况<br />          (if (or (= 13 (cadr ptr)) (= 32 (cadr ptr))) <br />           (if wid-flag <br />           (progn (setq hnu:wallwid wid-flag) <br />                (princ (strcat "\n当前墙厚为:" (itoa wid-flag)))<br />                (if ss  (progn (ss_delete ss) (setq ss nil)))               <br />                (setq ss (make_wall ptlist-w wid-flag num-pt))<br />                (setq wid-flag nil)<br />                ) <br />                (setq flag (not flag));退出循环<br />            )<br />            )    <br />            ))<br />            <br />       (cond ((or (= (car ptr) 11) (= (car ptr) 25)) <br />       (if wid-flag <br />           (progn ;(setq hnu:wallwid wid-flag) <br />                (princ (strcat "\n当前墙厚为:" (itoa wid-flag)))<br />                (if ss  (progn (ss_delete ss) (setq ss nil)))               <br />                (setq ss (make_wall ptlist-w wid-flag num-pt))<br />                (setq wid-flag nil)<br />                ) <br />                (setq flag (not flag));退出循环<br />            )<br />            )  ;_Mouse Right button <br />            );cond 右击事件       <br />            );while<br />       ;捕捉左键，进行缩放测试<br /> (princ)<br /> )

由于核心是放代码。故弱化解析。有兴趣的，可以留言沟通。代码详见附件。
测试效果也没时间做精细了。希望热心人做出gif回复上。

xyp1964

揭秘 setup函数

2. (defun setup (la)
   
3.   (if (= (tblsearch "layer" la) nil)
   
4.     (Command "-layer" "m" la "")
   
5.     (Command "-layer" "t" la "")
   
6.   )
   
7.   (setvar "clayer" la)
   
8. )

(defun setup (la)<br />   (if (= (tblsearch "layer" la) nil)<br />     (Command "-layer" "m" la "")<br />     (Command "-layer" "t" la "")<br />   )<br />   (setvar "clayer" la)<br /> )

love_cq

寻找了很久了，多谢大神分享，大赞。

ajunseo

看上去很智能的插件。赞一个

lyqiezi

先下好，慢慢学习，转PKPM模型是直接用PKPM的程序吗？

tanle2020

下载了所有附件还是缺少函数，no function definition: SETUP

林霄云

tanle2020 发表于 2014-5-6 09:00
下载了所有附件还是缺少函数，no function definition: SETUP

对于setup函数出现的错误，可以注释之，或用（setvar "clayer" 图层名）替换之，前提是该图层存在。
同时，也敬请期待下篇文章对setup函数的解析。

429014673

楼主牛得很厉害，赞。
院长不用多长时间就会过来踢馆了。

adc

赞~~~~~~~~~~~

phoevana

支持，虽然不是结构专业

freehand8008

G都给3分肯定差不了！

enn09

用（setvar "clayer""墙"）替换了图层名，仍画不出

石井鱼

要是有个完整的傻瓜型的直接能用就好了