[LISP程序]：请高手帮我调一下程序

alwaysbin · 发表于 2007-2-11 12:31:52

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

。

[FONT=courier new]
(defun c:bar (/)
(princ "\n选择钢筋： ")
(setq ss1 (ssget ":s" '((0 . "TEXT"))))
(setq str1 (cdr (assoc 1 (setq ent1 (entget (ssname ss1 0))))))
(setq bba (BarArea (last (Parse_It str1 ";"))));计算出钢筋面积
(setq bbc (FIX (/ bba 100)));除以100并取整
);
;以下为子程序
;;计算钢筋面积
(defun BarArea (str / e)
(apply
'+
(mapcar '(lambda (x)
(setq e (Parse_It (vl-string-subst "x" "%%132" x) "x"))
(* (read (car e)) (CirArea (read (cadr e)))))
(Parse_It (car (Parse_It str " ")) "+")))
)
;计算园面积
(defun CirArea (dia)
(* pi dia dia 0.25)
)
;选筋(对称)
(defun PickBars (a n / barlst dia1 pos )
(setq barlst '(12 14 16 18 20 22 25 28 30 32))
(setq dia1 (1+ (fix (sqrt (/ (* 4 (/ a n)) pi)))))
(if (not (member dia1 barlst))
(setq dia1 (nth (setq pos (vl-position
dia1
(vl-sort (cons dia1 barlst) '<)))
barlst))
(setq pos (vl-position dia1 barlst))
)
(if dia1
(cond
((<= n 2)
(strcat "2%%132" (itoa dia1)))
((> n 2)
(if (> pos 0)
(if (> (+ (* (- n 2) (CirArea (nth (1- pos) barlst))) (* 2 (CirArea dia1))) a)
(strcat "2%%132"
(itoa dia1)
"+"
(itoa (- n 2))
"%%132"
(itoa (nth (1- pos) barlst)))
(strcat (itoa n) "%%132" (itoa dia1))
)
(strcat (itoa n) "%%132" (itoa dia1))
);if
)
);cond
) ;if
)
; 作者: Bill Kramer
;
(defun Parse_It (inStr ;Input string to parse
Delim ;Delimeter character (or ascii code)
/ Res ;Result list buffer
Inx ;Character location of delim in string
InxP ;Previous character location
)
;
; Verify DELIM is of the proper type
;
(setq Delim (if (= (type Delim) 'STR)
(ASCII Delim) ;Convert character to integer
(if (/= (type Delim) 'INT) ;is it integer?
32 ;then use space
(if (> 0 Delim 256)
Delim
32)))
;
; Set up parameters for string search loop
;
Inx (VL-String-Position Delim inStr 0)
InxP -1
)
;
(while (and Inx (< Inx (strlen inStr)))
(setq Res
(cons (substr inStr (+ 2 InxP) (- Inx InxP 1))
Res)
InxP Inx
Inx (VL-String-Position Delim inStr (1+ InxP))
)
)
(setq Res (cons (substr inStr (+ 2 InxP)) Res))
(reverse Res)
)
;
[/FONT]

[FONT=courier new] 
(defun c:bar (/) 
 (princ "\n选择钢筋： ") 
  (setq ss1 (ssget ":s" '((0 . "TEXT")))) 
  (setq str1 (cdr (assoc 1 (setq ent1 (entget (ssname ss1 0)))))) 
      (setq bba (BarArea (last (Parse_It str1 ";"))));计算出钢筋面积 
  (setq bbc (FIX (/ bba 100)));除以100并取整 
  ); 
 
 
 
 
;以下为子程序 
 
 
 
;;计算钢筋面积 
(defun BarArea    (str / e) 
  (apply 
    '+ 
    (mapcar '(lambda (x) 
           (setq e (Parse_It (vl-string-subst "x" "%%132" x) "x")) 
           (* (read (car e)) (CirArea (read (cadr e))))) 
        (Parse_It (car (Parse_It str " ")) "+"))) 
  ) 
 ;计算园面积 
(defun CirArea    (dia) 
  (* pi dia dia 0.25) 
  ) 
 ;选筋(对称) 
(defun PickBars     (a n / barlst dia1 pos ) 
  (setq barlst '(12 14 16 18 20 22 25 28 30 32)) 
  (setq dia1 (1+ (fix (sqrt (/ (* 4 (/ a n)) pi))))) 
  (if (not (member dia1 barlst)) 
    (setq dia1 (nth (setq pos (vl-position 
                dia1 
                (vl-sort (cons dia1 barlst) '<))) 
            barlst)) 
    (setq pos (vl-position dia1 barlst)) 
  ) 
  (if dia1 
    (cond 
      ((<= n 2) 
       (strcat "2%%132" (itoa dia1))) 
      ((> n 2) 
       (if (> pos 0) 
     (if (> (+ (* (- n 2) (CirArea (nth (1- pos) barlst))) (* 2 (CirArea dia1))) a) 
      (strcat "2%%132" 
                (itoa dia1) 
                "+" 
                (itoa (- n 2)) 
                "%%132" 
                (itoa (nth (1- pos) barlst))) 
      (strcat (itoa n) "%%132" (itoa dia1)) 
      ) 
     (strcat (itoa n) "%%132" (itoa dia1)) 
    );if 
       ) 
      );cond 
    ) ;if 
  ) 
 ; 作者: Bill Kramer 
 ; 
(defun Parse_It     (inStr ;Input string to parse 
          Delim ;Delimeter character (or ascii code) 
          / Res ;Result list buffer 
          Inx ;Character location of delim in string 
          InxP ;Previous character location 
) 
 ; 
 ; Verify DELIM is of the proper type 
 ; 
  (setq    Delim (if (= (type Delim) 'STR) 
        (ASCII Delim) ;Convert character to integer 
        (if (/= (type Delim) 'INT) ;is it integer? 
          32 ;then use space 
          (if (> 0 Delim 256) 
            Delim 
            32))) 
 ; 
 ; Set up parameters for string search loop 
 ; 
    Inx   (VL-String-Position Delim inStr 0) 
    InxP  -1 
    ) 
 ; 
  (while (and Inx (< Inx (strlen inStr))) 
    (setq Res 
           (cons (substr inStr (+ 2 InxP) (- Inx InxP 1)) 
             Res) 
      InxP Inx 
      Inx  (VL-String-Position Delim inStr (1+ InxP)) 
      ) 
    ) 
  (setq Res (cons (substr inStr (+ 2 InxP)) Res)) 
  (reverse Res) 
  ) 
 ; 
 
 
  [/FONT]

这是一个计算钢筋面积并写在图上的程序，我只写了一部分，剩下的不会……

现在有几个问题：

1。我算出来了面积，即bbc，但想把它用txt写到图上，大小和刚才选的文字一样大，位置在文字上方，间隔一1。5个文字高度，颜色用红色。

2。现在的程序只能写一个，我想改成批量的，即框选后，写出所有的面积在图上。

3。如果图上钢筋的代码不是%%132，而是%%131，怎么办？？

解释一下，一般钢筋的表示方法，2根18的钢筋，写法是2%%13218，%%132表示钢筋。

计算钢筋面积的子程序，我已经写在了后面

coolzhb · 发表于 2007-2-11 21:19:17

给你一个程序，我机器里面的，供你参考！另外稽龙也写了一个程序，你可以找找，在论坛里面！

[FONT=courier new]
(defun c:4 (/ 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 7)
(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 1)
(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 mj (txt1 / k1 n1 d as) ; 计算诸如4%%13225所代表的面积:1963mm
; 2
(setq k1 (vl-string-search "%%13" txt1)) ; k1=2 12%%13125 6/5
(setq n1 (atoi (substr txt1 1 k1)))
(setq d (atoi (substr txt1 (+ k1 6))))
(setq as (* pi d d 0.25 n1))
)
(defun mjj (txt / kong plus ww s1 s2) ; 只要有txt就可以求出面积
(if (vl-string-search " " txt) ; 去除两空格字符
(setq txt (vl-string-subst " " " " txt))
)
(setq kong (vl-string-search " " txt)) ; 获得空格所在位置
(if (/= kong nil) ; 如果有空格，则将txt从空格处去掉尾巴
(setq txt (substr txt 1 kong))
) ; 到目前为止，txt只剩下有+号和无+号两
; 种情况了
(setq plus (vl-string-search "+" txt)) ; 获得+所在位置
(if (= plus nil) ; 如果没有+，则直接进行计算
(setq ww (mj txt))
(progn
(setq s1 (mj (substr txt 1 plus)))
(setq s2 (mj (substr txt (+ plus 2))))
(setq ww (+ s1 s2))
)
)
(setq ww ww)
)
(defun dis (ent / obj laynm name st1 st2 st3 lst h ang n text fenhao ww1
ww2 ss1 ss2 i d s i1 i2 i3 s1 s2 n as1 as2 fyjisuan fy
)
(setq obj (vlax-ename->vla-object ent))
(setq laynm (strcat "图层:" (dxf ent 8))
name (dxf ent 0)
)
(if (or
(= name "TEXT")
(= name "MTEXT")
)
(progn
(setq text (vla-get-textstring obj)) ; 获得文字内容
(if (vl-string-search "%%13" text)
(progn ; (setq text "2%%13114;3%%13114")
(setq fenhao (vl-string-search ";" text)) ; 获得;所在位置
; 集中标注情况
(if (>= fenhao 0) ; 有分号则输出面积
(progn
(setq ww1 (substr text 1 fenhao)) ; 分号前面的文字
(setq ww2 (substr text (+ fenhao 2))) ; 分号后面的文字
(setq ss1 (/ (mjj ww1) 100))
(setq ss2 (/ (mjj ww2) 100))
(setq ss1 (rtos ss1 2 2))
(setq ss2 (rtos ss2 2 2))
(setq lst (list (strcat ss1 ";" ss2)))
)
(setq lst (list (rtos (/ (mjj text) 100) 2 2))) ; 如果没有;则?
; ??屑扑?
)
(if ; %%1308@100板钢筋情况
(wcmatch text "%%13#*[@-@]###,%%13#*[@-@]##,%%13#*[@-@]#")
(progn ; (setq text "%%13110@200")
(setq i (vl-string-search "@" text))
(setq d (atof (substr text 6 (- i 6 -1))))
(setq s (atof (substr text (+ i 2))))
(setq stellas (/ (* pi d d 0.25 1000) s))
(setq fy (fylisp (substr text 1 5)))
(setq fyjisuan 210) ; 计算时用一级钢则采用210，可根据情况
; 修改*******************************
; ***
(if (= fy 210) ; 如果是一级钢则只输出自身面积，否则?
; 涑鲎陨砑白?怀梢患陡趾蟮拿婊?
(setq lst (list (strcat "板筋:" (rtos stellas 2 1))))
(setq lst (list (strcat "板筋:" (rtos stellas 2 1) "/"
(rtos (/ (* stellas fy) fyjisuan)
2 1
)
)
)
)
)
)
)
(if ; %%1308@100/150(2)箍筋情况
(wcmatch text "%%13#*[@-@]*/*(#)")
(progn
(setq i1 (vl-string-search "@" text))
(setq i2 (vl-string-search "/" text))
(setq i3 (vl-string-search "(" text))
(setq d (atof (substr text 6 (- i1 6 -1))))
(setq s1 (atof (substr text (+ i1 2) (- i2 i1))))
(setq s2 (atof (substr text (+ i2 2) (- i3 i1))))
(setq n (atof (substr text (+ i3 2) (- (strlen text) i3 2))))
(setq as1 (/ (* pi d d 0.25 100 n) s1 100)) ; 换成100间距时?
; 墓拷蠲婊?
(setq as2 (/ (* pi d d 0.25 100 n) s2 100)) ; 换成100间距时?
; 墓拷蠲婊?
(setq fy (fylisp (substr text 1 5)))
(setq fyjisuan 210) ; 计算时用一级钢则采用210，可根据情况
; 修改*******************************
; ***
(if (= fy 210)
(setq lst (list (strcat "G" (rtos as1 2 2) "-"
(rtos as2 2 2)
)
)
)
(setq lst (list (strcat "G" (rtos as1 2 2) "-"
(rtos as2 2 2)
) (strcat "G" (rtos (/ (* as1 fy) fyjisuan)
2 2
) "-" (rtos (/ (* as2 fy)
fyjisuan
) 2 2
)
)
)
)
)
)
)
(if ; %%1308@100(2)箍筋情况
(wcmatch text
"%%13#*[@-@]###(#),%%13#*[@-@]##(#),%%13#*[@-@]#(#)"
)
(progn
(setq i1 (vl-string-search "@" text))
(setq i2 (vl-string-search "(" text))
(setq d (atof (substr text 6 (- i1 6 -1))))
(setq s1 (atof (substr text (+ i1 2) (- i2 i1))))
(setq n (atof (substr text (+ i2 2) (- (strlen text) i2 2))))
(setq as1 (/ (* pi d d 0.25 100 n) s1 100)) ; 换成100间距时?
; 墓拷蠲婊?
(setq fy (fylisp (substr text 1 5)))
(setq fyjisuan 210) ; 计算时用一级钢则采用210，可根据情况
; 修改*******************************
; ***
(if (= fy 210)
(setq lst (list (strcat "G" (rtos as1 2 2))))
(setq lst (list (strcat "G" (rtos as1 2 2))
(strcat "G" (rtos (/ (* as1 fy) fyjisuan)
2 2
)
)
)
)
)
)
)
(if ; g6%%13112情况
(wcmatch text "G*%%13#*,N*%%13#*")
(progn ; (setq text "g12%%1318")
(setq i (vl-string-search "%%13" text))
(setq n (atof (substr text 2 i)))
(setq d (atof (substr text (+ i 6))))
(setq as1 (* pi d d 0.25 n 0.5 0.01))
(setq lst (list (strcat "单边面积:" (rtos as1 2 2))))
)
)
)
)
)
(setq lst (list "非文字对象!"))
)
(setq ss (ssadd)
h (/ (getvar "viewsize") 10)
)
(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
) "STANDARD" 1
) ss
)
)
)
(vl-load-com)
(command "_.undo" "_m")
(princ "动态显示梁、板主、箍筋面积\n")
(setq olderr *error*
*error* myerr
)
(setq oldos (getvar "osmode"))
(setq oldfill (getvar "fillmode"))
(setvar "osmode" 0)
(setvar "fillmode" 1)
(setvar "cmdecho" 0)
(command "_.style" "STANDARD" "tssdeng2.shx,tssdchn.shx" "" 0.7 "" "" ""
""
)
(setq ss (ssadd))
(while (not pd)
(while (not (progn
(setq gr (grread t 2))
(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)
)
;;; bb定义完成
(defun fylisp (ttt / fy)
(cond
((= ttt "%%130")
(setq fy 210)
)
((= ttt "%%131")
(setq fy 300)
)
((= ttt "%%132")
(setq fy 360)
)
((= ttt "%%133")
(setq fy 360)
)
)
(setq fy fy)
)
[/FONT]

[FONT=courier new] 
(defun c:4 (/ 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 7) 
                    (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 1) 
                    (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 mj (txt1 / k1 n1 d as)               ; 计算诸如4%%13225所代表的面积:1963mm 
                                       ; 2 
    (setq k1 (vl-string-search "%%13" txt1)) ; k1=2   12%%13125 6/5 
    (setq n1 (atoi (substr txt1 1 k1))) 
    (setq d (atoi (substr txt1 (+ k1 6)))) 
    (setq as (* pi d d 0.25 n1)) 
  ) 
 
  (defun mjj (txt / kong plus ww s1 s2)        ; 只要有txt就可以求出面积 
    (if (vl-string-search "  " txt)    ; 去除两空格字符 
      (setq txt (vl-string-subst " " "  " txt)) 
    ) 
    (setq kong (vl-string-search " " txt)) ; 获得空格所在位置 
    (if (/= kong nil)                       ; 如果有空格，则将txt从空格处去掉尾巴 
      (setq txt (substr txt 1 kong)) 
    )                                       ; 到目前为止，txt只剩下有+号和无+号两 
                                       ; 种情况了 
    (setq plus (vl-string-search "+" txt)) ; 获得+所在位置 
    (if (= plus nil)                       ; 如果没有+，则直接进行计算 
      (setq ww (mj txt)) 
      (progn 
        (setq s1 (mj (substr txt 1 plus))) 
        (setq s2 (mj (substr txt (+ plus 2)))) 
        (setq ww (+ s1 s2)) 
      ) 
    ) 
    (setq ww ww) 
  ) 
 
 
  (defun dis (ent / obj laynm name st1 st2 st3 lst h ang n text fenhao ww1 
                  ww2 ss1 ss2 i d s i1 i2 i3 s1 s2 n as1 as2 fyjisuan fy 
             ) 
    (setq obj (vlax-ename->vla-object ent)) 
    (setq laynm (strcat "图层:" (dxf ent 8)) 
          name (dxf ent 0) 
    ) 
 
    (if (or 
          (= name "TEXT") 
          (= name "MTEXT") 
        ) 
      (progn 
        (setq text (vla-get-textstring obj)) ; 获得文字内容 
        (if (vl-string-search "%%13" text) 
          (progn                       ; (setq text "2%%13114;3%%13114") 
            (setq fenhao (vl-string-search ";" text)) ; 获得;所在位置 
                                       ; 集中标注情况 
            (if (>= fenhao 0)               ; 有分号则输出面积 
              (progn 
                (setq ww1 (substr text 1 fenhao)) ; 分号前面的文字 
                (setq ww2 (substr text (+ fenhao 2))) ; 分号后面的文字 
                (setq ss1 (/ (mjj ww1) 100)) 
                (setq ss2 (/ (mjj ww2) 100)) 
                (setq ss1 (rtos ss1 2 2)) 
                (setq ss2 (rtos ss2 2 2)) 
                (setq lst (list (strcat ss1 ";" ss2))) 
              ) 
              (setq lst (list (rtos (/ (mjj text) 100) 2 2))) ; 如果没有;则? 
                                       ; ??屑扑? 
            ) 
 
            (if                        ; %%1308@100板钢筋情况 
              (wcmatch text "%%13#*[@-@]###,%%13#*[@-@]##,%%13#*[@-@]#") 
              (progn                       ; (setq text "%%13110@200") 
                (setq i (vl-string-search "@" text)) 
                (setq d (atof (substr text 6 (- i 6 -1)))) 
                (setq s (atof (substr text (+ i 2)))) 
                (setq stellas (/ (* pi d d 0.25 1000) s)) 
                (setq fy (fylisp (substr text 1 5))) 
 
                (setq fyjisuan 210)    ; 计算时用一级钢则采用210，可根据情况 
                                       ; 修改******************************* 
                                       ; *** 
                (if (= fy 210)               ; 如果是一级钢则只输出自身面积，否则? 
                                       ; 涑鲎陨砑白?怀梢患陡趾蟮拿婊? 
                  (setq lst (list (strcat "板筋:" (rtos stellas 2 1)))) 
                  (setq lst (list (strcat "板筋:" (rtos stellas 2 1) "/" 
                                          (rtos (/ (* stellas fy) fyjisuan) 
                                                2 1 
                                          ) 
                                  ) 
                            ) 
                  ) 
                ) 
              ) 
            ) 
 
            (if                        ; %%1308@100/150(2)箍筋情况 
              (wcmatch text "%%13#*[@-@]*/*(#)") 
              (progn 
                (setq i1 (vl-string-search "@" text)) 
                (setq i2 (vl-string-search "/" text)) 
                (setq i3 (vl-string-search "(" text)) 
                (setq d (atof (substr text 6 (- i1 6 -1)))) 
                (setq s1 (atof (substr text (+ i1 2) (- i2 i1)))) 
                (setq s2 (atof (substr text (+ i2 2) (- i3 i1)))) 
                (setq n (atof (substr text (+ i3 2) (- (strlen text) i3 2)))) 
                (setq as1 (/ (* pi d d 0.25 100 n) s1 100)) ; 换成100间距时? 
                                       ; 墓拷蠲婊? 
                (setq as2 (/ (* pi d d 0.25 100 n) s2 100)) ; 换成100间距时? 
                                       ; 墓拷蠲婊? 
                (setq fy (fylisp (substr text 1 5))) 
                (setq fyjisuan 210)    ; 计算时用一级钢则采用210，可根据情况 
                                       ; 修改******************************* 
                                       ; *** 
 
                (if (= fy 210) 
                  (setq lst (list (strcat "G" (rtos as1 2 2) "-" 
                                          (rtos as2 2 2) 
                                  ) 
                            ) 
                  ) 
                  (setq lst (list (strcat "G" (rtos as1 2 2) "-" 
                                          (rtos as2 2 2) 
                                  ) (strcat "G" (rtos (/ (* as1 fy) fyjisuan) 
                                                      2 2 
                                                ) "-" (rtos (/ (* as2 fy) 
                                                               fyjisuan 
                                                            ) 2 2 
                                                      ) 
                                    ) 
                            ) 
                  ) 
                ) 
              ) 
            ) 
 
 
            (if                        ; %%1308@100(2)箍筋情况 
              (wcmatch text 
                       "%%13#*[@-@]###(#),%%13#*[@-@]##(#),%%13#*[@-@]#(#)" 
              ) 
              (progn 
                (setq i1 (vl-string-search "@" text)) 
                (setq i2 (vl-string-search "(" text)) 
                (setq d (atof (substr text 6 (- i1 6 -1)))) 
                (setq s1 (atof (substr text (+ i1 2) (- i2 i1)))) 
                (setq n (atof (substr text (+ i2 2) (- (strlen text) i2 2)))) 
                (setq as1 (/ (* pi d d 0.25 100 n) s1 100)) ; 换成100间距时? 
                                       ; 墓拷蠲婊? 
                (setq fy (fylisp (substr text 1 5))) 
                (setq fyjisuan 210)    ; 计算时用一级钢则采用210，可根据情况 
                                       ; 修改******************************* 
                                       ; *** 
 
                (if (= fy 210) 
                  (setq lst (list (strcat "G" (rtos as1 2 2)))) 
                  (setq lst (list (strcat "G" (rtos as1 2 2)) 
                                  (strcat "G" (rtos (/ (* as1 fy) fyjisuan) 
                                                    2 2 
                                              ) 
                                  ) 
                            ) 
                  ) 
                ) 
              ) 
            ) 
 
            (if                        ; g6%%13112情况 
              (wcmatch text "G*%%13#*,N*%%13#*") 
              (progn                       ; (setq text "g12%%1318") 
                (setq i (vl-string-search "%%13" text)) 
                (setq n (atof (substr text 2 i))) 
                (setq d (atof (substr text (+ i 6)))) 
 
                (setq as1 (* pi d d 0.25 n 0.5 0.01)) 
                (setq lst (list (strcat "单边面积:" (rtos as1 2 2)))) 
              ) 
            ) 
 
 
          ) 
        ) 
 
      ) 
 
      (setq lst (list "非文字对象!")) 
    ) 
 
    (setq ss (ssadd) 
          h (/ (getvar "viewsize") 10) 
    ) 
    (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 
                           ) "STANDARD" 1 
             ) ss 
      ) 
    ) 
  ) 
 
 
  (vl-load-com) 
  (command "_.undo" "_m") 
  (princ "动态显示梁、板主、箍筋面积\n") 
  (setq olderr *error* 
        *error* myerr 
  ) 
  (setq oldos (getvar "osmode")) 
  (setq oldfill (getvar "fillmode")) 
  (setvar "osmode" 0) 
  (setvar "fillmode" 1) 
  (setvar "cmdecho" 0) 
  (command "_.style" "STANDARD" "tssdeng2.shx,tssdchn.shx" "" 0.7 "" "" "" 
           "" 
  ) 
  (setq ss (ssadd)) 
 
  (while (not pd) 
    (while (not (progn 
                  (setq gr (grread t 2)) 
                  (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) 
) 
;;; bb定义完成 
 
 
(defun fylisp (ttt / fy) 
  (cond 
    ((= ttt "%%130") 
      (setq fy 210) 
    ) 
    ((= ttt "%%131") 
      (setq fy 300) 
    ) 
    ((= ttt "%%132") 
      (setq fy 360) 
    ) 
    ((= ttt "%%133") 
      (setq fy 360) 
    ) 
  ) 
  (setq fy fy) 
) 
 
  [/FONT]

cy956 · 发表于 2007-2-15 23:09:48

我是建筑的，突然要看结构的内容有点抓瞎。：）
以前也为结构兄弟写过，由pkpm的计算结果自动配梁筋之类的程序。

sfjlx · 发表于 2007-2-16 11:09:50

最初由 cy956 发布
.........，由pkpm的计算结果自动配梁筋之类的程序。 [/B]

可否发给我一份原程序?谢谢!我也正在编写相似的程序!想借鉴一下!shenfjliu@126.com

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：请高手帮我调一下程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子