;;; - ------------------------------------------------------------------------------ - ;
;;; -                T O O L - A C M - R E M I R R                                   - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Entspiegeln von Blockreferenzen                                 - ;
;;; - Befehle      : ACM-REMIRR                                                      - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 06.07.2025                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(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 DT:ERROR (MSG)    
  (if(not(wcmatch(strcase MSG t) "*break,*cancel*,*exit*"))      
    (princ (strcat "\nFEHLER: " MSG))
  )
  (DT:UNDOEND)
  (DT:RESET)
  (princ)
)
(defun DT:INIT()  
  (DT:UNDOSTART)        
  (setq ERRORSAVE *error*  *error* DT:ERROR        
  )
)
(defun DT:RESET()    
  (setq *error* ERRORSAVE)
  (mapcar '(lambda(X) (set X nil))(list 'ERRORSAVE))
  (DT:UNDOEND)
  (princ)
)
(defun C:ACM-REMIRR(/ DT:MIRRXBLOCKDEF BLOCK ITEM X Y Z R I NAME SUB LISTE MIRRBLOCKNAME)  
  (defun DT:MIRRXBLOCKDEF(BLOCKNAME MIRRBLOCKNAME / DOC BLOCK MIRRBLOCK DBXDOC ERRMSG)
    (setq DOC(vla-get-ActiveDocument(vlax-get-acad-object)))
    (if(and(or(=(type BLOCKNAME)'STR)
              (not(setq ERRMSG "Ungültiger Blockname"))
           )
           (or(not(vl-catch-all-error-p
                    (setq BLOCK(vl-catch-all-apply
                                 'vla-item  (list(vla-get-blocks DOC) BLOCKNAME)
                               )
                    )
                  )
              )
              (not(setq ERRMSG "Block nicht gefunden"))
           )
           (or(and(=(type MIRRBLOCKNAME)'STR)
                  (snvalid MIRRBLOCKNAME)
                  (not(tblobjname "BLOCK" MIRRBLOCKNAME))
              )
              (not(setq ERRMSG "Ungültiger Mirror-Blockname"))
           )
           (or(not(vl-catch-all-error-p
                    (setq DBXDOC (vl-catch-all-apply
                                   'vla-GetInterfaceObject
                                   (list
                                     (vlax-get-acad-object)
                                     (strcat "ObjectDBX.AxDbDocument."
                                             (substr(getvar"ACADVER")1 2)
                                     )
                                   )
                                 )
                   )
                 )
              )
              (not(setq ERRMSG "Fehler bei BDBXDOC-Erzeugung"))
           )
           (or(and(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 MIRRBLOCK(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 MIRRBLOCK MIRRBLOCKNAME)
                        )
                      )
                  )    
                  (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 MIRRBLOCK)
                                 )
                               )
                               (vlax-make-variant (vla-get-blocks DOC))
                          )
                        )
                      )
                  )
                  (not(vl-catch-all-error-p
                        (setq MIRRBLOCK(vl-catch-all-apply
                                         'vla-item
                                          (list(vla-get-blocks DOC) MIRRBLOCKNAME)
                                      )
                        )
                      )
                  )
               )
              (not(setq ERRMSG "Fehler bei der MIRROR-BLOCK-Erzeugung"))
           )  
           
       )
      (progn   
        (if DBXDOC (vlax-release-object DBXDOC))
        (vlax-for ITEM MIRRBLOCK
          (if(not(vl-catch-all-error-p                  
                   (vl-catch-all-apply
                     'vla-mirror (list ITEM (vlax-3D-Point '(0 0 0))(vlax-3D-Point '(0 1 0)))
                   ) 
                 )  
             )
            (vl-catch-all-apply 'vla-delete (list ITEM))
          )
        )
        MIRRBLOCK
      )
      (progn
        (if DBXDOC (vlax-release-object DBXDOC))
        (prompt ERRMSG)
      )
    )
  )
 (vlax-for BLOCK (vla-get-Blocks(vla-get-activedocument(vlax-get-acad-object)))
   (vlax-for ITEM  BLOCK
     (if(and(member(strcase(vla-get-objectname ITEM))
                   '("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK")
            )
            (setq X (float(vla-get-XScaleFactor ITEM)))
            (setq Y (float(vla-get-YScaleFactor ITEM)))
            (setq Z (float(vla-get-ZScaleFactor ITEM)))
            (or(<  X 0)(<  Y 0)(< Z 0))            
            (setq NAME(strcase(vla-get-name ITEM)))
        )
       (progn
         (if(setq SUB(assoc NAME LISTE))
           (setq LISTE (subst (list NAME (cons (list ITEM X Y Z) (cadr SUB)))
                              SUB
                              LISTE
                       )
           )
           (setq LISTE (cons (list NAME (cons (list ITEM X Y Z) (cdr SUB)))
                             LISTE
                       )
           )                 
         )  
       )         
     )  
   )   
 )
 (if LISTE
   (progn
     (DT:INIT)  
     (foreach BLOCK LISTE
       (setq MIRRBLOCKNAME(strcat(car BLOCK)"-MIRR"))
       (setq I 0)
       (while(tblobjname "BLOCK" MIRRBLOCKNAME)
         (setq MIRRBLOCKNAME(strcat MIRRBLOCKNAME(itoa(setq I(1+ I)))))
       )
       (if(=(type(DT:MIRRXBLOCKDEF (car BLOCK) MIRRBLOCKNAME))'VLA-OBJECT)
         (mapcar
           '(lambda(INSDATA / VLINS ENINS ENDATA X Y Z R)
              (if(and(setq VLINS(car INSDATA))
                     (setq ENINS(vlax-vla-object->ename VLINS))
                     (setq ENDATA(entget ENINS))
                     (numberp (setq X (cadr   INSDATA)))
                     (numberp (setq Y (caddr  INSDATA)))
                     (numberp (setq Z (cadddr INSDATA)))
                     (setq R (vla-get-Rotation VLINS))
                 )
                (progn
                  (cond
                    ((and(< X 0)(>= Y 0))
                       (entmod(subst (cons 2 MIRRBLOCKNAME)(assoc 2 ENDATA)ENDATA))
                       (vl-catch-all-apply
                         'vla-put-XScaleFactor(list VLINS (abs(vla-get-XScaleFactor VLINS)))
                       )
                     )
                     ((and(< Y 0)(>= X 0))
                       (entmod(subst (cons 2 MIRRBLOCKNAME)(assoc 2 ENDATA)ENDATA))
                       (vl-catch-all-apply
                         'vla-put-YScaleFactor(list VLINS (abs(vla-get-YScaleFactor VLINS)))
                       )
                       (vl-catch-all-apply 'vla-put-rotation (list VLINS (+ R PI)))
                     )
                     ((and(< X 0)(< Y 0))
                       (vl-catch-all-apply
                         'vla-put-XScaleFactor(list VLINS (abs(vla-get-XScaleFactor VLINS)))
                       )
                       (vl-catch-all-apply
                         'vla-put-YScaleFactor(list VLINS (abs(vla-get-YScaleFactor VLINS)))
                       )
                       (vl-catch-all-apply 'vla-put-rotation (list VLINS (+ R PI)))
                     )
                  )
                  (if (< Z 0)
                    (vl-catch-all-apply
                      'vla-put-XScaleFactor(list VLINS (abs(vla-get-XScaleFactor VLINS)))
                    )
                  )
                )                            
              )    
            )  
            (cadr BLOCK)
         )  
       )  
     )
     (DT:RESET)
   )
   (prompt"\nKeine gespiegelten Blockreferenzen gefunden")
  )
  (princ)
)  

;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-REMIRR:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-REMIRR : Entspiegeln von Blockreferenzen" 
      "\n=========== "
      "\n(C) Thomas Krüger 2025" 
      "\nE-Mail: tk@cad-od.de"
      "\nBefehlszeilenaufruf : ACM-REMIRR\n"   
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-REMIRR:INFO)
(princ)