Link to www.autocadtips.wordpress.com
There used to be a web site called ASMITOOLS.com where this particular LISP routine was posted. After the website went down, the author basically dumped all the routines in a forum as he decided to move on and let anyone use these LISP routines.
This routine is a great routine that lets you copy existing text objects (DTEXT, MTEXT & Attributes) to table cells.
Here’s how:
TTC <enter>
Specify whether you want to place text multiple time by choosing “Multiple” or “Pair-wise’ which will let you select a text object and then place it and then select another text object and place that object.
When placing the text objects one tip to help is that the table cell that receives the text object is determined by how much of the pick-box (cursor) is in the cell. You place your cursor over a line in the table and the more of the pick-box that is in a cell will determine which cell the text gets placed in. It’s a little tricky at first but you will get the hang of it…
;; ==================================================================== ;;
;; ;;
;; TTC.LSP - The program copies the text from: DText, MText, ;;
;; Tables, Dimensions, Attributes, Attributes, ;;
;; Attributes Definitions, DText, MText and inner ;;
;; block's DText and MText to: DText, MText, Tables, ;;
;; Attribures and Attributes Definitions. There are ;;
;; Multiple and Pair-wise modes. ;;
;; ;;
;; ==================================================================== ;;
;; ;;
;; Command(s) to call: TTC ;;
;; ;;
;; ==================================================================== ;;
;; ;;
;; THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY ;;
;; MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR ;;
;; PARTS OF IT ABSOLUTELY FREE. ;;
;; ;;
;; THIS PROGRAM PROVIDES 'AS IS' WITH ALL FAULTS AND SPECIFICALLY ;;
;; DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS ;;
;; FOR A PARTICULAR USE. ;;
;; ;;
;; ==================================================================== ;;
;; ;;
;; V1.3, 29 November, 2005, Riga, Latvia ;;
;; © Aleksandr Smirnov (ASMI) ;;
;; For AutoCAD 2000 - 2008 (isn't tested in a next versions) ;;
;; ;;
;; http://www.asmitools.com ;;
;; ;;
;; ==================================================================== ;;
(defun c:ttc (/ actDoc vlaObj sObj sText curObj oldForm
oType oldMode conFlag errFlag *error*)
(vl-load-com)
(setq actDoc(vla-get-ActiveDocument
(vlax-get-acad-object)))
(vla-StartUndoMark actDoc)
(defun TTC_Paste(pasteStr / nslLst vlaObj hitPt
hitRes Row Column)
(setq errFlag nil)
(if
(setq nslLst(nentsel "\nPaste text >"))
(progn
(cond
((and
(= 4(length nslLst))
(= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))
); end and
(setq vlaObj(vlax-ename->vla-object
(cdr(assoc -1(entget(car(last nslLst)))))))
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-TextOverride(list vlaObj pasteStr)))
(progn
(princ "\n<!> Can't paste. Object may be on locked layer <!> ")
(setq errFlag T)
); end progn
); end if
); end condition #1
((and
(= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
); end and
(setq vlaObj
(vlax-ename->vla-object
(cdr(assoc -1(entget(car(last nslLst))))))
hitPt(vlax-3D-Point(trans(cadr nslLst)1 0))
hitRes(vla-HitTest vlaObj hitPt
(vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Column)
); end setq
(if(= :vlax-true hitRes)
(progn
(if(vl-catch-all-error-p
(vl-catch-all-apply
'vla-SetText(list vlaObj Row Column pasteStr)))
(progn
(princ "\n<!> Can't paste. Object may be on locked layer <!> ")
(setq errFlag T)
); end progn
); end if
); end progn
); end if
); end condition # 2
((and
(= 4(length nslLst))
(= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))
); end and
(princ "\n<!> Can't paste to block's DText or MText <!> ")
(setq errFlag T)
); end condition #3
((and
(= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst))))
'("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
); end and
(setq vlaObj(vlax-ename->vla-object(car nslLst)))
(if(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-TextString(list vlaObj pasteStr)))
(progn
(princ "\n<!> Error. Can't pase text <!> ")
(setq errFlag T)
); end progn
); end if
); end condition #4
(T
(princ "\n<!> Can't paste. Invalid object <!> ")
(setq errFlag T)
); end condition #5
); end cond
T
); end progn
nil
); end if
); end of TTC_Paste
(defun TTC_MText_Clear(Mtext / Text Str)
(setq Text "")
(while(/= Mtext "")
(cond
((wcmatch(strcase
(setq Str
(substr Mtext 1 2)))"\\[\\{}`~]")
(setq Mtext(substr Mtext 3)
Text(strcat Text Str)
); end setq
); end condition #1
((wcmatch(substr Mtext 1 1) "[{}]")
(setq Mtext
(substr Mtext 2))
); end condition #2
((and
(wcmatch
(strcase
(substr Mtext 1 2)) "\\P")
(/=(substr Mtext 3 1) " ")
); end and
(setq Mtext (substr Mtext 3)
Text (strcat Text " ")
); end setq
); end condition #3
((wcmatch
(strcase
(substr Mtext 1 2)) "\\[LOP]")
(setq Mtext(substr Mtext 3))
); end condition #4
((wcmatch
(strcase
(substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext
(substr Mtext
(+ 2(vl-string-search ";" Mtext))))
); end condition #5
((wcmatch
(strcase (substr Mtext 1 2)) "\\S")
(setq Str(substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text(strcat Text (vl-string-translate "#^\\" " " Str))
Mtext(substr Mtext (+ 4 (strlen Str)))
); end setq
(print Str)
); end condition #6
(T(setq Text(strcat Text(substr Mtext 1 1))
Mtext (substr Mtext 2)
); end setq
); end condition #7
); end cond
); end while
Text
); end of TTC_MText_Clear
(defun TTC_Copy (/ sObj sText tType actDoc)
(if
(and
(setq sObj(car(nentsel "\nCopy text... ")))
(member(setq tType(cdr(assoc 0(entget sObj))))
'("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
); end and
(progn
(setq actDoc(vla-get-ActiveDocument
(vlax-get-Acad-object))
sText(vla-get-TextString
(vlax-ename->vla-object sObj))
); end setq
(if(= tType "MTEXT")
(setq sText(TTC_MText_Clear sText))
); end if
); end progn
); end if
sText
); end of TTC_Copy
(defun CCT_Str_Echo(paseStr / comStr)
(if(< 20(strlen paseStr))
(setq comStr
(strcat
(substr paseStr 1 17)"..."))
(setq comStr paseStr)
); end if
(princ(strcat "\nText = \"" comStr "\""))
(princ)
); end of CCT_Str_Echo
(defun *error*(msg)
(vla-EndUndoMark
(vla-get-ActiveDocument
(vlax-get-acad-object)))
(princ "\nQuit TTC")
(princ)
); end of *error*
(if(not ttc:Mode)(setq ttc:Mode "Multiple"))
(initget "Multiple Pair-wise")
(setq oldMode ttc:Mode
ttc:Mode(getkword
(strcat "\nSpecify mode [Multiple/Pair-wise] <"ttc:Mode">: "))
conFlag T
paseStr ""
); end setq
(if(null ttc:Mode)(setq ttc:Mode oldMode))
(if(= ttc:Mode "Multiple")
(progn
(if(and(setq paseStr(TTC_Copy))conFlag)
(progn
(CCT_Str_Echo paseStr)
(while(setq conFlag(TTC_Paste paseStr))T
); end while
); end progn
); end if
); end progn
(progn
(while(and conFlag paseStr)
(setq paseStr(TTC_Copy))
(if(and paseStr conFlag)
(progn
(CCT_Str_Echo paseStr)
(setq errFlag T)
(while errFlag
(setq conFlag(TTC_Paste paseStr))
);end while
); end progn
); end if
); end while
); end progn
); end if
(vla-EndUndoMark actDoc)
(princ "\nQuit TTC")
(princ)
); end c:ttc
(princ "\n[Info] http:\\\\www.AsmiTools.com [Info]")
(princ "\n[Info] Type TTC to run text to text copy tool [Info]")
AutoCAD Tips 