[转帖]完善实时显示钢筋面积源码
在网上看到这段源码，我觉得对在设计院工作做结构的还是蛮有用处的，但是源码里面有不少错误，自己试着更了一下，还剩几个警告和错误没有处理掉，求高手帮忙看一下。源码如下：
(DEFUN C:mmkl ()
(SETQ SS (SSGET "X" '((0 . "TEXT")))
I 0)
(REPEAT (SSLENGTH SS)
(SETQ ENT (ENTGET (SSNAME SS I))
STR (CDR (ASSOC 1 ENT))
SL (STRLEN STR)
J 1 I (I1))
(IF (AND (NOT (WCMATCH STR "*/*")) (WCMATCH STR "*!*")) (PROGN
(WHILE (AND (= (SETQ ST (SUBSTR STR J 1)) "0") (= (SETQ ST (SUBSTR STR J 1)) "0") (= (/ pi 2) ang 0) (list pi (pi (/ pi 2)) 1))
((>= pi ang (/ pi 2)) (list 0 (pi (/ pi 2)) 1))
((>= (pi (/ pi 2)) ang pi) (list 0 (/ pi 2) 0))
((>= (* 2 pi) ang (pi (/ pi 2))) (list pi (/ pi 2) 0))
)
)
)
)
)
(defun add_solid(p1 p2 p3 p4)
(entmakex (list (cons 0 "SOLID") (cons 100 "AcDbEntity") (cons 62 250) (cons 100 "AcDbTrace")
(cons 10 p1) (cons 11 p2) (cons 12 p3) (cons 13 p4)
)
)
)
(defun add_text(pt h ang txt style jus)
(entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 62 2) (cons 100 "AcDbText") (if (= jus 0) (cons 10 pt) (list 10 0.0 0.0 0.0)) (cons 40 h)
(cons 1 txt) (cons 50 ang) (cons 7 style) (cons 72 (cond ((= jus 0) 0) ((= jus 1) 1) ((= jus 2) 1) ((= jus 3) 2))) (if (= jus 0)
(list 11 0.0 0.0 0.0) (cons 11 pt)) (cons 100 "AcDbText") (cons 73 (cond ((= jus 0) 0) ((= jus 1) 2) ((= jus 2) 3) ((= jus 3) 2)))
)
)
)
(defun dis (ent / obj laynm name st1 st2 st3 lst h ang n)
(setq obj (vlax-ename->vla-object ent))
(setq laynm (strcat "图层:" (dxf ent 8)) name (dxf ent 1))
;;;;;;首先取得文字容
;(setq tc_txt (vla-get-textstring obj))
(cond
((wcmatch (STRCASE (dxf ent 1)) "#`%`##,##`%`##,##`%`##")
(progn
;(setq tc_mj (tc_tctc1 name))
(setq lst (list "====纵筋面积====" laynm
;(strcat "钢筋标注:" (vla-get-textstring obj))
(strcat "钢筋面积:" (rtos (/ (tc_tctc1 (vla-get-textstring obj)) 100) 2 3)) "cm^2"
;(strcat "钢筋面积:" (rtos (vla-get-ScaleFactor obj) 2 1))
))
)
)
((wcmatch (STRCASE (dxf ent 1)) "#`%`##/#`%`##,#`%`##/##`%`##,##`%`##/#`%`##;##`%`##/##`%`##")
(progn
(setq lst (list "====纵筋面积====" laynm
;(strcat "钢筋标注:" (vla-get-textstring obj))
(strcat "钢筋面积:" (rtos (/ (tc_tctc2 (vla-get-textstring obj)) 100) 2 3)) "cm^2"
))
)
)
((wcmatch (STRCASE (dxf ent 1)) "`%`*")
(progn
(setq lst (list "====板筋面积====" laynm
;(strcat "钢筋标注:" (vla-get-textstring obj))
(strcat "钢筋面积:" (rtos (tc_tctc3 (vla-get-textstring obj))2 3)) "mm^2"
))
)
)
;;;;调试部分
((wcmatch (STRCASE (dxf ent 1)) "`%`*`(*`)")
(progn
(setq lst (list "====箍筋面积====" laynm
;(strcat "钢筋标注:" (vla-get-textstring obj))
(strcat "钢筋面积:" (rtos(/ (tc_tctc5 (vla-get-textstring obj)) 100) 2 3) "/"
(rtos (/ (/ (* (tc_tctc5 (vla-get-textstring obj)) tc_t8)tc_t9a) 100) 2 3)) "cm^2"
))
)
)
;;;;调试部分
((wcmatch (STRCASE (dxf ent 1)) "#`%`## #`%`##,#`%`## ##`%`##,##`%`## #`%`##;##`%`## ##`%`##")
(progn
(setq lst (list "====纵筋面积====" laynm
;(strcat "钢筋标注:" (vla-get-textstring obj))
(strcat "钢筋面积:" (rtos (/ (tc_tctc4 (vla-get-textstring obj)) 100) 2 3)) "cm^2"
))
)
)
);end cond
(setq ss (ssadd) h (/ (getvar "viewsize") 35))
(setq ang (fx (angle (getvar "viewctr") pt)))
(setq n (* 1.4 (1+ (/ (apply 'max (mapcar 'strlen lst)) 2.0))))
(ssadd (add_solid pt (polar pt (car ang) (* n h)) (setq pt (polar pt (cadr ang) (h (* 1.8 h (length lst))))) (polar pt (car ang) (* n h))) ss)
(setq pt (polar pt (car ang) (/ (* n h) 2)))
(if (= (caddr ang) 0)
(setq pt (polar pt (/ pi 2) (* 0.4 h)))
(setq pt (polar pt (/ pi 2) ((* 1.4 h) (* 1.8 h (length lst)))))
)
(setq n -1)
(repeat (length lst)
(ssadd (add_text (setq pt (polar pt (pi (/ pi 2)) (* 1.8 h))) h 0 (nth (setq n (n1)) lst) "钢筋显示" 1) ss)
)
(vl-load-com)
(command "_.undo" "_m")
(prompt "\n***移动鼠标掠过对象查看信息！***")
(setq olderr *error* *error* myerr)
(setq oldos (getvar "osmode"))
(setq oldfill (getvar "fillmode"))
(setvar "osmode" 0)
(setvar "fillmode" 1)
(setvar "cmdecho" 0)
(tc_jzhz)
(setq ss (ssadd))
(while (not pd)
(while (not (progn
(setq gr (grread T 1))
(if (= (car gr) 5)
(setq pt (cadr gr)
ent (nentselp pt)
ent (if (and ent (= (type (last (last ent))) 'ename))
(last (last ent))
(car ent)
)
)
(setq pd T)
)
))
)
(if (and (not pd) (not (equal ent entold)) (not (ssmemb ent ss)))
(progn
(if entold (redraw entold 4))
(if ss (command "_.erase" ss ""))
(redraw ent 3)
(dis ent)
(setq entold ent)
)
)
)
(if entold (redraw entold 4))
(if ss (command "_.erase" ss ""))
(setvar "osmode" oldos)
(setvar "fillmode" oldfill)
(setq *error* olderr)
(princ)
)
(princ)
;;下列程序与这程序类似!
;;转贴自从XDCAD,作者忘了!是你嗎?
;;当鼠标移动到满足过滤条件的像素上时，像素会闪动
;;USAGECS_EntSel "\n请选Polyline物件: " '((0 . "*Polyline")))
(defun CS_ENTSEL (STR FILTER / PT SS_NAME SS)
(if (/= (type STR) 'STR)
(progn
(princ "\n变量类型不对，STR应为字符串。\n")
(eval NIL)
)
(progn
(if (/= (type FILTER) 'list)
(progn
(princ "\n变量类型不对，FILTER应为表。\n")
(eval NIL)
)
(progn
(princ STR)
(setq PT (grread t 4 2))
(while (/= 3 (car PT))
(if (= 5 (car PT))
(progn
(setq PT (cadr PT))
(setq SS (ssget PT FILTER))
(if SS_NAME
(redraw SS_NAME 4)
)
(setq SS_NAME NIL)
(if SS
(progn
(setq SS_NAME (ssname SS 0))
(redraw SS_NAME 3)
)
)
)
(setq PT (grread t 4 2))
)
)
(setq PT (cadr PT))
(setq SS (ssget PT FILTER))
(if SS_NAME
(redraw SS_NAME 4)
)
(setq SS_NAME NIL)
(if SS
(progn
(setq SS_NAME (ssname SS 0))
(list SS_NAME PT)
)
(eval CS_NAME)
)
)
)
)
)
)
(defun set-description (a d /b e)
(if (car (atoms-family 1 '("vl-load-com"))) (vl-load-com))
(setq a (vlax-ename->vla-object a))
(setq b (vla-get-Hyperlinks a))
(vlax-for item b
(vla-delete item)
)
(setq b (vla-get-Hyperlinks a))
(setq e (vla-add b "DescriptionOnly"))
(vla-put-URLDescription e d)
(command "redraw")
)
;;;;;;=========================================
;;;;;;tc_makestyle 加载字体并作当前字体样式====
;;;;;;=========================================
(defun tc_jzhz ()
(if (not (tblobjname "style" "钢筋显示"))
(entmake
'((0 . "STYLE")
(100 . "AcDbSymbolTableRecord")
(100 . "AcDbTextStyleTableRecord")
(2 . "钢筋显示")
(70 . 0)
(40 . 0)
(41 . 0.6)
(50 . 0)
(71 . 0)
(42 . 0.2)
(41 . 1)
(3 . "黑体")
;(4 . "常规")
)
)
)
(setvar "textstyle" "钢筋显示")
)
;;;;;;;;第一种钢筋面积显示已完成
(defun tc_tctc1 (txt3 / N1 t1 t2 TC_GJMJ1)
(setq n1 (vl-string-search "%"txt3)) ;在字符串中搜索指定子串的位置编号
(setq t1 (atoi (substr txt3 1 n1))
t2 (atoi (substr txt3 6 n1)))
(setq tc_gjmj1 (* t1 (/ (* t2 t2 3.1415926) 4)))
)
;;;;;;;
(defun tc_tctc2 (txt3 / N2 t3 t4 TC_GJMJ2)
(setq n2 (vl-string-search "/"txt3)) ;在字符串中搜索指定子串的位置编号
(setq t3 (substr txt3 1 n2)
t4 (substr txt3 2 n2))
(setq tc_gjmj2 ((tc_tctc1 t3) (tc_tctc1 t4)))
)
;;;;;;
(defun tc_tctc3 (txt3 / N3 N4 T5 T6 TC_GJMJ3 )
(setq n3 (vl-string-search "%"txt3)) ;在字符串中搜索指定子串的位置号
(setq n4 (vl-string-search "@"txt3))
(setq t5 (atof (substr txt3 (1 n3) (1- n3)))
t6 (atof (substr txt3(2 n4) (1- n4)))
)
(setq tc_gjmj3 (* (/ 1000 t6) (/ (* t5 t5 3.1415926) 4)))
)
;;;;;;
(defun tc_tctc4 (txt3 / N2 t3 t4 TC_GJMJ4)
(setq n2 (vl-string-search " "txt3)) ;在字符串中搜索指定子串的位置编号
(setq t3 (substr txt3 1 n2)
t4 (substr txt3 2 n2))
(setq tc_gjmj4 ((tc_tctc1 t3) (tc_tctc1 t4)))
)
;;;;;;
(defun tc_tctc5 (txt3 / N5 N5A N6 N6A N7 N7A N8 N8A N9A TC_AREA1 TC_AREA2 TC_GJMJ5 TC_NUM1 TC_T10A TC_T7 TC_T7A TC_T9)
(setq tc_num1 (vl-string-search "/"txt3))
(if (= tc_num1 nil)
(progn
(setq n5 (vl-string-search "%"txt3)) ;在字符串中搜索指定子串的位置号
(setq n6 (vl-string-search "@"txt3))
(setq n7 (vl-string-search "("txt3))
(setq n8 (vl-string-search ")"txt3))
(setq tc_t7 (atoi (substr txt3(5 n5) (- n6 (5 n5)))))
(setq tc_t8 (atoi (substr txt3(2 n6) (- n7 (1 n6))))
tc_t9 (atoi (substr txt3(2 n7) (- n8 (1 n7))))
)
(setq tc_t9a tc_t8)
(setq tc_area1 (/ (* tc_t7 tc_t7 3.1415926) 4))
(setq tc_gjmj5 (/ (* tc_area1 200 tc_t9) tc_t8))
(if (>= tc_t7 10)
(setq tc_gjmj5 (/ (* tc_gjmj5 300) 210))
(setq tc_gjmj5 tc_gjmj5)
) ;_ 结束if
(progn
(setq n5a (vl-string-search "%"txt3)) ;在字符串中搜索指定子串的位置号
(setq n6a (vl-string-search "@"txt3))
(setq n7a (vl-string-search "/"txt3))
(setq n8a (vl-string-search "("txt3))
(setq n9a (vl-string-search ")"txt3))
(setq tc_t7a (atoi (substr txt3 (6n5a) (- n6a (5n5a)))))
(setq tc_t8 (atoi (substr txt3(2n6a) (- n7a (1n6a))))
tc_t9a (atoi (substr txt3(2n7a) (- n8a (1n7a))))
tc_t10a (atoi (substr txt3(2n8a) (- n9a (1n8a))))
)
(setq tc_area2 (/ (* tc_t7a tc_t7a 3.1415926) 4))
(setq tc_gjmj5 (/ (* tc_area2 200 tc_t10a) tc_t8))
(if (>= tc_t7a 10) (setq tc_gjmj5 (/ (* tc_gjmj5 300) 210)))
;(setq tc_gjmj6 (/ (* tc_area 200 tc_t10) tc_t9))
;(if (>= tc_t7 10) (setq tc_gjmj6 (/ (* tc_gjmj6 300) 210)))
)))
)
<font face="Verdana">[检查文字 gjmj.lsp 正在加载...]<br/>....<br/>; 警告: 用作函数的局部变量: H<br/>; 警告: 用作函数的局部变量: N<br/>.......<br/>; 错误: 表达式中有错误函数: (1 N3)<br/>..<br/>; 错误: 表达式中有错误函数: (5 N5)<br/>; 检查完成.</font> http://atlisp.cn/stable/at-structure/readme.mp4
结构绘图工具，查钢筋面积等。
http://atlisp.cn/package-info?name=at-structure&edition=stable
把代码弄个压缩文件发下，这一大片很难整理。。。。 <font face="Verdana">[检查文字 gjmj.lsp 正在加载...]<br/>....<br/>; 警告: 用作函数的局部变量: H<br/>; 警告: 用作函数的局部变量: N<br/>.......<br/>; 错误: 表达式中有错误函数: (1 N3)<br/>..<br/>; 错误: 表达式中有错误函数: (5 N5)<br/>; 检查完成.</font> 哎，就是很管用哈，不过还有其他的高手有类似的插件 继续努力... 这个是源码，高手来出手啊 把一楼的代码整理了下{:1_1:}
初入宝地，都太厉害了
页:
[1]
2