[编程交流] 请帮忙，Lisp本地化obj

(defun c:test ()
 (vl-load-com)
 ;;-------------------=={ UnFormat String }==------------------;;
 ;;                                                            ;;
 ;;  Returns a string with all MText formatting codes removed. ;;
 ;;------------------------------------------------------------;;
 ;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
 ;;------------------------------------------------------------;;
 ;;  Arguments:                                                ;;
 ;;  str - String to Process                                   ;;
 ;;  mtx - MText Flag (T if string is for use in MText)        ;;
 ;;------------------------------------------------------------;;
 ;;  Returns:  String with formatting codes removed            ;;
 ;;------------------------------------------------------------;;
 (defun LM:UnFormat (str mtx / _replace rx)
   (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
   (if        (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
     (progn (setq str (vl-catch-all-apply
                 (function
                   (lambda ()
                     (vlax-put-property rx 'global actrue)
                     (vlax-put-property rx 'multiline actrue)
                     (vlax-put-property rx 'ignorecase acfalse)
                     (foreach pair '(("\032" . "\\\\\\\")
                                     (" " . "\\\\P|\\n|\\t")
                                     ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
                                     ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
                                     ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
                                     ("$1" . "[\\\\]({)|{")
                                    )
                       (setq str (_replace (car pair) (cdr pair) str))
                     )
                     (if mtx
                       (_replace "\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
                       (_replace "\" "\032" str)
                     )
                   )
                 )
               )
     )
     (vlax-release-object rx)
     (if (null (vl-catch-all-error-p str))
       str
     )
     )
   )
 )
 ;; Unique  -  Lee Mac
 ;; Returns a list with duplicate elements removed.
 (defun LM:Unique (l / x r)
   (while l
     (setq x (car l)
    l (vl-remove x (cdr l))
    r (cons x r)
     )
   )
   (reverse r)
 )
 ;;
 ;;
 ;; Source : http://www.theswamp.org/index.php?topic=10371.0
                                ;Union polylines
                                ;Stefan M. 09.01.2014
 (defun UNIP (lst / *error* i lst r1 reg ss sysvar prop)
   (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
   (setq ms (vlax-get acDoc
               (if (= 1 (getvar 'cvport))
                 'paperspace
                 'modelspace
               )
     )
   )
   (vla-startundomark acDoc)
   (setq sysvar (mapcar 'getvar '(peditaccept draworderctl cmdecho)))
   (defun *error* (msg)
     (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*")) (princ (strcat "\nError: " msg)))
     (mapcar 'setvar '(peditaccept draworderctl cmdecho) sysvar)
     (vla-endundomark acDoc)
     (princ)
   )
   (foreach x lst (vla-put-closed x :vlax-true))
   (setq prop (mapcar '(lambda (p) (vlax-get (car lst) p)) '(Layer LineType Color)))
   (setq reg (vlax-invoke ms 'AddRegion lst))
   (foreach x lst
     (if (not (vlax-erased-p x))
(vla-delete x)
     )
   )
   (setq r1 (car reg))
   (foreach x (cdr reg) (vlax-invoke r1 'boolean acunion x))
   (mapcar '(lambda (p v) (vlax-put r1 p v)) '(Layer LineType Color) prop)
   (setq lst (apply 'append
             (mapcar '(lambda (a)
                        (if (listp a)
                          (mapcar 'vlax-vla-object->ename a)
                          (list (vlax-vla-object->ename a))
                        )
                      )
                     (mapcar '(lambda (e / p)
                                (if (eq (vla-get-objectname e) "AcDbRegion")
                                  (progn (setq p (vlax-invoke e 'explode)) (vla-delete e) p)
                                  e
                                )
                              )
                             (vlax-invoke r1 'explode)
                     )
             )
      )
   )
   (vla-delete r1)
   (setq ss (ssadd))
   (foreach x lst (ssadd x ss))
   (mapcar 'setvar '(peditaccept draworderctl cmdecho) '(1 0 0))
   (command "_pedit" "_m" ss "" "_j" "" "")
   (*error* nil)
   (princ)
 )
 ;;
 ;; ==========================
 ;; ACTUAL PROGRAM STARTS HERE
 ;; ==========================
 ;;
 (setvar "cmdecho" 0)
 (setq oldsnapmode (getvar "snapmode"))
 (setq oldosmode (getvar "osmode"))
 (setq oldlayer (getvar "clayer"))
 (setq oldorthomode (getvar "orthomode"))
 (setvar "snapmode" 0)
 (setvar "osmode" 0)
 (setvar "orthomode" 0)
 (setq sset (ssget "_:L" '((0 . "*TEXT"))))
 (setq textlist nil)
 (setq textstrlist nil)
 (repeat (setq n (sslength sset))
   (setq ent (ssname sset (setq n (1- n))))
   (setq obj (vlax-ename->vla-object ent))
   (setq txtstring (strcat (LM:UnFormat (vla-get-textstring obj) nil)))
   (setq textlist (cons (list ent txtstring) textlist))
   (setq textstrlist (cons txtstring textstrlist))
 )
 (setq uniqtextlist (LM:Unique textstrlist))
 (setq finallist nil)
 (foreach xx uniqtextlist
   (setq templist nil)
   (foreach yy        textlist
     (if (equal xx (cadr yy))
(progn (setq templist (cons (car yy) templist)))
     )
   )
   (setq finallist (cons (list xx templist) finallist))
 )
 (setq cnt 1)
 (foreach xx finallist
   (setq lyrname (strcat "LYR-" (car xx)))
   (if        (not (tblsearch "LAYER" lyrname))
     (command "_.-layer" "M" lyrname "C" cnt "" "L" "Continuous" "" "LW" 0.25 "" "")
   )
   (setq cnt (1+ cnt))
   (setq entlist (cadr xx))
   (setvar 'clayer lyrname)
   (setq joinlist nil)
   (foreach yy        entlist
     (setq obj (vlax-ename->vla-object yy))
     (setq inspt (vlax-safearray->list (vlax-variant-value (vla-get-textalignmentpoint obj))))
     (command "-boundary" inspt "")
     (setq joinlist (cons (vlax-ename->vla-object (entlast)) joinlist))
   )
   (UNIP joinlist)
 )
 (setvar "snapmode" oldsnapmode)
 (setvar "orthomode" oldorthomode)
 (setvar "osmode" oldosmode)
 (if (tblsearch "LAYER" oldlayer)
   (setvar "clayer" oldlayer)
 )
 (princ)
)