合并字体

eachy · 发表于 2013-7-13 02:27:05

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

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

×

[sell]

(vl-load-com)
(if (>= (atof (getvar "acadver")) 16.0)
(vl-arx-import "acapp.arx")
(vl-arx-import "acadapp.arx")
)
(defun c:msty (/ ea:table ea:flist ea:getsfont
ea:getdmstyle ea:pross ea:getutime
ea:string_parse ea:string_unparse
ea:command ea:transty ea:get-utime myerr
ea:clearcset thisdrawing olderr nullss
what_next _eamegstyle_id nsty
stlst dmlst sname dname
d_f dname_textstyle sname_fnt
a dmode cfnt del
dl efnt l n
nsty olderr sel sln
x $_tch_loaded ea:unlockall *acad*
)
(defun ea:table (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
(acad_strlsort (reverse r))
)
(defun ea:flist (key lst def)
(start_list key)
(mapcar 'add_list lst)
(end_list)
(if def
(set_tile key def)
)
)
(defun ea:string_parse (str delimiter / post strlst)
(if str
(progn
(setq strlst '())
(while (vl-string-search delimiter str)
(setq post (vl-string-search delimiter str))
(setq strlst (append strlst (list (substr str 1 post))))
(setq str (substr str (+ post 2)))
)
(vl-remove "" (append strlst (list str)))
)
) ;_ end if
) ;_ end defun ea:string_pase
(defun ea:string_unparse (lst delimiter / return)
(setq return "")
(foreach str lst
(setq return (strcat return delimiter str))
)
(substr return 2)
)
;;一个在状态条显示处理进度的函数
;; k 数 l 长度
(defun Ea:pross (k l)
(grtext -2
(strcat "已完成"
(rtos (/ (* 100.0 k) l)
2
0
)
"%...."
)
)
)
(defun ea:get-utime ()
(* 86400 (getvar "tdusrtimer"))
)
(defun ea:clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset
(vl-catch-all-apply
'vla-item
(list
(vlax-get-property
thisdrawing
'selectionsets
)
"CURRENT"
)
)
)
)
)
(vlax-invoke cset 'delete)
)
)
(defun ea:getsfont ()
(mapcar '(lambda (x / sel efnt cfnt)
(setq sel (entget (tblobjname "style" x))
efnt (cdr (assoc 3 sel))
cfnt (cdr (assoc 4 sel))
)
(if (vl-string-search ".SHX" (strcase efnt))
(setq efnt (substr efnt 1 (- (strlen efnt) 4)))
)
(if (vl-string-search ".SHX" (strcase cfnt))
(setq cfnt (substr cfnt 1 (- (strlen cfnt) 4)))
)
(if (/= cfnt "")
(strcat x "[" efnt "," cfnt "]")
(strcat x "[" efnt "]")
)
)
sname
)
)
(defun ea:getdmstyle ()
(mapcar '(lambda (x)
(list x
(cdr
(assoc
2
(entget
(cdr
(assoc
340
(entget
(tblobjname "dimstyle" x)
)
)
)
)
)
)
)
)
dname
)
)
(defun ea:command (mod)
(initdia)
(vl-cmdf (if mod
".style"
".ddim"
)
)
(while (/= (getvar "cmdnames") "") (command pause))
(setq sname (vl-remove "" (ea:table "style"))
dname (ea:table "dimstyle")
)
)
(defun ea:chksel (lst / tmp tf sl sln ttf)
(setq tmp (mapcar 'cadr d_f)
tf t
)
(setq sl (mapcar 'read (ea:string_parse lst " "))
sln (vl-remove nsty (mapcar '(lambda (x) (nth x sname)) sl))
)
(while (and tf tmp)
(setq ttf (vl-position (car tmp) sln))
(setq tmp (cdr tmp))
(if ttf
(setq tf nil)
)
)
ttf
)
(defun ea:unlock_all ()
(vla-eval *Acad*
"For Each lyr In Thisdrawing.layers:lyr.lock=false:Next"
)
)
(defun ea:transty (/ ea:chg_blockatt_style
ea:update_dimension a del
dl filter sl sln
x cset upbn ss
ssl n l t0
t1 $dim_in_block
)
(defun ea:chg_blockatt_style (obj)
(mapcar
'(lambda (a)
(if (vl-position (vla-get-stylename a) sln)
(vla-put-stylename a nsty)
)
)
(safearray-value (variant-value (vla-getattributes obj)))
)
)
(defun ea:update_dimension ()
(if $dim_in_block
(vla-regen thisdrawing acActiveViewport)
(progn
(ssget "x" '((0 . "Dimension")))
(vla-eval
*acad*
"For Each Obj In Thisdrawing.Activeselectionset:Obj.update:Next"
)
)
)
)
(defun ea:chg_object_style (obj)
(cond
((and (vlax-property-available-p obj 'stylename T)
(vl-position (vlax-get-property obj 'stylename) sln)
)
(vlax-put-property obj 'stylename nsty)
)
((vlax-property-available-p obj 'hasattributes)
(ea:chg_blockatt_style obj)
)
($_tch_loaded
(cond
((and (vlax-property-available-p obj 'textstyle T) ;_ dim特性
(vl-position (vlax-get-property obj 'textstyle) sln)
)
(vla-put-textstyle obj nsty)
)
((and (vlax-property-available-p obj 'fontstyle T)
(vl-position (vlax-get-property obj 'fontstyle) sln)
)
(vlax-put-property obj 'fontstyle nsty)
)
(t)
)
)
(t)
)
)
(cond
((and (/= stlst "") (/= stlst nil)) ;_ 转换字体或字体及标注样式
(setq t0 (ea:get-utime))
(ea:unlock_all)
(setq sl (mapcar 'read (ea:string_parse stlst " "))
sln (vl-remove nsty (mapcar '(lambda (x) (nth x sname)) sl))
filter (ea:string_unparse sln ",")
)
(if (and (/= dmlst "") (/= dmlst nil))
(setq dl (mapcar 'read (ea:string_parse dmlst " ")))
)
(setvar "textstyle" nsty)
(setq l (- (vla-get-count (vla-get-blocks thisdrawing)) 2)
n 1
)
(ea:clearcset)
;;修改 text mtext 属性
(if (ssget "x"
(list '(-4 . "<or")
(cons 7 filter)
'(-4 . "<and")
'(0 . "insert")
'(66 . 1)
'(-4 . "and>")
'(-4 . "or>")
)
)
(progn
(setq l (+ (vla-get-count
(setq cset (vlax-get-property
thisdrawing
'activeselectionset
)
)
)
l
)
)
(vlax-for obj (vla-get-activeselectionset thisdrawing)
(ea:pross n l)
(ea:chg_object_style obj)
(setq n (1+ n))
) ;_ end vlax-map-collection
)
) ;_ end if
;;修改块定义
(if (zerop l)
(setq l 1)
)
(vlax-map-collection
(vlax-get-property thisdrawing 'blocks)
'(lambda (b / bn mark)
(ea:pross n l)
(setq bn (strcase (vla-get-name b))
mark t
)
(if (not (wcmatch bn "`**_SPAC*"))
(vlax-map-collection
b
'(lambda (n / bbn)
(ea:chg_object_style n)
(if
(and mark
(wcmatch (setq bbn (vla-get-objectname n))
"*Block*"
)
)
(progn
(if (= (substr bn 1 1) "*")
(setq bbn (strcat "`" bn))
)
(if (not upbn)
(setq upbn (list bbn))
(if (not (vl-position bbn upbn))
(setq upbn (append (list bbn) upbn))
)
)
(setq mark nil)
)
)
(if (wcmatch (vla-get-objectname n) "*Dim*")
(setq $dim_in_block t)
)
)
)
) ;_ end cond
(setq n (1+ n))
) ;_ end lambda
) ;_ end vlax-map-collection
;;修改 dimstyle
(if (= dmode "0")
(progn
(if dl
(setq l (+ l (length dl)))
(setq l (+ l (length d_f)))
)
(mapcar
'(lambda (x / del)
(setq
del (entget (tblobjname
"dimstyle"
(if dl
(nth x dname)
(car x)
)
)
)
)
(if (or dl (and (not dl) (vl-position (cadr x) sln)))
(progn
(ea:pross n l)
(entmod (subst (cons 340 (tblobjname "Style" nsty))
(assoc 340 del)
del
)
)
(setq n (1+ n))
)
)
)
(if dl
dl
d_f
)
)
(if (vl-position (getvar "dimtxsty") sln)
(progn
(setvar "dimtxsty" nsty)
(vla-put-activedimstyle
thisdrawing
(vla-item (vla-get-dimstyles thisdrawing)
(getvar "dimstyle")
)
)
(ea:unlock_all)
(ea:update_dimension)
)
)
)
(if
(ssget "x"
(append '((-4 . "<and") (0 . "insert") (-4 . "<or"))
(mapcar '(lambda (x) (cons 2 x)) upba)
'((-4 . "or>") (-4 . "and>"))
)
)
(vla-eval
*acad*
"For Each Obj In Thisdrawing.ActiveSelectionset:Obj.Update:Next"
)
)
)
(mapcar '(lambda (x)
(vl-catch-all-apply
'vla-delete
(list (vla-item (vla-get-textstyles thisdrawing) x))
)
)
sln
)
(setq sname (vl-remove "" (ea:table "style"))
dname (ea:table "dimstyle")
)
)
((and (/= dmlst nil) (/= dmlst "")) ;_ 仅转换标注样式字体
(setq t0 (ea:get-utime))
(setq dl (mapcar 'read (ea:string_parse dmlst " ")))
(mapcar
'(lambda (x / del)
(setq
del (entget (tblobjname
"dimstyle"
(nth x dname)
)
)
)
(entmod (subst (cons 340 (tblobjname "Style" nsty))
(assoc 340 del)
del
)
)
)
dl
) ;_ end mapcar
(if
(and (vl-position (vl-position (getvar "dimstyle") dname) dl)
(/= (getvar "dimtxsty") nsty)
)
(progn
(setvar "dimtxsty" nsty)
(vla-put-activedimstyle
thisdrawing
(vla-item (vla-get-dimstyles thisdrawing)
(getvar "dimstyle")
)
)
)
)
(ea:update_dimension)
)
(t)
) ;_ end cond
(if t0
(progn
(setq t1 (ea:get-utime))
(princ
(strcat "\n成功转换至 " nsty " 字体, 耗时(secs): ")
)
(princ (- t1 t0))
)
)
) ;_ end defun
;;主程序
(setq *acad* (vlax-get-acad-object)
thisdrawing (vla-get-activedocument *acad*)
$_tch_loaded (vl-position "tch_initstart.arx" (arx))
)
(vla-startundomark thisdrawing)
(vl-catch-all-apply
'(lambda ()
(if (setq nullss (ssget "x" '((0 . "*text") (1 . ""))))
(vl-cmdf ".erase" nullss "")
)
(if (not _eamegstyle_id)
(setq _eamegstyle_id (load_dialog "ea_megstyle.dcl"))
)
(setq what_next 2)
(while (>= what_next 2)
(if (not sname)
(setq sname (vl-remove "" (ea:table "style")))
)
(setq sname_fnt (ea:getsfont))
(if (not dname)
(setq dname (ea:table "dimstyle"))
)
(setq d_f (ea:getdmstyle))
(setq dname_textstyle
(mapcar '(lambda (x)
(strcat (car x) "[" (cadr x) "]")
)
d_f
)
)
(if (not (new_dialog "ea_megstyle" _eamegstyle_id))
(exit)
)
(ea:flist "sty" sname_fnt nil)
(ea:flist "dim" dname_textstyle nil)
(ea:flist "lst"
sname
(itoa (vl-position (getvar "textstyle") sname))
)
(mode_tile "dst" 1)
(action_tile
"trans"
(strcat
"(princ \"\n请稍候, 处理进行中....\")"
"(setq stlst (get_tile \"sty\"))"
"(setq dmlst (get_tile \"dim\"))"
"(setq nsty (nth (atoi (get_tile \"lst\")) sname))"
"(setq dmode (get_tile \"dst\"))"
"(done_dialog 4)"
)
)
(action_tile "accept" "(done_dialog 1)")
(action_tile "dim" "(if (= $reason 4)(done_dialog 5))")
(action_tile
"sty"
(strcat
"(if (ea:chksel $value)(mode_tile \"dst\" 0)(progn (if (= (get_tile \"dst\") \"0\")(set_tile \"dst\" \"1\")) (mode_tile \"dst\" 1)))"
"(if (= $reason 4)(done_dialog 6))"
)
)
(setq what_next (start_dialog))
(cond
((= what_next 4)
(ea:transty)
)
((= what_next 6)
(ea:command t)
)
((= what_next 5)
(ea:command nil)
)
(t)
)
) ;_end while
(unload_dialog _eamegstyle_id)
)
)
(vla-endundomark thisdrawing)
(princ)
)
(princ "\n字体合并, 命令: msty . Eachy[www.xdcad.net]")
(princ)

(vl-load-com) 
(if (>= (atof (getvar "acadver")) 16.0) 
  (vl-arx-import "acapp.arx") 
  (vl-arx-import "acadapp.arx") 
) 
(defun c:msty (/        ea:table     ea:flist     ea:getsfont 
           ea:getdmstyle         ea:pross     ea:getutime 
           ea:string_parse         ea:string_unparse 
           ea:command   ea:transty     ea:get-utime myerr 
           ea:clearcset thisdrawing     olderr          nullss 
           what_next    _eamegstyle_id          nsty 
           stlst        dmlst     sname          dname 
           d_f        dname_textstyle          sname_fnt 
           a        dmode     cfnt          del 
           dl        efnt     l          n 
           nsty        olderr     sel          sln 
           x        $_tch_loaded ea:unlockall *acad* 
          ) 
  (defun ea:table (s / d r) 
    (while (setq d (tblnext s (null d))) 
      (setq r (cons (cdr (assoc 2 d)) r)) 
    ) 
    (acad_strlsort (reverse r)) 
  ) 
  (defun ea:flist (key lst def) 
    (start_list key) 
    (mapcar 'add_list lst) 
    (end_list) 
    (if    def 
      (set_tile key def) 
    ) 
  ) 
  (defun ea:string_parse (str delimiter / post strlst) 
    (if    str 
      (progn 
    (setq strlst '()) 
    (while (vl-string-search delimiter str) 
      (setq post (vl-string-search delimiter str)) 
      (setq strlst (append strlst (list (substr str 1 post)))) 
      (setq str (substr str (+ post 2))) 
    ) 
    (vl-remove "" (append strlst (list str))) 
      ) 
    ) ;_ end if 
  ) ;_ end defun ea:string_pase 
  (defun ea:string_unparse (lst delimiter / return) 
    (setq return "") 
    (foreach str lst 
      (setq return (strcat return delimiter str)) 
    ) 
    (substr return 2) 
  ) 
  ;;一个在状态条显示处理进度的函数 
  ;; k 数 l 长度 
  (defun Ea:pross (k l) 
    (grtext -2 
        (strcat "已完成" 
            (rtos (/ (* 100.0 k) l) 
              2 
              0 
            ) 
            "%...." 
        ) 
    ) 
  ) 
  (defun ea:get-utime () 
    (* 86400 (getvar "tdusrtimer")) 
  ) 
  (defun ea:clearcset (/ cset) 
    (if    (not (vl-catch-all-error-p 
           (setq cset 
              (vl-catch-all-apply 
            'vla-item 
            (list 
              (vlax-get-property 
                thisdrawing 
                'selectionsets 
              ) 
              "CURRENT" 
            ) 
              ) 
           ) 
         ) 
    ) 
      (vlax-invoke cset 'delete) 
    ) 
  ) 
  (defun ea:getsfont () 
    (mapcar '(lambda (x / sel efnt cfnt) 
           (setq sel  (entget (tblobjname "style" x)) 
             efnt (cdr (assoc 3 sel)) 
             cfnt (cdr (assoc 4 sel)) 
           ) 
           (if (vl-string-search ".SHX" (strcase efnt)) 
         (setq efnt (substr efnt 1 (- (strlen efnt) 4))) 
           ) 
           (if (vl-string-search ".SHX" (strcase cfnt)) 
         (setq cfnt (substr cfnt 1 (- (strlen cfnt) 4))) 
           ) 
           (if (/= cfnt "") 
         (strcat x "[" efnt "," cfnt "]") 
         (strcat x "[" efnt "]") 
           ) 
         ) 
        sname 
    ) 
  ) 
  (defun ea:getdmstyle () 
    (mapcar '(lambda (x) 
           (list x 
             (cdr 
               (assoc 
             2 
             (entget 
               (cdr 
                 (assoc 
                   340 
                   (entget 
                 (tblobjname "dimstyle" x) 
                   ) 
                 ) 
               ) 
             ) 
               ) 
             ) 
 
           ) 
         ) 
        dname 
    ) 
  ) 
  (defun ea:command (mod) 
    (initdia) 
    (vl-cmdf (if mod 
           ".style" 
           ".ddim" 
         ) 
    ) 
    (while (/= (getvar "cmdnames") "") (command pause)) 
    (setq sname    (vl-remove "" (ea:table "style")) 
      dname    (ea:table "dimstyle") 
    ) 
  ) 
  (defun ea:chksel (lst / tmp tf sl sln ttf) 
    (setq tmp (mapcar 'cadr d_f) 
      tf  t 
    ) 
    (setq sl  (mapcar 'read (ea:string_parse lst " ")) 
      sln (vl-remove nsty (mapcar '(lambda (x) (nth x sname)) sl)) 
    ) 
    (while (and tf tmp) 
      (setq ttf (vl-position (car tmp) sln)) 
      (setq tmp (cdr tmp)) 
      (if ttf 
    (setq tf nil) 
      ) 
    ) 
    ttf 
  ) 
  (defun ea:unlock_all () 
    (vla-eval *Acad* 
          "For Each lyr In Thisdrawing.layers:lyr.lock=false:Next" 
    ) 
  ) 
  (defun ea:transty (/         ea:chg_blockatt_style 
             ea:update_dimension     a         del 
             dl         filter         sl         sln 
             x         cset         upbn     ss 
             ssl     n         l         t0 
             t1         $dim_in_block 
            ) 
    (defun ea:chg_blockatt_style (obj) 
      (mapcar 
    '(lambda (a) 
       (if (vl-position (vla-get-stylename a) sln) 
         (vla-put-stylename a nsty) 
       ) 
     ) 
    (safearray-value (variant-value (vla-getattributes obj))) 
      ) 
    ) 
    (defun ea:update_dimension () 
      (if $dim_in_block 
    (vla-regen thisdrawing acActiveViewport) 
    (progn 
      (ssget "x" '((0 . "Dimension"))) 
      (vla-eval 
        *acad* 
        "For Each Obj In Thisdrawing.Activeselectionset:Obj.update:Next" 
      ) 
    ) 
      ) 
    ) 
    (defun ea:chg_object_style (obj) 
      (cond 
    ((and (vlax-property-available-p obj 'stylename T) 
          (vl-position (vlax-get-property obj 'stylename) sln) 
     ) 
     (vlax-put-property obj 'stylename nsty) 
    ) 
    ((vlax-property-available-p obj 'hasattributes) 
     (ea:chg_blockatt_style obj) 
    ) 
    ($_tch_loaded 
     (cond 
       ((and (vlax-property-available-p obj 'textstyle T) ;_ dim特性 
         (vl-position (vlax-get-property obj 'textstyle) sln) 
        ) 
        (vla-put-textstyle obj nsty) 
       ) 
       ((and (vlax-property-available-p obj 'fontstyle T) 
         (vl-position (vlax-get-property obj 'fontstyle) sln) 
        ) 
        (vlax-put-property obj 'fontstyle nsty) 
       ) 
       (t) 
     ) 
    ) 
    (t) 
      ) 
    ) 
    (cond 
      ((and (/= stlst "") (/= stlst nil)) ;_ 转换字体或字体及标注样式 
       (setq t0 (ea:get-utime)) 
       (ea:unlock_all) 
       (setq sl        (mapcar 'read (ea:string_parse stlst " ")) 
         sln    (vl-remove nsty (mapcar '(lambda (x) (nth x sname)) sl)) 
         filter (ea:string_unparse sln ",") 
       ) 
       (if (and (/= dmlst "") (/= dmlst nil)) 
     (setq dl (mapcar 'read (ea:string_parse dmlst " "))) 
       ) 
       (setvar "textstyle" nsty) 
       (setq l (- (vla-get-count (vla-get-blocks thisdrawing)) 2) 
         n 1 
       ) 
       (ea:clearcset) 
       ;;修改 text mtext 属性 
       (if (ssget "x" 
          (list    '(-4 . "<or") 
            (cons 7 filter) 
            '(-4 . "<and") 
            '(0 . "insert") 
            '(66 . 1) 
            '(-4 . "and>") 
            '(-4 . "or>") 
          ) 
       ) 
     (progn 
       (setq l (+ (vla-get-count 
            (setq cset (vlax-get-property 
                     thisdrawing 
                     'activeselectionset 
                   ) 
            ) 
              ) 
              l 
           ) 
       ) 
       (vlax-for obj (vla-get-activeselectionset thisdrawing) 
         (ea:pross n l) 
         (ea:chg_object_style obj) 
         (setq n (1+ n)) 
       ) ;_ end vlax-map-collection 
     ) 
       ) ;_ end if 
       ;;修改块定义 
       (if (zerop l) 
     (setq l 1) 
       ) 
       (vlax-map-collection 
     (vlax-get-property thisdrawing 'blocks) 
     '(lambda (b / bn mark) 
        (ea:pross n l) 
        (setq bn   (strcase (vla-get-name b)) 
          mark t 
        ) 
        (if    (not (wcmatch bn "`**_SPAC*")) 
          (vlax-map-collection 
        b 
        '(lambda (n / bbn) 
           (ea:chg_object_style n) 
           (if 
             (and mark 
              (wcmatch (setq bbn (vla-get-objectname n)) 
                   "*Block*" 
              ) 
             ) 
              (progn 
            (if (= (substr bn 1 1) "*") 
              (setq bbn (strcat "`" bn)) 
            ) 
            (if (not upbn) 
              (setq upbn (list bbn)) 
              (if (not (vl-position bbn upbn)) 
                (setq upbn (append (list bbn) upbn)) 
              ) 
            ) 
            (setq mark nil) 
              ) 
           ) 
           (if (wcmatch (vla-get-objectname n) "*Dim*") 
             (setq $dim_in_block t) 
           ) 
         ) 
          ) 
        ) ;_ end cond 
        (setq n (1+ n)) 
      ) ;_ end lambda 
       ) ;_ end vlax-map-collection       
       ;;修改 dimstyle       
       (if (= dmode "0") 
     (progn 
       (if dl 
         (setq l (+ l (length dl))) 
         (setq l (+ l (length d_f))) 
       ) 
       (mapcar 
         '(lambda (x / del) 
        (setq 
          del (entget (tblobjname 
                "dimstyle" 
                (if dl 
                  (nth x dname) 
                  (car x) 
                ) 
                  ) 
              ) 
        ) 
        (if (or dl (and (not dl) (vl-position (cadr x) sln))) 
          (progn 
            (ea:pross n l) 
            (entmod (subst (cons 340 (tblobjname "Style" nsty)) 
                   (assoc 340 del) 
                   del 
                ) 
            ) 
            (setq n (1+ n)) 
          ) 
        ) 
          ) 
         (if dl 
           dl 
           d_f 
         ) 
       ) 
       (if (vl-position (getvar "dimtxsty") sln) 
         (progn 
           (setvar "dimtxsty" nsty) 
           (vla-put-activedimstyle 
         thisdrawing 
         (vla-item (vla-get-dimstyles thisdrawing) 
               (getvar "dimstyle") 
         ) 
           ) 
           (ea:unlock_all) 
           (ea:update_dimension) 
         ) 
       ) 
     ) 
     (if 
       (ssget "x" 
          (append '((-4 . "<and") (0 . "insert") (-4 . "<or")) 
              (mapcar '(lambda (x) (cons 2 x)) upba) 
              '((-4 . "or>") (-4 . "and>")) 
          ) 
       ) 
        (vla-eval 
          *acad* 
          "For Each Obj In Thisdrawing.ActiveSelectionset:Obj.Update:Next" 
        ) 
     ) 
       ) 
       (mapcar '(lambda    (x) 
          (vl-catch-all-apply 
            'vla-delete 
            (list (vla-item (vla-get-textstyles thisdrawing) x)) 
          ) 
        ) 
           sln 
       ) 
       (setq sname (vl-remove "" (ea:table "style")) 
         dname (ea:table "dimstyle") 
       ) 
      ) 
      ((and (/= dmlst nil) (/= dmlst "")) ;_ 仅转换标注样式字体 
       (setq t0 (ea:get-utime)) 
       (setq dl (mapcar 'read (ea:string_parse dmlst " "))) 
       (mapcar 
     '(lambda (x / del) 
        (setq 
          del (entget (tblobjname 
                "dimstyle" 
                (nth x dname) 
              ) 
          ) 
        ) 
        (entmod (subst (cons 340 (tblobjname "Style" nsty)) 
               (assoc 340 del) 
               del 
            ) 
        ) 
      ) 
     dl 
       ) ;_ end mapcar 
       (if 
     (and (vl-position (vl-position (getvar "dimstyle") dname) dl) 
          (/= (getvar "dimtxsty") nsty) 
     ) 
      (progn 
        (setvar "dimtxsty" nsty) 
        (vla-put-activedimstyle 
          thisdrawing 
          (vla-item    (vla-get-dimstyles thisdrawing) 
            (getvar "dimstyle") 
          ) 
        ) 
      ) 
       ) 
       (ea:update_dimension) 
      ) 
      (t) 
    ) ;_ end cond 
    (if    t0 
      (progn 
    (setq t1 (ea:get-utime)) 
    (princ 
      (strcat "\n成功转换至 " nsty " 字体,  耗时(secs): ") 
    ) 
    (princ (- t1 t0)) 
      ) 
    ) 
  ) ;_ end defun 
  ;;主程序 
  (setq    *acad*         (vlax-get-acad-object) 
    thisdrawing  (vla-get-activedocument *acad*) 
    $_tch_loaded (vl-position "tch_initstart.arx" (arx)) 
  ) 
  (vla-startundomark thisdrawing) 
  (vl-catch-all-apply 
    '(lambda () 
       (if (setq nullss (ssget "x" '((0 . "*text") (1 . "")))) 
     (vl-cmdf ".erase" nullss "") 
       ) 
       (if (not _eamegstyle_id) 
     (setq _eamegstyle_id (load_dialog "ea_megstyle.dcl")) 
       ) 
       (setq what_next 2) 
       (while (>= what_next 2) 
     (if (not sname) 
       (setq sname (vl-remove "" (ea:table "style"))) 
     ) 
     (setq sname_fnt (ea:getsfont)) 
     (if (not dname) 
       (setq dname (ea:table "dimstyle")) 
     ) 
     (setq d_f (ea:getdmstyle)) 
     (setq dname_textstyle 
        (mapcar    '(lambda (x) 
               (strcat (car x) "[" (cadr x) "]") 
             ) 
            d_f 
        ) 
     ) 
     (if (not (new_dialog "ea_megstyle" _eamegstyle_id)) 
       (exit) 
     ) 
     (ea:flist "sty" sname_fnt nil) 
     (ea:flist "dim" dname_textstyle nil) 
     (ea:flist "lst" 
           sname 
           (itoa (vl-position (getvar "textstyle") sname)) 
     ) 
     (mode_tile "dst" 1) 
     (action_tile 
       "trans" 
       (strcat 
         "(princ \"\n请稍候, 处理进行中....\")" 
         "(setq stlst (get_tile \"sty\"))" 
         "(setq dmlst (get_tile \"dim\"))" 
         "(setq nsty (nth (atoi (get_tile \"lst\")) sname))" 
         "(setq dmode (get_tile \"dst\"))" 
         "(done_dialog 4)" 
        ) 
     ) 
     (action_tile "accept" "(done_dialog 1)") 
     (action_tile "dim" "(if (= $reason 4)(done_dialog 5))") 
     (action_tile 
       "sty" 
       (strcat 
         "(if (ea:chksel $value)(mode_tile \"dst\" 0)(progn (if (= (get_tile \"dst\") \"0\")(set_tile \"dst\" \"1\")) (mode_tile \"dst\" 1)))" 
         "(if (= $reason 4)(done_dialog 6))" 
       ) 
     ) 
     (setq what_next (start_dialog)) 
     (cond 
       ((= what_next 4) 
        (ea:transty) 
       ) 
       ((= what_next 6) 
        (ea:command t) 
       ) 
       ((= what_next 5) 
        (ea:command nil) 
       ) 
       (t) 
     ) 
       ) ;_end while 
       (unload_dialog _eamegstyle_id) 
     ) 
  ) 
  (vla-endundomark thisdrawing) 
  (princ) 
) 
(princ "\n字体合并, 命令: msty . Eachy[<a href=\"http://www.xdcad.net\" target=\"_blank\">www.xdcad.net</a>]") 
(princ)

[/sell]

eachy · 发表于 2013-7-13 02:30:25

配套DCL

ea_megstyle : dialog {
label = "字体管理 V61206 By Eachy";
: column {
alignment = centered;
: row {
: boxed_column {
label = "字体样式";
: list_box {
width = 30;
height = 12;
key = "sty";
multiple_select = true;
}
}
: boxed_column {
label = "标注样式";
: list_box {
width = 30;
height = 12;
key = "dim";
multiple_select = true;
}
}
}
: row {
alignment = centered;
fixed_width = true;
: toggle {
label = "忽略标注";
key = "dst";
value = "1";
}
: button {
label = "转换";
fixed_width = true;
key = "trans";
}
: popup_list {
width = 15;
key = "lst";
}
: button {
key = "accept";
label = "退出";
is_default = true;
}
}
}
}

ea_megstyle : dialog { 
  label = "字体管理 V61206 By Eachy"; 
  : column { 
    alignment = centered;   
  : row { 
    : boxed_column { 
      label = "字体样式"; 
      : list_box { 
        width = 30; 
        height = 12; 
        key = "sty"; 
        multiple_select = true; 
        } 
      } 
    : boxed_column { 
      label = "标注样式"; 
      : list_box { 
        width = 30; 
        height = 12; 
        key = "dim"; 
        multiple_select = true; 
        } 
      } 
    } 
  : row { 
    alignment = centered; 
    fixed_width = true; 
    : toggle { 
      label = "忽略标注"; 
      key = "dst"; 
      value = "1"; 
      } 
    : button { 
      label = "转换"; 
      fixed_width = true; 
      key = "trans"; 
      } 
    : popup_list { 
      width = 15; 
      key = "lst"; 
      } 
    : button { 
      key = "accept"; 
      label = "退出"; 
      is_default = true; 
      } 
    } 
  }         
}

userzhl · 发表于 2013-7-13 07:34:34

eachy 老师，就要顶。

daidong013 · 发表于 2013-7-13 08:18:33

地板一下，支持！顶

GTJ116600 · 发表于 2013-7-13 08:20:43

呵呵，恭喜eachy前辈又出精品

1993063 · 发表于 2013-7-13 08:27:28

eachy 老师，就要顶。

display18 · 发表于 2013-7-13 08:41:58

支持楼主，支持新作品

myfrankie · 发表于 2013-7-13 08:56:08

如何使用。保存文件名是什么

q3_2006 · 发表于 2013-7-13 10:09:04

很好用，谢谢分享！

yzr2002626 · 发表于 2013-7-13 11:14:28

支持eachy，谢谢分享！

十月 · 发表于 2013-7-13 11:37:11

真的非常好用

myfrankie · 发表于 2013-7-13 11:43:21

复制后保存名是什么？求解

haibinpro · 发表于 2013-7-13 11:57:12

10豆豆啊，放个录像看看嘛。

429014673 · 发表于 2013-7-13 12:56:37

你好版早期还有一个图层合并，希望也共享出来贡献论坛啦

yfph2918 · 发表于 2013-7-13 13:23:53

10D豆啊，，，

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

[原创] 合并字体

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

评分

点评