带matchprops的文本副本乐筑天下 - Powered by Discuz! Archiver

Nobull84 发表于 2022-7-5 23:27:21

带matchprops的文本副本

大家好，

谁能告诉我怎么修改这个代码吗？它要求选择一个值，然后是应用一次还是多次。在多模式下，您仍然一次只能选择一个。我希望能够使用选择框一次应用于多个对象。

谢谢
-诺布尔

;;;;Realization {Smirnoff}
;;; TTCM - Text to Text copy whith Matchprop. Copy text from DIMENSION, TEXT,
;;;MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one
(defun c:tt (/ actDoc vlaObj sObj sText curObj oldForm
   oType oldMode conFlag errFlag *error* prop)
(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 "\nCan't paste to block's DText or MText. Select Attribute ")
(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 "\nError. Can't pase text. ")
(setq errFlag T)
); end progn
); end if
); end condition #4
(T
(princ "\nCan't paste. Invalid object. ")
(setq errFlag T)
); end condition #5
); end cond
(if (and (null errFlag)
         (= (type vlaObj) 'VLA-OBJECT))
(mapcar '(lambda (x y) (vlax-put-property vlaObj x y))
   '(Linetype LineWeight Color Layer)
   prop
   )
)
         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)) "\\")
(setq Mtext(substr Mtext 3))
); end condition #4
((wcmatch
(strcase
   (substr Mtext 1 2)) "\\")
(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 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
(setq prop (mapcar '(lambda (x)
         (vlax-get-property (vlax-ename->vla-object sObj)x))
'(Linetype LineWeight Color Layer)
      )
   )
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 TTCM")
(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 <" 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 TTCM")
(princ)
); end c:ttc
(princ "\n\t TTCM - Text to Text copy with matchprop.")
(princ "\nCopy text from DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one")

Lee Mac 发表于 2022-7-5 23:47:49

这是我的一个老程序，它可能会有所帮助：复制或交换文本

Nobull84 发表于 2022-7-6 00:10:40

感谢更新的lisp。老的还可以，但你的就行了。荣誉

再次感谢，
-诺布尔

Lee Mac 发表于 2022-7-6 00:20:57

不客气，这也是一个老程序，但我很高兴它仍然有用

Nobull84 发表于 2022-7-6 00:32:48

这个Lisp程序一直都很好，但有两个调整会让这个Lisp程序真的让我和可能的几个同事感到震惊。
1.有没有办法默认“多个”粘贴功能，或者选择单粘贴，或者根本不选择？我一直在使用它，这相当重要，似乎我从来没有这个需要一次。
2.我似乎不能用它来粘贴替代维度？有没有办法做到这一点？例如，有时我需要将维度替换为“E.O.S.”，并在其周围放置一个云。如果我能这样做一次，并能够复制/粘贴其余的将非常好。

谢谢
-诺布尔

页: [1]

乐筑天下's Archiver

带matchprops的文本副本