- UID
- 29878
- 积分
- 269
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2003-2-17
- 最后登录
- 1970-1-1
|
马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？立即注册
×
我也改了一个显示钢筋面积的LISP，请LISP高手改进一下
就是%%1308@200(2)显示不了;不知是什么原因
(DEFUN C:DISAPPEARBAR ()
(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 (1+ I))
(IF (AND (NOT (WCMATCH STR "*/*")) (WCMATCH STR "*!*")) (PROGN
(WHILE (AND (< J SL) (/= (SUBSTR STR J 1) "(")) (SETQ J (1+ J)))
(IF (< J SL) (PROGN
(SETQ ENT (SUBST (CONS 1 (SUBSTR STR 1 (1- J))) (CONS 1 STR) ENT))
(ENTMOD ENT)
))
))
)
(PRINC)
)
(DEFUN C:SHOWBAR ()
(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 S3 0 I (1+ I))
(IF (AND (NOT (WCMATCH STR "*/*")) (WCMATCH STR "*!*")) (PROGN
(WHILE (< J SL)
(SETQ S1 "" S2 "")
(WHILE (AND (>= (SETQ ST (SUBSTR STR J 1)) "0") (<= ST "9"))
(SETQ S1 (STRCAT S1 ST) J (1+ J))
)
(SETQ J (+ J 1))
(WHILE (AND (>= (SETQ ST (SUBSTR STR J 1)) "0") (<= ST "9"))
(SETQ S2 (STRCAT S2 ST) J (1+ J))
)
(SETQ S3 (+ (FIX (* (ATOI S1) PI (ATOI S2) (ATOI S2) 0.25)) S3))
(SETQ J (1+ J))
)
(SETQ ENT (SUBST (CONS 1 (STRCAT STR "(" (ITOA (FIX S3)) "mm2)")) (CONS 1 STR) ENT))
(ENTMOD ENT)
))
)
(PRINC)
)
(defun C:vb(/ myerr dxf toang fx add_solid add_text dis olderr oldos oldfill ss pd gr pt ent entold)
(defun myerr(msg)
(setq *error* olderr)
(command "_.undo" "_b")
(princ)
)
(defun dxf(ent i)
(if (= (type ent) 'ename)
(setq ent (entget ent))
)
(cdr (assoc i ent))
)
(defun toang(ang i)
(if (= i 1)
(* ang (/ 180 pi))
(* ang (/ pi 180))
)
)
(defun fx(ang)
(cond
((>= (/ 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)) "#`%`%13[0-4]##,##`%`%13[0-4]##,##`%`%13[0-4]##")
(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)) "#`%`%13[0-4]##/#`%`%13[0-4]##,#`%`%13[0-4]##/##`%`%13[0-4]##,##`%`%13[0-4]##/#`%`%13[0-4]##;##`%`%13[0-4]##/##`%`%13[0-4]##")
(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)) "`%`%13*[50-250]")
(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)) "`%`%13*[50-250]`(*`)")
(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)) "#`%`%13[0-4]##+#`%`%13[0-4]##,#`%`%13[0-4]##+##`%`%13[0-4]##,##`%`%13[0-4]##+#`%`%13[0-4]##;##`%`%13[0-4]##+##`%`%13[0-4]##")
(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 (1+ n)) 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,作者忘了!是你嗎?
;;当鼠标移动到满足过滤条件的像素上时，像素会闪动
;;USAGE:(CS_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 (+ n1 6))))
(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 (+ n2 2)))
(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 (+ n3 6) (1- n4)))
t6 (atof (substr txt3 (+ n4 2)))
)
(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 (+ n2 2)))
(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 (+ n5 6) (- n6 (+ n5 5)))))
(setq tc_t8 (atoi (substr txt3 (+ n6 2) (- n7 (+ n6 1))))
tc_t9 (atoi (substr txt3 (+ n7 2) (- 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)))
)
(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 (+ n5a 6) (- n6a (+ n5a 5)))))
(setq tc_t8 (atoi (substr txt3 (+ n6a 2) (- n7a (+ n6a 1))))
tc_t9a (atoi (substr txt3 (+ n7a 2) (- n8a (1+ n7a))))
tc_t10a (atoi (substr txt3 (+ n8a 2) (- n9a (1+ n8a))))
)
(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)))
))) |
|
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
发表于 2005-11-29 00:16:09
提升卡
置顶卡
沉默卡
变色卡
千斤顶
