; ====================================================================================== ;
; BATTR.LSP by kojacek (05-01-2010) AutoCAD 2k+                                          ;
; ====================================================================================== ;
; Polecenie BATTR zamienia wstawienia bloków, zachowujac cechy zgodnych (TAG-ami) atry-  ;
; butów. Mozna przedefiniowac blok (np. dodajac dodatkowe atrybuty) - program uaktualni  ;
; istniejace wstawienia, nie tracac wczesniejszych zmiam istniejacych atrybutow.         ;
; ====================================================================================== ;
; ====================================================================================== ;
(vl-load-com)
; ====================================================================================== ;
(defun C:BATTR (/ bl on nn lb olderr)
  (setq olderr *error* *error* BATTR_error)
  (if
    (setq bl (ai_table "BLOCK" (+ 2 4 8)))
    (if
      (setq on
        (getstring "\nNazwa bloku do zmiany: ")
      )
      (progn
        (setq on (strcase on)
              bl (mapcar 'strcase bl)
        )
        (if
          (jk:BAT_GetBlockName on bl)
          (if
            (setq ss
              (ssget "_X"
                (list (cons 0 "INSERT")(cons 2 on))
              )
            )
            (if
              (setq nn
                (getstring "\nNazwa bloku zastępującego: ")
              )
              (if
                (jk:BAT_GetBlockName (strcase nn) bl)
                (progn
                  (setq lb (jk:SSX_SS->List ss))
                  (princ "\nProszę czekać... \n")
                  (jk:SYS_UndoBegin)
                  (foreach % lb
                    (jk:ATT_ReInsertBlock % nn)
                  )
                  (jk:SYS_UndoEnd)
                )
              )
            )
            (princ
              (strcat
                "\nW rysunku nie ma wstawień bloku: "
                on
              )
            )
          )
        )
      )
    )
    (princ "\nW rysunku nie ma bloków. ")
  )
  (setq *error* olderr)
  (princ)
)
; ====================================================================================== ;
; sprawdza czy blok istnieje i czy ma atrybuty                                           ;
; ====================================================================================== ;
(defun jk:BAT_GetBlockName (Name Lst /)
  (cond
    ( (not (member Name Lst))
      (princ "\nBłędna nazwa - blok nie istnieje. ")
      Nil
    )
    ( (= (cdr (assoc 70 (tblsearch "BLOCK" Name))) 2)
      Name
    )
    (T (princ "\nBlok nie posiada atrybutów. ") Nil)
  )
)
; ====================================================================================== ;
; w miejsce usunietego bloku insEname, wstawia blok o nazwie NameNew. Przenosi cechy     ;
; bloku i jego atrybutów (dla zgodnych TAG-ów)                                           ;
; ====================================================================================== ;
(defun jk:ATT_ReInsertBlock (insEname NameNew / dx lt ip sp bl bd ad ip Nb)
  (setq dx (entget insEname)
        lt (cdr (assoc 410 dx))
        ip (cdr (assoc 10 dx))
        sp (vla-get-Block (vla-item (vla-get-Layouts (jk:ACX_ActDoc)) lt))
        bl '("XScaleFactor" "YScaleFactor" "ZScaleFactor" "Rotation" "Layer"
             "Color" "Linetype" "LinetypeScale" "LinetypeScale"
            )
        al '("Alignment" "Backward" "Color" "Height" "InsertionPoint"
            "Layer" "ObliqueAngle" "Rotation" "ScaleFactor"
            "StyleName" "TextAlignmentPoint" "TextGenerationFlag"
            "TextString"  "UpsideDown"
            )
        bd (jk:BLK_GetInsertData insEname bl)
        ad (jk:BLK_GetAttsData insEname al)
  )
  (if
    (vlax-write-enabled-p insEname)
    (progn
      (setq Nb
        (vla-InsertBlock sp (vlax-3d-point ip) NameNew 1.0 1.0 1.0 0.0)
      )
      (foreach % bd
        (if
          (vlax-property-available-p Nb (car %))
          (if
            (not
              (vl-catch-all-error-p
                (vl-catch-all-apply
                  'vlax-put-Property
                  (list Nb (car %)(cdr %))
                )
              )
            )
            (vlax-put-property Nb (car %)(cdr %))
          )
        )
      )
      (jk:BLK_PutAttsData Nb ad)
      (entdel insEname)
    )
  )
)
; ====================================================================================== ;
; zwraca liste par kropkowych PropList obiektu insert Obj                                ;
; ====================================================================================== ;
(defun jk:BLK_GetInsertData (Obj PropList / InsList)
  (setq Obj (jk:CON_VlaObject Obj))
  (if
    (= (strcase (vla-get-objectname Obj)) "ACDBBLOCKREFERENCE")
    (mapcar
      '(lambda (%)
        (cons %
          (if
            (vlax-property-available-p Obj %)
            (vlax-get-property Obj %)
            :vlax-null
          )
        )
      ) PropList
    )
  )
)
; ====================================================================================== ;
; zwraca liste par kropkowych PropList obiektu AttRib Obj                                ;
; ====================================================================================== ;
(defun jk:BLK_GetAttsData (Obj PropList / atrList)
  (setq Obj (jk:CON_VlaObject Obj))
  (if
    (jk:BLK_isAtts? Obj)
    (progn
      (setq atrList
             (vlax-safearray->list
               (vlax-variant-value
                 (vla-GetAttributes Obj))
             )
            atrList
             (mapcar
               '(lambda (%)
                 (cons %
                   (cons
                     (vla-get-TagString %)
                     (mapcar
                       '(lambda (%%)
                          (cons
                            %%
                            (if
                              (vlax-property-available-p % %%)
                              (vlax-get-property % %%)
                              :vlax-null
                            )
                          )
                        )
                        PropList
                     )
                   )
                 )
               )
              atrList
           )
      )
      atrList
      (mapcar 'cdr atrList)
    )
    Nil
  )
)
; ====================================================================================== ;
; dla zgodnych TAG-ów atrybutow bloku Obj ustala cechy przekazane jako Data              ;
; ====================================================================================== ;
(defun jk:BLK_PutAttsData (Obj Data / atrList dt at)
  (setq Obj (jk:CON_VlaObject Obj))
  (if
    (jk:BLK_isAtts? Obj)
    (progn
      (setq atrList
        (vlax-safearray->list
          (vlax-variant-value (vla-GetAttributes Obj))
        )
          atrList (mapcar '(lambda (%)
                             (cons (vla-get-TagString %) %)
                          ) atrList
                  )
      )
      (if
        (vlax-write-enabled-p Obj)
        (progn
          (foreach % atrList
            (if
              (assoc (car %) Data)
              (progn
                (setq dt (cdr (assoc (car %) Data))
                      at (cdr %)
                )
                (foreach %% dt
                  (if
                    (vlax-property-available-p at (car %%))
                    (if
                      (not
                        (vl-catch-all-error-p
                          (vl-catch-all-apply
                            'vlax-put-Property
                            (list at (car %%)(cdr %%))
                          )
                        )
                      )
                      (vlax-put-property at (car %%)(cdr %%))
                    )
                  )
                ) 
              )
            )
          )
        )
        nil
      )
    )
    nil
  )
)
; ====================================================================================== ;
; error                                                                                  ;
; ====================================================================================== ;
(defun BATTR_error (msg)
  (if (member msg '("console break" "Function cancelled"))
    (princ (strcat "\n" msg "\n"))
    (princ
      (strcat "\nBłąd: " msg "\n")
    ) 
  )
  (jk:SYS_UndoEnd)
  (if olderr (setq *error* olderr))
)
; ====================================================================================== ;
; jk_Utils.lsp                                                                           ;
; ====================================================================================== ;
; + ai_table (ai_utils.lsp) Copyright 1992,1994,1996-1999 by Autodesk, Inc.              ;
; ====================================================================================== ;
; ====================================================================================== ;
; undo start                                                                             ;
; ====================================================================================== ;
(defun jk:SYS_UndoBegin ()(vla-StartUndoMark (jk:ACX_ActDoc)))
; ====================================================================================== ;
; Undo end                                                                               ;
; ====================================================================================== ;
(defun jk:SYS_UndoEnd ()(vla-EndUndoMark (jk:ACX_ActDoc)))
; ====================================================================================== ;
; Zwraca obiekt ActiveDocument aktualnego rysunku                                        ;
; ====================================================================================== ;
(defun jk:ACX_ActDoc ()
  (if
    (not *jk-ActDoc)
    (setq *jk-ActDoc (vla-get-activedocument (vlax-get-acad-object)))
    *jk-ActDoc
  )
)
; ====================================================================================== ;
; zmienia SS na liste Ename                                                              ;
; ====================================================================================== ;
(defun jk:SSX_SS->List (sel / % l)
  (repeat 
    (setq % (sslength sel))
    (setq % (1- %) 
          l (cons (ssname sel %) l)
    )
  )
)
; ====================================================================================== ;
; sprawdza czy [Obj] to blok i czy ma atrybuty. Zwraca T/Nil                             ;
; ====================================================================================== ;
(defun jk:BLK_isAtts? (Obj)
  (setq Obj (jk:CON_VlaObject Obj))
  (cond
    ( (= (strcase (vla-get-objectname Obj)) "ACDBBLOCKREFERENCE")
      (cdr
        (assoc (vla-get-HasAttributes Obj) '((:vlax-true . T)(:vlax-false . Nil)))
      )
    )
    (T Nil)
  )
)
; ====================================================================================== ;
; zmienia Ename na VlaObject                                                             ;
; ====================================================================================== ;
(defun jk:CON_VlaObject (In)
  (cond
    ((= (type In) 'VLA-OBJECT) In)
    ((= (type In) 'ENAME)(vlax-ename->vla-object In))
    (T Nil)
  )
)
; ====================================================================================== ;
(princ "\nBATTR.LSP by kojacek wczytano. Polecenie BATTR ")(princ)