[求助]程序优化

123456abc · 发表于 2008-3-7 12:59

请高手帮忙优化下面一段程序，要求简洁，可以在cad2004使用，且可以改变字高和圆圈及椭圆大小，谢谢！！
(defun C:BALLOON
(/ tmp ts th nh ip sp ali le errexit bx acadver
     LBLOCK BLAYER TEXTGAP TEXTSIZE BWIDTH)
    (setq TEXTGAP 1)     ;希望的文本和“气泡”的间距（1单位=尺寸文本高）
    (setq TEXTSIZE 4)   ;1个单位高字符的平均宽度（仅用于R11）
    (setq BWIDTH 0.04)     ;“气泡”线宽：nil=无宽度（1单位=尺寸文本高，如果气泡是椭圆，无效，且在R13中PELLIPSE=0）
(setq acadver (read (substr (getvar "ACADVER") 1 2)))
(if (/= (type acadver) 'INT) (setq acadver 0))

(defun errexit (s)
    (princ "\n错误： ")
    (princ s)
    (restore)
)

(defun bx ()
    (if le (entdel le))
    (setvar "CMDECHO" (car oldvar))
    (setvar "BLIPMODE" (cadr oldvar))
    (setvar "OSMODE" (nth 2 oldvar))
    (setvar "CLAYER" (nth 3 oldvar))
    (setvar "DONUTID" (nth 4 oldvar))
    (setvar "DONUTOD" (nth 5 oldvar))
    (setq *error* olderr)
    (princ)
)
;Main Program
(setq T (not nil))
(setq olderr *error*
        restore bx
        *error* errexit
)
(setq oldvar
    (list
      (getvar "CMDECHO")
      (getvar "BLIPMODE")
      (getvar "OSMODE")
      (getvar "CLAYER")
      (getvar "DONUTID")
      (getvar "DONUTOD")
    )
)
(setvar "CMDECHO" 0)
(setvar "BLIPMODE" 0)
(setvar "OSMODE" 0)
(terpri)
(if (= acadver 11)            ;是R11吗？

    (defun textbox (elist)      ;如果是，定义一个定制的文本框函数
      (list
        '(0 0 0)
        (list
          (* (strlen (cdr (assoc 1 elist))) (cdr (assoc 40 elist)) TEXTSIZE)
          (cdr (assoc 40 elist))
          0
        )
      )
    )
)
(if
    (= 0
      (setq th
        (cdr (assoc '40 (tblsearch "style" (getvar "textstyle"))))
      )
    )
    (setq nh (setq th (* (getvar "DIMTXT") (getvar "DIMSCALE"))))
    (setq nh nil)
)
(if BLAYER
    (command "._LAYER"
      (if (tblsearch "LAYER" BLAYER) "_S" "_M")
      BLAYER
      ""
    )
)
(if (setq ip (setq sp (getpoint "拾取旁注线起点： ")))
    (progn
      (entmake (list '(0 . "POINT") (cons 10 (trans sp 1 0))))
      (setq le (entlast))
      (command "._DIM1" "_LEADER")
      (setvar "CMDECHO" 1)
      (command sp)
      (while
        (progn
          (initget 128)
          (setq sp (getpoint sp))
        )
        (command sp)
      )
      (setvar "CMDECHO" 0)
      (command)
      (setq sp (trans (cdr (assoc '11 (entget (entlast)))) 0 1))
      (setq ali (angle (trans (cdr (assoc '10 (entget (entlast)))) 0 1) sp))
      (setq tmp (getstring T "键入文本： "))
      (setq ts (textbox (list (cons '1 tmp) (cons '40 th))))
      (setq ts
        (list
          (+ (- (car (cadr ts)) (car (car ts))) (* 2 TEXTGAP th))
          (* 3 TEXTGAP th)
        )
      )
      (command "._TEXT"
               "_M"
               (polar
                 sp
                 ali
                 (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts)))
               )
      )
      (if nh (command th))
      (command
        (if (<= (strlen tmp) 2)
          '0
          (rtd
            (if
              (and (< ali (* 3 (/ pi 2))) (> ali (/ pi 2)))
              (+ ali pi)
              ali
            )
          )
        )
        tmp
      )
      (if (<= (strlen tmp) 2)
        (command "._DONUT"
                 (cadr ts)
                 (cadr ts)
                 (polar
                   sp
                   ali
                   (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts)))
                 )
                 ""
        )
        (command "._ELLIPSE"
                 sp
                 (polar sp ali (if (<= (strlen tmp) 2) (cadr ts) (car ts)))
                 (/ (cadr ts) 2)
        )
      )
      (if LBLOCK
        (progn
          (entmake (list
            (cons '0 "BLOCK")
            (cons '2 "*U")
            (cons '70 1)
            (cons '10 ip)
          ))
          (setq th (setq tmp le))
          (while (setq tmp (entnext tmp))
            (entmake (entget tmp))
          )
          (setq tmp (entmake (list (cons '0 "ENDBLK"))))
          (while (setq th (entnext th))
            (entdel th)
          )
          (entdel le)
          (setq le nil)
          (entmake (list
            (cons '0 "INSERT")
            (cons '2 tmp)
            (cons '10 ip)
          ))
        )
      )
    )
)
(restore)
(princ)
)

123456abc · 发表于 2008-3-9 17:18

高手呢帮帮忙啊程序本身是没有问题的，只是需要优化一下

ZZXXQQ · 发表于 2008-3-9 22:04

本帖最后由作者于 2008-3-10 21:13:02 编辑

(defun C:BALLOON (/ tmp ts th nh ip sp ali le errexit restore acadver TEXTGAP BWIDTH)
(defun errexit (s)
(princ "\n错误 : ")
(princ s)
(restore)
)
(defun restore ()
(if le (entdel le))
(setvar "CMDECHO" (car oldvar))
(setvar "BLIPMODE" (cadr oldvar))
(setvar "OSMODE" (nth 2 oldvar))
(setvar "CLAYER" (nth 3 oldvar))
(setvar "DONUTID" (nth 4 oldvar))
(setvar "DONUTOD" (nth 5 oldvar))
(setq *error* olderr)
)
;Main Program
(setq TEXTGAP 1) ;希望的文本和“气泡”的间距（1单位=尺寸文本高）
(setq BWIDTH 0.04) ;“气泡”线宽：nil=无宽度（1单位=尺寸文本高，如果气泡是椭圆，无效，且在R13中PELLIPSE=0）
(setq acadver (read (substr (getvar "ACADVER") 1 2)))
(if (/= (type acadver) 'INT) (setq acadver 0))
(setq olderr *error* *error* errexit)
(setq oldvar
(list (getvar "CMDECHO") (getvar "BLIPMODE") (getvar "OSMODE")
(getvar "CLAYER") (getvar "DONUTID") (getvar "DONUTOD"))
)
(setvar "CMDECHO" 0)
(setvar "BLIPMODE" 0)
(setvar "OSMODE" 0)
(if (= (setq th (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)
(setq nh (setq th (* (getvar "DIMTXT") (getvar "DIMSCALE"))))
(setq nh nil)
)
(if (setq ip (setq sp (getpoint "\n拾取旁注线起点 :"))) (progn
(entmake (list '(0 . "POINT") (cons 10 (trans sp 1 0))))
(setq le (entlast))
(command "._DIM1" "_LEADER")
(setvar "CMDECHO" 1)
(command sp)
(while (setq sp (getpoint sp "\n下一点 :")) (command sp))
(setvar "CMDECHO" 0)
(command)
(setq sp (trans (cdr (assoc 11 (entget (entlast)))) 0 1))
(setq ali (angle (trans (cdr (assoc 10 (entget (entlast)))) 0 1) sp))
(setq tmp (getstring T "\n键入文本 : "))
(setq ts (textbox (list (cons 1 tmp) (cons 40 th))))
(setq ts (list
(+ (- (car (cadr ts)) (car (car ts))) (* 2 TEXTGAP th))
(* 3 TEXTGAP th)
)
)
(command "._TEXT" "_M" (polar sp ali (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts)))))
(if nh (command th))
(command
(if (<= (strlen tmp) 2)
0
(rtd (if (and (< ali (* 3 (/ pi 2))) (> ali (/ pi 2))) (+ ali pi) ali))
)
tmp
)
(if (<= (strlen tmp) 2)
(command "._DONUT" (cadr ts) (cadr ts)
(polar sp ali (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts))))
""
)
(command "._ELLIPSE"
sp
(polar sp ali (if (<= (strlen tmp) 2) (cadr ts) (car ts)))
(/ (cadr ts) 2)
)
)
))
(restore)
(princ)
)

(defun C:BALLOON (/ tmp ts th nh ip sp ali le errexit restore acadver TEXTGAP BWIDTH)
 (defun errexit (s)
  (princ "\n错误 : ")
  (princ s)
  (restore)
 )
 (defun restore ()
  (if le (entdel le))
  (setvar "CMDECHO" (car oldvar))
  (setvar "BLIPMODE" (cadr oldvar))
  (setvar "OSMODE" (nth 2 oldvar))
  (setvar "CLAYER" (nth 3 oldvar))
  (setvar "DONUTID" (nth 4 oldvar))
  (setvar "DONUTOD" (nth 5 oldvar))
  (setq *error* olderr)
 )
  ;Main Program
 (setq TEXTGAP 1)     ;希望的文本和“气泡”的间距（1单位=尺寸文本高）
 (setq BWIDTH 0.04)     ;“气泡”线宽：nil=无宽度（1单位=尺寸文本高，如果气泡是椭圆，无效，且在R13中PELLIPSE=0）
 (setq acadver (read (substr (getvar "ACADVER") 1 2)))
 (if (/= (type acadver) 'INT) (setq acadver 0))
 (setq olderr *error* *error* errexit)
 (setq oldvar
  (list (getvar "CMDECHO")  (getvar "BLIPMODE")  (getvar "OSMODE")
        (getvar "CLAYER") (getvar "DONUTID") (getvar "DONUTOD"))
 )
 (setvar "CMDECHO" 0)
 (setvar "BLIPMODE" 0)
 (setvar "OSMODE" 0)
 (if (= (setq th (cdr (assoc 40 (tblsearch "style" (getvar "textstyle"))))) 0)
  (setq nh (setq th (* (getvar "DIMTXT") (getvar "DIMSCALE"))))
  (setq nh nil)
 )
 (if (setq ip (setq sp (getpoint "\n拾取旁注线起点 :"))) (progn
  (entmake (list '(0 . "POINT") (cons 10 (trans sp 1 0))))
  (setq le (entlast))
  (command "._DIM1" "_LEADER")
  (setvar "CMDECHO" 1)
  (command sp)
  (while (setq sp (getpoint sp "\n下一点 :")) (command sp))
  (setvar "CMDECHO" 0)
  (command)
  (setq sp (trans (cdr (assoc 11 (entget (entlast)))) 0 1))
  (setq ali (angle (trans (cdr (assoc 10 (entget (entlast)))) 0 1) sp))
  (setq tmp (getstring T "\n键入文本 : "))
  (setq ts (textbox (list (cons 1 tmp) (cons 40 th))))
  (setq ts (list 
            (+ (- (car (cadr ts)) (car (car ts))) (* 2 TEXTGAP th))
            (* 3 TEXTGAP th)
           )
  )
  (command "._TEXT" "_M" (polar sp ali (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts)))))
  (if nh (command th))
  (command 
   (if (<= (strlen tmp) 2)
     0
    (rtd (if (and (< ali (* 3 (/ pi 2))) (> ali (/ pi 2))) (+ ali pi) ali))
   )
   tmp
  )
  (if (<= (strlen tmp) 2)
   (command "._DONUT" (cadr ts) (cadr ts)
                 (polar sp ali (* 0.5 (if (<= (strlen tmp) 2) (cadr ts) (car ts))))
                 ""
   )
   (command "._ELLIPSE"
                 sp
                 (polar sp ali (if (<= (strlen tmp) 2) (cadr ts) (car ts)))
                 (/ (cadr ts) 2)
   )
  )
 ))
 (restore)
 (princ)
)

123456abc · 发表于 2008-3-10 15:01

谢谢ZZXXQQ版主，我运行了一下程序，当多于3个字符时提示“no function definition: RTD”

椭圆也无法绘制，请问应该怎么解决？

123456abc · 发表于 2008-3-10 16:04

文字高度也没有改变

ZZXXQQ · 发表于 2008-3-10 21:19

原程序就缺RTD函数，只好编了个。三楼已改。

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