;;; - ------------------------------------------------------------------------------ - ;
;;; -                T O O L - T E X T T R A N S F E R                               - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Übertragung von Textinhalten von einem Textobjekt auf andere    - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Befehle            : TEXTTRANSFER                                              - ;
;;; - letzte Änderung am : 10.10.2022                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)
(defun C:TEXTTRANSFER(/ TEXT1 TEXT2 DATA1 DATA2 ESC  
                        TEXTCLONE DT:NENTSEL
                        DT:UNDOEND  DT:UNDOSTART
                     )
  (defun DT:UNDOEND()
    (while(= 8(logand 8 (getvar "undoctl")))
      (vla-endundomark (vla-get-activedocument(vlax-get-acad-object)))
    )      
  )
  (defun DT:UNDOSTART()
    (DT:UNDOEND)
    (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))
  )
  (defun TEXTTRANSFER( TEXT1 TEXT2
                     / TEXTSTRING TEXT1OBJNAME TEXT2OBJNAME OWNER BLOCKNAME BLOCK LISTE
                       DT:OBJEKT:GETOWNER PROPSTAKEOVER TEXTGETTEXTSTR)
    (defun DT:OBJEKT:GETOWNER(OBJ)
      (if(and(setq OBJ(cond
                        ((=(type OBJ)'ENAME)(vlax-ename->vla-object OBJ))
                        ((=(type OBJ)'VLA-OBJECT)OBJ)
                      )
             )      
             (setq OWNER
               (cond
                ((and(>(vl-string-search "x64"(getvar "PLATFORM"))0)
                     (vlax-method-applicable-p(vla-get-Document OBJ)"ObjectIdToObject32")
                     (vlax-property-available-p OBJ "ownerid32")
                 )
                  (vlax-invoke-method
                    (vla-get-Document OBJ)'ObjectIdToObject32(vla-get-ownerid32 OBJ)
                  )
                )                     
                ('T
                  (vlax-invoke-method
                    (vla-get-Document OBJ)'ObjectIdToObject(vla-get-ownerid OBJ)
                  )
                )
               )  
             )
         )
        OWNER
      )
    )
    (defun PROPSTAKEOVER ( MASTER SLAVE PROPS / RETURN PROPS_VALUE)
      (if(and(=(type MASTER) 'VLA-object)(=(type SLAVE) 'VLA-object)(=(type PROPS)'LIST))
        (progn
          (foreach PROP PROPS
            (and(or(=(type PROP)'STR)(=(type PROP)'SYM))
                   (vlax-property-available-p MASTER PROP   )
                   (vlax-property-available-p SLAVE  PROP 'T)
                   (not(vl-catch-all-error-p
                         (setq PROPS_VALUE(vl-catch-all-apply'vlax-get-property(list MASTER PROP)))
                       )  
                   )
                   (not(vl-catch-all-error-p                      
                         (vl-catch-all-apply
                           'vlax-put-property (list SLAVE PROP PROPS_VALUE)
                         ) 
                       )
                   )
            )
          )
          SLAVE
        ) 
      )  
    )
    (defun TEXTGETTEXTSTR (OBJEKT LISTED? / MTEXTSTR TEXTSTR DUMMY TEXTLIST)
      (if(and(setq OBJEKT(cond((=(type OBJEKT) 'VLA-object) OBJEKT)
                              ((=(type OBJEKT) 'Ename) (vlax-ename->vla-object OBJEKT))    
                         )
             )           
             (setq MTEXTSTR
               (cond
                 ((member(strcase(vla-get-objectname  OBJEKT))
                                '("ACDBTEXT" "ACDBMTEXT" "ACDBATTRIBUTE")
                  )
                    (vla-get-textstring OBJEKT)
                 )
                 ((=(strcase(vla-get-objectname  OBJEKT))"ACDBATTRIBUTEDEFINITION")
                    (if(or(and(setq OWNER(DT:OBJEKT:GETOWNER OBJEKT))
                              (vlax-property-available-p OWNER 'ISLAYOUT)
                              (=(vla-get-islayout OWNER):vlax-true)
                          )
                          (=(vla-get-constant OBJEKT):vlax-false)
                       )
                      (vla-get-tagstring  OBJEKT) 
                      (vla-get-textstring OBJEKT)
                    )  
                 ) 
               )
             )
         ) 
        (progn
          (setq TEXTSTR "")
          (while (/= MTEXTSTR "") 
            (cond 
              ((wcmatch (strcase (setq DUMMY (substr MTEXTSTR 1 2))) "\\[\\{}]") 
                (setq MTEXTSTR (substr MTEXTSTR 3) TEXTSTR  (strcat TEXTSTR DUMMY))
              )          
              ((wcmatch (substr MTEXTSTR 1 1) "[{}]")(setq MTEXTSTR(substr MTEXTSTR 2)))   
              ((wcmatch (strcase (substr MTEXTSTR 1 2)) "\\[LO`~]")(setq MTEXTSTR(substr MTEXTSTR 3))) 
              ((wcmatch (strcase (substr MTEXTSTR 1 2)) "\\[ACFHQTW]") 
                (setq MTEXTSTR (substr MTEXTSTR (+ 2 (vl-string-search ";" MTEXTSTR)))) 
              )          
              ((wcmatch (strcase (substr MTEXTSTR 1 2)) "\\P")
                (if LISTED?
                  (setq TEXTLIST (cons TEXTSTR TEXTLIST)TEXTSTR  "" MTEXTSTR (substr MTEXTSTR 3))
                  (if(or(= " " (substr TEXTSTR (strlen TEXTSTR)))(= " " (substr MTEXTSTR 3 1)))
                    (setq MTEXTSTR (substr MTEXTSTR 3))
                    (setq MTEXTSTR (substr MTEXTSTR 3) TEXTSTR (strcat TEXTSTR " "))
                  )  
                )
              )          
              ((wcmatch (strcase (substr MTEXTSTR 1 2)) "\\S") 
                (setq DUMMY   (substr MTEXTSTR 3 (- (vl-string-search ";" MTEXTSTR) 2)))
                (setq TEXTSTR (strcat TEXTSTR    (vl-string-translate "#^\\" "/^\\" DUMMY))) 
                (setq MTEXTSTR (substr MTEXTSTR (+ 4 (strlen DUMMY))))              
              )        
              ('T 
                (setq TEXTSTR (strcat TEXTSTR (substr MTEXTSTR 1 1))) 
                 (setq MTEXTSTR (substr MTEXTSTR 2))
              ) 
            ) 
          )
        )
      )      
      (if LISTED? (reverse(cons TEXTSTR TEXTLIST))TEXTSTR)
    )
    (if(and(setq TEXT1(cond
                        ((=(type TEXT1)'ENAME)(vlax-ename->vla-object TEXT1))
                        ((=(type TEXT1)'VLA-OBJECT) TEXT1)
                      )
           )         
           (setq TEXT2(cond
                        ((=(type TEXT2)'ENAME)(vlax-ename->vla-object TEXT2))
                        ((=(type TEXT2)'VLA-OBJECT) TEXT2)
                      )
           )
           (member(strcase(vla-get-objectname TEXT1))
                 '("ACDBATTRIBUTE" "ACDBTEXT" "ACDBMTEXT" "ACDBATTRIBUTEDEFINITION")
           )
           (setq TEXTSTRING(TEXTGETTEXTSTR TEXT1 'T))
           (setq TEXT1OBJNAME(strcase(vla-get-objectname TEXT1)))
           (setq TEXT2OBJNAME(strcase(vla-get-objectname TEXT2)))                         
           (cond
             ((and(= TEXT1OBJNAME TEXT2OBJNAME)(/= TEXT2OBJNAME "ACDBATTRIBUTEDEFINITION"))
                (not(vl-catch-all-error-p
                       (vl-catch-all-apply
                         'vla-put-Textstring(list TEXT2 (vla-get-textstring TEXT1))
                       )
                    )
                )
             ) 
             ((= TEXT2OBJNAME "ACDBTEXT")
                (not(vl-catch-all-error-p                      
                      (vl-catch-all-apply
                        'vla-put-Textstring(list TEXT2 (car TEXTSTRING))
                      )
                    )
                )
             )
             ((= TEXT2OBJNAME "ACDBATTRIBUTEDEFINITION")
                (if(and(setq OWNER(DT:OBJEKT:GETOWNER OBJEKT))
                       (vlax-property-available-p OWNER 'ISLAYOUT)
                       (=(vla-get-islayout OWNER):vlax-true)
                   )
                  (not(vl-catch-all-error-p
                        (vl-catch-all-apply
                          'vla-put-Tagstring(list TEXT2 (car TEXTSTRING))
                        )
                      )
                  )
                  (not(vl-catch-all-error-p                      
                        (vl-catch-all-apply
                          'vla-put-Textstring(list TEXT2 (car TEXTSTRING))
                        )
                      )
                  ) 
               )                         
             )
             ((= TEXT2OBJNAME  "ACDBMTEXT")
               (setq TEXT2(PROPSTAKEOVER TEXT1 TEXT2
                              '( MTextAttribute       MTextAttributeContent
                                 MTextBoundaryWidth   MTextDrawingDirection
                                 TextString
                               )
                          )
               )
               (not(vl-catch-all-error-p                      
                        (vl-catch-all-apply
                          'vla-put-Textstring(list TEXT2 (car TEXTSTRING))
                        )
                   )
               )
             ) 
             ((= TEXT2OBJNAME "ACDBATTRIBUTE")
                (if(and(vlax-property-available-p TEXT2 'MTextAttribute)
                       (=(vla-get-MTextAttribute TEXT2):vlax-true)
                   )    
                  (setq TEXT2(PROPSTAKEOVER TEXT1 TEXT2
                               '( MTextAttribute       MTextAttributeContent
                                  MTextBoundaryWidth   MTextDrawingDirection
                                  TextString
                                )
                             ) 
                  )
                  (not(vl-catch-all-error-p                      
                        (vl-catch-all-apply
                          'vla-put-Textstring(list TEXT2 (car TEXTSTRING))
                        )
                      )
                  )
                )           
                (and(not(vl-catch-all-error-p (setq OWNER(DT:OBJEKT:GETOWNER TEXT2))))
                    (=(type OWNER)'VLA-OBJECT)
                    (member(strcase (vla-get-ObjectName OWNER))'("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK"))
                    (not(vl-catch-all-apply 'vla-update (list (vlax-ename->vla-object X))))
                )        
           )
         )    
       )
      (progn
        (and(not(vl-catch-all-error-p (setq OWNER(DT:OBJEKT:GETOWNER TEXT2))))
            (=(type OWNER)'VLA-OBJECT)
            (=(strcase (vla-get-ObjectName OWNER))"ACDBBLOCKTABLERECORD")
            (=(vla-get-ISLAYOUT OWNER):vlax-false)
            (setq BLOCKNAME(vla-get-name OWNER))
            (setq BLOCK(tblobjname "BLOCK" BLOCKNAME))
            (setq LISTE(cdr (assoc 330 (entget BLOCK))))
            (setq LISTE(entget LISTE))
            (mapcar
               '(lambda(X)(vl-catch-all-apply 'vla-update (list (vlax-ename->vla-object X))))
                (mapcar 'cdr
                  (vl-remove-if-not
                    '(lambda(D)(and(=(car D) 331)(=(type(cdr D))'ENAME)))
                     (cdr(reverse(cdr(member(assoc 102 LISTE)LISTE))))
                  )
                )
            )
        )           
        TEXT2
      )  
    )  
  )
  (defun DT:NENTSEL(MSG / OBJ)
    (or(=(type MSG)'STR)(setq MSG""))    
    (if(not(vl-catch-all-error-p(setq OBJ(vl-catch-all-apply  'nentsel (list MSG)))))
      (cond ((=(type (car OBJ))'ENAME)(car OBJ))('T nil))
      "*ESC*"
    )   
  )
  (while(not ESC)
    (while(not(and(or(setq TEXT1(DT:NENTSEL "\nQuellTextObjekt wählen:"))
                     (initget "Ja Nein")
                     (setq ESC(/=(getkword"\nNichts gewählt. Abbruch? [Ja / Nein] <Ja>:")"Nein"))
                  )
                  (or ESC
                     (and(=(type TEXT1)'ENAME)
                         (setq DATA1(entget TEXT1))
                         (member(strcase(cdr(assoc 0 DATA1)))'("ATTRIB" "TEXT" "MTEXT" "ATTDEF"))
                     )
                     (and(setq ESC(and(=(type TEXT1)'STR)(= TEXT1 "*ESC*")))
                         (or(prompt "\nAbbruch durch Anwender .....")'T)
                     )    
                     (prompt "\nKein QuellTextObjekt gewählt ..... nochmal ..")
                  )                             
              )
          )
    )
    (if(not ESC)
      (while(not(and(or(setq TEXT2(DT:NENTSEL "\nZielTextObjekt wählen:"))
                       (initget "Ja Nein")
                       (setq ESC(/=(getkword"\nNichts gewählt. Abbruch? [Ja / Nein] <Ja>:")"Nein"))
                    )
                    (or ESC
                       (and(=(type TEXT2)'ENAME)
                           (setq DATA2(entget TEXT2))
                           (member(strcase(cdr(assoc 0 DATA2)))'("ATTRIB" "TEXT" "MTEXT" "ATTDEF"))
                       )
                       (and(setq ESC(and(=(type TEXT2)'STR)(= TEXT2 "*ESC*")))
                           (or(prompt "\nAbbruch durch Anwender.....")'T)
                       )    
                       (prompt "\nKein ZielTextObjekt gewählt ..... nochmal ..")
                    )                             
                )
            )
      )
    )  
    (if (not ESC)
      (progn
        (DT:UNDOEND)
        (DT:UNDOSTART)   
        (if(TEXTTRANSFER TEXT1 TEXT2)
          (prompt "\nTextinhalt übertragen.\n")
          (prompt "\nFehler beim Textinhalt übertragen.\n")
        )
        (DT:UNDOEND)
      )
    )
  )
  (princ)
)
;;; -------------------------------------------------------------------------------- - ;
(defun TEXTTRANSFER:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-TEXTTRANSFER: Übertragen des Textinhaltes von einem " 
      "\n================  Textobjekt auf ein anderes."         
      "\n(C) Thomas Krüger 2022  E-Mail: tk@cad-od.de"  
      "\nBefehlsaufruf : TEXTTRANSFER"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------ - ;
(TEXTTRANSFER:INFO)
(princ)
