请帮忙，Lisp本地化obj
请帮助，Lisp本地化具有相同内容的对象！对不起，我英语不好！
khoanh ve Engli。图纸
像这样的http://www.cadtutor.net/forum/showthread.php?91084-Area-Statement-Under-Layer-quot-Acquired-No.-amp-Area quot到csv 否，所有文字ONT=>边界，所有文字CLN=>边界（或图案填充） 请附上您的图纸。 非常感谢。
khoanh ve Engli。图纸
(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" . "\\\\(\\\\)|\\\\[^\\\\;]*;|\\\\")
("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
("$1" . "[\\\\]({)|{")
)
(setq str (_replace (car pair) (cdr pair) str))
)
(if mtx
(_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\)|({)|(})" 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)
)
通过键入测试运行。 很好，但是怎么样？ 当我运行例程时，会根据您的需要创建两个边界，第一个用于所有ONT文本，第二个用于所有CLN文本。
例行公事中有什么问题？ 非常感谢。
我想要这样的东西：
2.dwg 请检查我在#6后修改的代码。
页:
[1]
2