;;; - ------------------------------------------------------------------------------ - ;
;;; -                T O O L - A C M - B L O C K D U P L I C A T E                   - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Blockdefinition duplizieren                                     - ;
;;; - Befehle      : BLOCKDUPLICATE ,  BLOCKDUPLICATECOPY                            - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 15.05.2023                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)

(defun DT:BLOCKDUPLICATE(BLOCK NEWNAME / DT:GETDBX DT:BLOCK-GET-DEF DOC NEWBLOCK)
  (defun DT:GETDBX(/ DOC SERVER)
    (if(or(not(vl-catch-all-error-p
                (setq DOC (vl-catch-all-apply
                            'vla-GetInterfaceObject
                            (list
                              (vlax-get-acad-object)
                              (strcat "ObjectDBX.AxDbDocument."(substr(getvar"ACADVER")1 2))
                            )
                          )
                )
              )
          )    
          (and(or(and(setq SERVER (findfile (strcat "AxDb"(substr(getvar"ACADVER")1 2)".dll")))
                     (startapp "regsvr32.exe" (strcat "/s \"" SERVER "\""))
                 )
                 (and(setq SERVER (findfile "AxDb.dll"))
                     (startapp "regsvr32.exe" (strcat "/s \"" SERVER "\""))
                 )
              )
              (or(not(vl-catch-all-error-p 
                       (setq DOC (vl-catch-all-apply
                                   'vla-GetInterfaceObject
                                   (list
                                     (vlax-get-acad-object)
                                     (strcat "ObjectDBX.AxDbDocument." (substr(getvar"ACADVER")1 2))
                                   )    
                                 )
                       )
                     )
                 )                                      
                 (not(vl-catch-all-error-p
                       (setq DOC (vl-catch-all-apply
                                   'vla-GetInterfaceObject
                                   (list(vlax-get-acad-object)"ObjectDBX.AxDbDocument")
                                 )
                       )
                    )
                 )
              )
          )
       )
      DOC
      (if (=(getvar"CMDECHO")1)(prompt "\nObjectDBX-Server nicht gefunden.Abbruch."))  
    )
  )
  ;;; - ---------------------------------------------------------------------------- - ;
  (defun DT:BLOCK-GET-DEF(BLOCK)
    (cond
      ((=(type BLOCK)'STR)
        (if(not(vl-catch-all-error-p
                 (setq BLOCK(vl-catch-all-apply
                              'vla-item
                              (list(vla-get-blocks
                                     (vla-get-ActiveDocument(vlax-get-acad-object))
                                   )
                                   BLOCK
                              )
                            )
                 )
               )
           )
          BLOCK
        )
      )
      ((=(type BLOCK)'vla-Object)
        (cond
           ((member (strcase(vla-get-objectname  BLOCK))
                   '("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK")
            )              
            (if(not(vl-catch-all-error-p
                      (setq BLOCK(vl-catch-all-apply
                                   'vla-item
                                    (list(vla-get-blocks
                                           (vla-get-ActiveDocument(vlax-get-acad-object))
                                         )
                                    ) 
                                    (vla-get-name BLOCK)
                                 )
                      )
                    )
                )
               BLOCK
             )
           )
           ((=(strcase(vla-get-objectname  BLOCK))"ACDBBLOCKTABLERECORD")
              BLOCK
           )
        )
      )
      ((and(=(type BLOCK)'ENAME)        
           (member(cdr(assoc 0 (entget BLOCK)))'("BLOCK" "INSERT"))
       )
        (if(not(vl-catch-all-error-p
                 (setq BLOCK(vl-catch-all-apply
                              'vla-item
                               (list(vla-get-blocks
                                      (vla-get-ActiveDocument(vlax-get-acad-object))
                                    )                                   
                                    (cdr(assoc 2 (entget BLOCK)))
                               )     
                            )
                 )
               )
           )    
          BLOCK
        )        
      ) 
    )
  )
  
  (if(and(=(type NEWNAME)'STR)
         (or(not(tblobjname "BLOCK" NEWNAME))
            (prompt "\nBlockname schon vorhanden.Abbruch")
         )
         (setq BLOCK(DT:BLOCK-GET-DEF BLOCK))
         (setq DOC(vla-get-activedocument(vlax-get-acad-object)))
         (setq DBXDOC(DT:GETDBX))
         (not(vl-catch-all-error-p
               (vl-catch-all-apply
                 'vla-CopyObjects
                 (list DOC
                      (vlax-make-variant
                        (vlax-safearray-fill
                           (vlax-make-safearray vlax-vbObject '(0 . 0)) 
                           (list BLOCK)
                        )
                      )
                      (vlax-make-variant (vla-get-blocks DBXDOC))
                 )
               )
             )
         )
         (not(vl-catch-all-error-p
               (setq NEWBLOCK(vl-catch-all-apply
                                'vla-item
                                 (list(vla-get-blocks DBXDOC)
                                      (vla-get-name BLOCK)
                                 )
                             )
               )
             )
         )
         (not(vl-catch-all-error-p
               (vl-catch-all-apply
                 'vla-put-name (list NEWBLOCK NEWNAME)
               )
             )
         )    
         (not(vl-catch-all-error-p
               (vl-catch-all-apply
                 'vla-CopyObjects
                 (list DBXDOC
                      (vlax-make-variant
                        (vlax-safearray-fill
                           (vlax-make-safearray vlax-vbObject '(0 . 0)) 
                           (list NEWBLOCK)
                        )
                      )
                      (vlax-make-variant (vla-get-blocks DOC))
                 )
               )
             )
         )
         (not(vl-catch-all-error-p
               (setq NEWBLOCK(vl-catch-all-apply
                                'vla-item
                                 (list(vla-get-blocks DOC) NEWNAME)
                             )
               )
             )
         )
     )
    (progn   
      (if DBXDOC (vlax-release-object DBXDOC))        
      NEWBLOCK
    )
    (progn
      (if DBXDOC (vlax-release-object DBXDOC))
      (princ)
    )
  )
)

(defun C:BLOCKDUPLICATE(/ BLOCK NEWNAME DATA)
  (if(and(or(setq BLOCK(car(entsel"\nBlock wählen:")))
            (prompt "\nNichts gewählt.Abbruch")
         )   
         (or(=(cdr(assoc 0 (setq DATA(entget BLOCK))))"INSERT")
            (prompt "\nKeine Blockreferenz gewählt.Abbruch")
         )   
         (setq NEWNAME(getstring"\nNeuer Blockname: "))
         (or(snvalid NEWNAME 0)
            (prompt "\nUngültiger Blockname.Abbruch")
         )    
         (or(not(tblobjname "BLOCK" NEWNAME))
            (prompt "\nBlockname existiert schon.Abbruch")
         )
         (DT:BLOCKDUPLICATE BLOCK NEWNAME)            
         (entmod (subst (cons 2 NEWNAME)(assoc 2 DATA)DATA))
     )
    (prompt "\nBlockdefinition erfolgreich dupliziert und zugewiesen.\n")
    (prompt "\nFehler beim Duplizieren des Blockes.\n")
  )
  (princ)
)

(defun C:BLOCKDUPLICATECOPY(/ BLOCK NEWNAME DATA)
    (if(and(or(setq BLOCK(car(entsel"\nBlock wählen:")))
            (prompt "\nNichts gewählt.Abbruch")
         )   
         (or(=(cdr(assoc 0 (setq DATA(entget BLOCK))))"INSERT")
            (prompt "\nKeine Blockreferenz gewählt.Abbruch")
         )   
         (setq NEWNAME(getstring"\nNeuer Blockname: "))
         (or(snvalid NEWNAME 0)
            (prompt "\nUngültiger Blockname.Abbruch")
         )    
         (or(not(tblobjname "BLOCK" NEWNAME))
            (prompt "\nBlockname existiert schon.Abbruch")
         )   
         (or(DT:BLOCKDUPLICATE BLOCK NEWNAME)
            (prompt "\nFehler beim Duplizieren des Blockes.Abbruch")
         )   
       )    
      (command "_insert" NEWNAME "_x" 1.0 "_y" 1.0 "_z" 1.0 "_r" 0.0)
    )        
)

(defun C:BDP() (C:BLOCKDUPLICATE))
(defun C:BDPC()(C:BLOCKDUPLICATECOPY))
                   
;;; - ------------------------------------------------------------------------------ - ;
(defun ACM-BLOCKDUPLICATE:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-BLOCKDUPLICATE : Blockdefinitionen duplizieren"
      "\n================== "
      "\n(C) Thomas Krüger 2023 (tk@cad-od.de)"
      "\nBefehlszeilenaufrufe :  BLOCKDUPLICATE BLOCKDUPLICATECOPY\n"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------ - ;
(ACM-BLOCKDUPLICATE:INFO)
(princ)

  
  
