[LISP函数]：快速修改文字字体字高

leer

(defun *error*(st)
  (princ (strcat "Error: " st))
  (princ)
)

(defun C:cst(/ test ss len n en1 a oldr newr ent nn)
  (setvar "CMDECHO" 0)
  (setq test T nn 0)
  (while test
    (setq ss (ssadd))
    (setq ss (ssget))
    (if (= nil ss)
      (setq test nil)
      (progn
        (setq len (sslength ss))
        (setq n 1 s 1)
        (while (<= n len)
          (setq en1 (ssname ss (1- n)))
          (setq a (entget en1))
          (if  (= "TEXT" (cdr (assoc 0 a)))
            (progn
              (if (= s 1)
                (progn
                  (setq oldr (cdr (assoc 7 a)))
                  (setq newr (strcase (getstring (strcat "\nNew font <" oldr ">:"))))
                  (if (= newr "") (setq newr oldr))
                  (setq s nil)
                )
              )
              (if (= (tblsearch "style" newr) nil)
                (progn
                  (cond ((= newr "XW")
                          (command "STYLE" "xw" "txt" "0" ".8" "0" "n" "n" "n"))
                        ((= newr "HZ")
                          (command "STYLE" "hz" "txt,hztxt" "0" ".8" "0" "n" "n" "n"))
                        ((= newr "CHINA")
                          (command "STYLE" "china" "txt,china" "0" ".8" "0" "n" "n" "n"))
                        ((= newr "LM")
                          (command "STYLE" "lm" "complex" "0" ".8" "0" "n" "n" "n"))
                        (T (princ (strcat "\nPlease define style " newr " use STYLE command !")))
                  )
                )
              )
              (setq ent (subst (cons 7 newr) (assoc 7 a) a))
              (entmod ent)
              (setq nn (1+ nn))
            )
          )
          (setq n (1+ n))
        )
      )
    )
  )
  (princ (strcat (itoa nn) " changed !"))
  (princ)
)
;修改字高的
(DEFUN changtextheight (EN TCH_ok / th1 aa1)

  (if b
    (progn
      (setq kk 0)
      (setq ss "\n新字高<")
      (SETQ TH (CDR (ASSOC 40 EN)))
      (if tch_ok
(progn
   (setq th1 (rtos (* th scale_47) 2 2))
   (setq th (* th scale_47))
)
(setq th1 (rtos (/ th 1) 2 2))
      )
      (princ (strcat ss th1 "mm>:"))
      (setq aa1 (getreal))
      (if aa1
(setq th (* aa1 1))
      )
      (setq b nil)

    )
  )
  (if TCH_ok
    (progn
      (setq th (/ th scale_47))
      (setq en (subst (cons 40 th) (assoc 40 en) en))
      (setq th (* th scale_47))
    )
    (setq en (subst (cons 40 th) (assoc 40 en) en))
  )
  (entmod en)
  (setq kk (1+ kk))
)
******************************************************

(defun C:CH (/ LL EN k kk th b)
  (setq sse (ssget))
  (if sse
    (progn
      (setq ll (sslength sse)
     b  0
     k  0
     kk 0
      )
      (repeat ll
(SETQ EN (ENTGET (ssname sse k)))
(setq TCH_ok nil)
(if (= (CDR (ASSOC 0 EN)) "TEXT")
   (changtextheight en TCH_ok)
   (if (= (CDR (ASSOC 0 EN)) "TCH_TEXT")
     (progn
       (setq scale_47 (cdr (assoc 47 en)))
     ;(setq en (subst (cons 72 11) (assoc 72 en) en))
       (setq TCH_ok 0)
       (changtextheight en TCH_ok)
     )

   )
)    ;if text_end

(if (= (CDR (ASSOC 0 EN)) "INSERT")
   (progn
     (setq main_B_name (cdr (assoc -1 en)))
     (setq an (tblsearch "block" (cdr (assoc 2 en))))
     (setq an_name (cdr (assoc -2 an)))
     (while (/= an_name nil)
       (setq en (entget an_name))
       (if (= (CDR (ASSOC 0 EN)) "TEXT")
  (progn
    (changtextheight en TCH_ok)

  )
       )
       (setq an_name (entnext an_name))
     )
     (entupd main_B_name)
   )
)    ;if_insert_end

(setq k (1+ k))
      )     ;repeat_end

      (princ (strcat "改了" (rtos kk) "个字符."))
    )
  )
  (PRINC)
)
**************************************************
(defun C:CW (/ p l n nw chm en ow enm e1)
      (setq p (ssget))
      (if p (progn
        (setq l 0 n (sslength p) chm 0)
        (while (< l n)
          (setq enm (cdr (assoc 0 (setq en (entget (ssname p l))))))
          (if(or (= enm "LWPOLYLINE") (= enm "POLYLINE") (= enm "LINE") (= enm "ARC")(= enm "CIRCLE"))
             (progn
               (if (zerop chm) (progn
               (if (and (/= enm "LINE") (/= enm "ARC")) (setq ow (cdr (assoc 40 en)))
                   (setq ow 0))
                (princ "\n新线宽<")
                (princ (rtos (/ ow 1) 2 2))
                (setq nw (getreal "mm>:"))
                (if (null nw) (setq nw ow))
              ))
    (if (= enm "CIRCLE")
      (progn
        ;(setq angle1 (/ pi 2))
        (setq pt1 (polar (CDR(ASSOC 10 EN)) 0 (CDR(ASSOC 40 EN))))
        (setq pt2 (polar (CDR(ASSOC 10 EN)) pi (CDR(ASSOC 40 EN))))
        (command ".BREAK" pt1 pt2)
        (command "pedit" (ssname p l) "y" "w" nw "c" "")
             ))
    (if (or (= enm "LINE") (= enm "ARC"))
        (command "pedit" (ssname p l) "y" "w" nw "")
        
        (if (or(= enm "LWPOLYLINE") (= enm "POLYLINE"))
            (command "pedit" (ssname p l) "w" nw "")
        )  
      )
              (setq  chm (1+ chm))
          ))
          (setq l (1+ l))
        )
      ))
      (princ "改了") (princ chm) (princ "条线.")
      (PRINC)
)


;(command ".BREAK"
  ;       (cons e
  ;          (polar (socas 10) 0 (socas 40))
  ;        )
  ;       (polar (socas 10) 1e-3 (socas 40))

lhj743

非常不错！
可以修改字型、字高，
尤其修改线宽很方便快捷！不用象pe那样要转换成复合线这么个步骤，很容易把圆的线宽修改！

liuyj

好像前一阵有人贴过，一模一样。

liyalin

我是菜鸟，能不能做成现成的LISP文件，以供下载啊？谢谢。还要用说明知道用才行。

xingtian8

能否提供下载

橄榄滋味

提供下载干嘛，自己从一楼处复制不就成了

张世杰

提个小小的建议,楼主如果采用缩进式格式,就好看多了.