导出文本
这里是另一个从旧论坛上弹出的晦涩中拯救出来的宝石。您希望从图形中输出文本。用这一点
AutoLISP应用程序。该应用程序将帮助您
达到理想的结果
(defun c:txtex (/ et)
(setq fl (open "dtext.txt" "w")
et (entnext)
)
(while et
(setq el (entget et)
tp (cdr (assoc 0 el))
)
(if (or (= tp "TEXT") (= tp "MTEXT"))
(write-line (cdr (assoc 1 el)) fl)
)
(setq et (entnext et))
)
(close fl)
)
将程序复制到记事本中打开的文件中。然后
将其保存为TXTEX。LSP。下一次加载
AutoCAD并运行它。
要运行程序，请在命令处键入TXTEX
促使这就是全部。创建的文本文件包含
在图纸中找到的所有文本。
您可以将文本文件插入Microsoft Excel或
Microsoft Word。我相信你知道怎么做。
否则请回到我身边。
等一下。你说的是100幅画
文本你想一次完成吗？如果是这样，我们必须
对程序进行一些修改。
您还需要一个脚本文件。脚本文件运行并
启动程序。每次创建文本文件时。
让我知道你想要什么。
Jos van Doorn。AutoCAD专家和AutoLISP
程序员同时出版ACAD时事通讯。免费。到
订阅发送空白电子邮件至：
acadnewsletter公司-subscribe@topica.com 不错的节目。文本按创建顺序放置在文本文件中，忽略屏幕位置。如果您希望控制订单，或者当您不�如果不需要从DWG中导出所有文本，可以尝试以下程序。您可能需要使用其他应用程序编辑文本文件。
重要提示：您选择的（M）文本将被删除，因此请操作DWG文件的副本！
(defun C:TEX()
;move selected text to file
(alert "I hope you have a copy of your DWG!")
(setq userfile (open "test13.txt" "w"));You
;may change the name of the text file
(setq txt (entsel "select (m)text"))
(while txt
(setq e (entget (car txt)))
(setq x nil line "")
(setq x (member (assoc 3 e) e))
(while x
(setq line (cdr (assoc 3 x)))
(write-line line userfile)
(setq x (cdr x))
(setq x (member (assoc 3 x) x)))
(setq line (cdr (assoc 1 e)))
(write-line line userfile)
(command "erase" txt "")
(setq txt(entsel "\nnext (m)text (Enter for terminate)")))
(close userfile))
(defun c:txtex (/ et)
(setq fl (open "dtext.txt" "w")
et (entnext)
)
(while et
(setq el (entget et)
tp (cdr (assoc 0 el))
)
(if (or (= tp "TEXT") (= tp "MTEXT"))
(write-line (cdr (assoc 1 el)) fl)
)
(setq et (entnext et))
)
(close fl)
)
我用这个lisp，它过去很管用。
但现在，当我运行它时，当我打开dtext时。txt文件它是空的。
什么会导致这种情况发生？
可爱的小节目，干杯！
有没有办法指定程序将在其上操作的层或使其仅在当前层上操作？ 试试这个：
(defun c:txtex (/ file,en,entity,current_layer,entity_layer)
(setq file (open "dtext.txt" "w")
en (entnext)
)
(setq current_layer (getvar 'clayer))
(while en
(setq entity (entget en)
text (cdr (assoc 0 entity))
entity_layer (cdr (assoc 8 entity))
)
(if (and (or (= text "TEXT")
(= text "MTEXT")
)
(= entity_layer current_layer)
)
(write-line (cdr (assoc 1 entity)) file)
)
(setq en (entnext en))
)
(close file)
)
应适用于当前层
普尔泽莫 如果您使用的是Autocad 2002及更高版本，并且希望获得完整的多行文字字符串（不带格式），则可以尝试使用以下内容：
代码擦除'cos包含一些错误（thnx到ASMI）此代码工作正常（我希望）：
(defun c:text-exp (/ *error*
file selset
file_handle kpblc-string-mtext-unformat
_kpblc-string-replace_kpblc-string-cut-between
bylayer
)
(defun _kpblc-string-cut-between (str s1 s2 reg / tmp substring)
(setq tmp (if s1
(kpblc-string-find-substr-pass str s1 reg 0)
1
) ;_ end of if
substring (kpblc-string-find-substr-pass str s2 reg tmp)
) ;_ end of setq
(if (and (or s1 s2) tmp substring)
(substr
str
tmp
(if (and s2 tmp)
(1+ (- (kpblc-string-find-substr-pass str s2 reg tmp)
tmp
) ;_ end of -
) ;_ end of 1+
) ;_ end of if
) ;_ end of substr
""
) ;_ end of if
) ;_ end of defun
(defun *error* (msg)
(vl-catch-all-apply '(lambda () (close file_handle)))
(princ msg)
(princ)
) ;_ end of defun
(defun _kpblc-string-replace (string old_substr new_substr / pos)
(while (setq pos (vl-string-search old_substr string))
(setq string
(strcat
(substr string 1 pos)
new_substr
(_kpblc-string-replace
(substr string (+ (strlen old_substr) pos 1))
old_substr
new_substr
) ;_ end of _kpblc-string-replace
) ;_ end of strcat
) ;_ end of setq
) ;_ end of while
string
) ;_ end of defun
(defun kpblc-string-mtext-unformat (ent
/
_tmp
_substr
_mtext-str-extractor-clr
_mtext-str-extractor-srch
)
(defun _mtext-str-extractor-clr (str / _pos)
(if (setq _pos (_mtext-str-extractor-srch
str
'("{\\" "\\f" "\\F")
) ;_ end of _mtext-str-extractor-srch
) ;_ end of setq
(strcat
(if (> _pos 0)
(substr str 1 _pos)
""
) ;_ end of if
(_mtext-str-extractor-clr
(substr
str
(+ 2 (vl-string-search ";" str (1+ _pos)))
) ;_ end of substr
) ;_ end of _mtext-str-extractor-clr
) ;_ end of strcat
str
) ;_ end of if
) ;_ end of defun
(defun _mtext-str-extractor-srch (str lst / _tmp)
(car (vl-sort
(vl-remove-if
'not
(mapcar (function (lambda (_x _y)
(vl-string-search _y _x)
) ;_ end of lambda
) ;_ end of function
(repeat (length lst)
(setq _tmp (cons str _tmp))
) ;_ end of repeat
lst
) ;_ end of mapcar
) ;_ end of vl-remove-if
'<
) ;_ end of vl-sort
) ;_ end of car
) ;_ end of defun
(setq
_tmp (vl-string-subst
""
"}"
(_mtext-str-extractor-clr
(_kpblc-string-replace
(_kpblc-string-replace
(_kpblc-string-replace
(_kpblc-string-replace
(_kpblc-string-replace
(_kpblc-string-replace
ent
"\\\\"
""
) ;_ end of _kpblc-string-replace
"\\{"
(chr 1)
) ;_ end of _kpblc-string-replace
"\\}"
(chr 2)
) ;_ end of _kpblc-string-replace
"\\P"
"\n"
) ;_ end of _kpblc-string-replace
"\\L"
""
) ;_ end of _kpblc-string-replace
"\\l"
""
) ;_ end of _kpblc-string-replace
) ;_ end of _mtext-str-extractor-clr
) ;_ end of vl-string-subst
) ;_ end of setq
(while
(and (setq _substr (_kpblc-string-cut-between _tmp "\\" ";" nil))
(/= _substr "")
) ;_ end of and
(setq _tmp (vl-string-subst "" _substr _tmp))
) ;_ end of while
(vl-string-subst "}" (chr 2) (vl-string-subst "{" (chr 1) _tmp))
_tmp
) ;_ end of defun
(vl-load-com)
(if (and (setq file (getfiled "Enter a new export file name" "" "txt" 1))
(setq selset (ssget
(if (= (setq bylayer
((lambda ()
(initget "Yes No _ Y N")
(getkword
"\nSelect by current layer <No> : "
) ;_ end of getkword
) ;_ end of lambda
)
) ;_ end of setq
"Y"
) ;_ end of =
(list (cons 0 "*TEXT") (cons 8 (getvar "clayer")))
(list (cons 0 "*TEXT"))
) ;_ end of if
) ;_ end of ssget
) ;_ end of setq
) ;_ end of and
(progn
(setq file_handle (open file "w"))
(foreach item
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
) ;_ end of mapcar
(write-line
(vl-string-translate
"\n"
" "
(vl-string-translate "\\P" " " (vla-get-textstring item))
) ;_ end of VL-STRING-TRANSLATE
file_handle
) ;_ end of write-line
) ;_ end of foreach
(close file_handle)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun 这是一个有一些选项的快捷方式。
;;TextOut.lsp by CAB
;;Version 101/26/07
(defun c:TextOut()
(TextOutSub (+ 1 2 16) nil) ; get text & mText & Strip
(princ)
)
;;Dump text strings in drawing to a text file
;;Output File name -> <DWG filename> + "-OUT.TXT"
;;Flags to filter object Type
;;Layer Name nil = any layer
(defun TextOutSub(flag lname / fl ent)
(vl-load-com)
;;Flags
;;1Text
;;2MText
;;4Attributes
;;8Attribute Definition
;;16 Strip Text Format characters
;;32
;;lname if nil use any layer
;;++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;test ename, return objtype if correct type else nil
;;++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun is_text (ename / obj typ)
(if
(setq typ
(assoc
(vla-get-objectname (setq obj (vlax-ename->vla-object ename)))
'(("AcDbText" . 1) ("AcDbMText" . 2) ("AcDbAttribute" . 4) ("AcDbAttributeDefinition" . )
)
)
(cons obj (cdr typ))
)
)
(setq fname (strcat (getvar "dwgprefix")
(vl-filename-base (getvar "dwgname"))
"-OUT.TXT"
))
(setq fl (open fname "w"))
(if lname
(progn
(write-line (strcat "***Filtered by Layer " lname " ***") fl)
(setq lname (strcase lname))
)
)
(while (setq ent (if ent (entnext ent)(entnext)))
(if (and (setq source (is_text ent))
(> (logand (cdr source) flag) 0)
(or (null lname)
(= (strcase (vla-get-layer (car source))) lname)
))
(progn
(setq TextSource (vla-get-textstring (car source)))
(and (> (logand 16 flag) 0) (setq TextSource (strip_text TextSource)))
(write-line (strcat "\n<---->" (substr (vla-get-objectname (car source)) 5)
"\n" TextSource) fl)
)
)
)
(close fl)
(princ)
)
;;;=======================[ Strip_Text.lsp ]=============================
;;; Author:Charles Alan Butler Copyright© 2005
;;; Version: 2.2Oct. 19, 2005
;;; Purpose: Strip format characters from text or mtext
;;; Returns: A string
;;; Sub_Routines: -None
;;; Arguments: A string variable
;;;======================================================================
(defun strip_text (str / skipcnt ndx newlst char fmtcode lst_len
IS_MTEXT LSTNEXTCHR PT TMP)
(setq ndx 0
;; "fmtcode" is a list of code flags that will end with ;
fmtcode
(vl-string->list "CcFfHhTtQqWwAa") ;("\C" "\F" "\H" "\T" "\Q" "\W" "\A")
)
(if (/= str "") ; skip if empty text ""
(progn
(setq lst (vl-string->list str)
lst_len(length lst)
newlst '()
is_mtext nil ; true if mtext
)
(while (< ndx lst_len)
;; step through text and find FORMAT CHARACTERS
(setq char (nth ndx lst) ; Get next character
nextchr (nth (1+ ndx) lst)
skipcnt 0
)
(cond
((and (= char 123) (= nextchr 92)) ; "{\" mtext code
(setq is_mtext t
skipcnt 1
)
)
((and (= char 125) is_mtext) ; "}"
(setq skipcnt 1)
)
((= char 37) ; code start with "%"
(if (null nextchr) ; true if % is last char in text
(setq skipcnt 1)
;;Dtext codes
(if (= nextchr 37) ; %% code found
(if (< 47 (nth (+ ndx 2) lst) 58) ; is a number
;;number found so fmtcode %%nnn
(setq skipcnt 5)
;; else letter code, so fmtcode %%p, %%d, %%c
;;CAB note - this code does not always exist in the string
;;it is used to create the character but the actual ascii code
;;is used in the string, not the case for %%c
(setq skipcnt 3)
) ; endif
) ; endif
) ; endif
) ; end cond (= char "%"))
((= char 92) ; code start with "\"
;;This section processes mtext codes
(cond
;; Process Coded information
((null nextchr) ; true if \ is last char in text
(setq skipcnt 1)
) ; end cond 1
((member nextchr fmtcode) ; this code will end with ";"
;; fmtcode -> ("\C" "\F" "\H" "\T" "\Q" "\W" "\A"))
(while (/= (setq char (nth (+ skipcnt ndx) lst)) 59)
(setq skipcnt (1+ skipcnt))
)
(setq skipcnt (1+ skipcnt))
) ; end cond
;; found \U then get 7 character group
((= nextchr 85) (setq skipcnt (+ skipcnt 7)))
;; found \M then get 8 character group
((= nextchr 77) (setq skipcnt (+ skipcnt ))
;; found \P then replace with CR LF 13 10
;;debug do not add CR LF, just remobe \P
((= nextchr 80) ; "\P"
(setq newlst(append newlst '(32))
;ndx (+ ndx 1)
skipcnt 2
)
) ; end cond
((= nextchr 123) ; "\{" normal brace
(setq ndx (+ ndx 1))
) ; end cond
((= nextchr 125) ; "\}" normal brace
(setq ndx (+ ndx 1))
) ; end cond
((= nextchr 126) ; "\~" non breaking space
(setq newlst (append newlst '(32))) ; " "
(setq skipcnt 2) ; end cond 9
)
;; 2 character group \L \l \O \o
((member nextchr '(76 108 79 111))
(setq skipcnt 2)
) ; end cond
;;Stacked text format as "[ top_txt / bot_txt ]"
((= nextchr 83) ; "\S"
(setq pt(1+ ndx)
tmp '()
)
(while
(not
(member
(setq tmp (nth (setq pt (1+ pt)) lst))
'(94 47 35) ; "^" "/" "#" seperator
)
)
(setq newlst (append newlst (list tmp)))
)
(setq newlst (append newlst '(47))) ; "/"
(while (/= (setq tmp (nth (setq pt (1+ pt)) lst)) 59) ; ";"
(setq newlst (append newlst (list tmp)))
)
(setq ndx pt
skipcnt (1+ skipcnt)
)
) ; end cond
) ; end cond stmtProcess Coded information
) ; end cond(or (= char "\\")
) ; end cond stmt
;;Skip format code characters
(if (zerop skipcnt) ; add char to string
(setq newlst (append newlst (list char))
ndx (+ ndx 1)
)
;;else skip some charactersPLOTTABS
(setq ndx (+ ndx skipcnt))
)
) ; end while Loop
) ; end progn
) ; endif
(vl-list->string newlst) ; return the stripped string
) ; end defun
;;;====================================================================== 真 的。。。。。。感谢您的所有选择/支持。我会尝试一下，让大家都知道。
再次感谢，
3月5日 CAB-这也适用于属性吗？我试过了，但它似乎没有从图形中提取任何属性。我喜欢李的属性提取程序。我想知道是否有任何程序将两者结合起来。这将非常有用。谢谢
似乎有两种不同的Lisp程序。这是正确的吗？还有，李是谁？我看了看下面，我没有看到李Mac。很抱歉
马克
页:
[1]
2