Topic: Condition PROGN statement help

[kameron1967]

Hi guys.  I need your help.  I need this routine to decide if it's border1(TITLEBLOCKA) OR border #2 (iTITLEBLOCKB) and perform actions depending on which border it find. 

I wanted to go into a drawing, check to see if it has TITLEBLOCKA or TITLEBLOCKB. 
 
 
If TITLEBLOCKA, rename it ABCDE, THEN move its insertion point to the origin.
 
If TITLEBLOCKB, rename it ABCDE, THEN move its insertion point to the origin.
 
Hopefully someone can help solve this one mystery!

Thank you, thank you, thank you!.

Code: [Select]

(if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "TITLEBLOCKA"))))
(vla-put-Name
  (vla-item
    (vla-get-Blocks
      (vla-get-ActiveDocument
        (vlax-get-acad-object)
      )
    )
  "TITLEBLOCKA") ;;;<-- old block name
"abcde") ;;;< -- new block name
)
(if (setq B3Set (ssget "x" '((0 . "INSERT")(2 . "abcde"))))
       (progn
            (setq ename1 (ssname B3Set 0))
            (setq InsPt (cdr (assoc 10 (entget ename1))))
          (command "._move" "all" "" InsPt '(0.0 0.0))
; (command "._move" "all" "" "0,0" "@2.06155<194")
)
)
)
 


  (if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "TITLEBLOCKB"))))
(vla-put-Name
  (vla-item
    (vla-get-Blocks
      (vla-get-ActiveDocument
        (vlax-get-acad-object)
      )
    )
  "TITLEBLOCKB") ;;;<-- old block name
"abcde") ;;;< -- new block name
).
(if (setq B3Set (ssget "x" '((0 . "INSERT")(2 . "abcde"))))
       (progn
            (setq ename1 (ssname B3Set 0))
            (setq InsPt (cdr (assoc 10 (entget ename1))))
            (command "._move" "all" "" InsPt '(0.0 0.0))
 (command "._move" "all" "" "0,0" "@2.06155<194")
)
)
)
);end of IF.
[\code}.....

[CAB]

Are the blocks all in model space or some are in a layout space?

[kameron1967]

Are the blocks all in model space or some are in a layout space?

Blocks are in paper space.  I actually was able to get help on this one.  But I appreciate your reply, Cab. 

[CAB]

Glad you got it worked out.
Care to share your results?

[kameron1967]

Oh, definitely.  But I have to warn you - it's going to look unclean and crazy!  But if it will help fill the time of you programming gurus.  I still have to make it so that it accounts for the multiple layout tabs, as well as same titleblock filename in each of those tabs.  Any help would sure be appreciated.  

Glad you got it worked out.
Care to share your results?

Code: [Select]

;*****************************************************************;*****************************************************************
;INFO: Change OLD border - use OLDTB ;INFO: Change OLD border - use OLDTB

;*****************************************************************;*****************************************************************;
(defun c:OLDTB  (/ ss att)
  (if (setq ss (ssget "X" (list (cons 0 "INSERT")(cons 2 "i3042sht");CHANGE TAG VALUES IN BLOCK
       (cons 66 1)(if (getvar "CTAB")(cons 410 (getvar "CTAB"))
              (cons 67 (- 1 (getvar "TILEMODE")))))))
    (progn
      (foreach ent (mapcar 'cadr (ssnamex ss))
    (setq att (entnext ent))
    (while (not (eq "SEQEND" (cdadr (entget att))))
      (cond ((eq "GROUP_ID" (cdr (assoc 2 (entget att))))
         (entmod (subst (cons 1 "CSC  OR/WA/UT") (assoc 1 (entget att)) (entget att))))
        ((eq "OLD-NUM" (cdr (assoc 2 (entget att))))
         (entmod (subst (cons 1 " ") (assoc 1 (entget att)) (entget att)))))
      (setq att (entnext att))))
      (command "_regenall"))
    (princ "\n<!> No Blocks Found <!>"))

(command "UNDO" "M")

(if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "rdnote"))))
(command "erase" ss "")
)

(if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "rdate"))))
(command "erase" ss "")
)

;--------------------------------------------------------------------------------------------------------------------------------------

(COMMAND "TILEMODE" "0")
(COMMAND "UCS" "W")

;*********NEED HELP getting DEFAULT LAYER STATE to delete when I first enter into the drawing so a new one could be created********

(COMMAND "-LAYER" "A" "S" "DEFAULT" "" "" "T" "*" "U" "*" "ON" "*" "")
  (COMMAND "-LAYER" "A" "D" "DEFAULT" "" "")
(COMMAND "-LAYER" "A" "S" "DEFAULT" "" "" "T" "*" "U" "*" "ON" "*" "")
(command "zoom" "w" "30,0" "40,10")

(command "undo" "m")
(command "ucs" "world")

;*********1ST CONDITION STATEMENT********
(cond

  ((and (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "zi3042sht"))))

           (not

            (vl-catch-all-error-p

               (vl-catch-all-apply

                   'vla-put-name

                      (list (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) "zi3042sht") "abcde")

               )

           )

);END OF IF
          );
          (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "abcde"))))
          (setq obj (vlax-ename->vla-object (ssname ss 0)))  
    );   END OF COND
)

;AFTER RENAME, MOVES BLOCK'S INSERTION POINT TO ORIGIN
(if (setq B3Set (ssget "x" '((0 . "INSERT")(2 . "abcde"))))
       (progn
            (setq ename1 (ssname B3Set 0))
            (setq InsPt (cdr (assoc 10 (entget ename1))))
            (command "._move" "all" "" InsPt '(0.0 0.0))

))

;*********2ND CONDITION STATEMENT FOR A DIFFERENT BORDER BLOCK********

(cond

  ((and (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "i3042sht"))))

           (not

            (vl-catch-all-error-p

               (vl-catch-all-apply

                   'vla-put-name

                      (list (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) "i3042sht") "abcde")

               )

           )

);END OF IF
          );

(if (setq B3Set (ssget "x" '((0 . "INSERT")(2 . "abcde"))))
       (progn
            (setq ename1 (ssname B3Set 0))
            (setq InsPt (cdr (assoc 10 (entget ename1))))
            (command "._move" "all" "" InsPt '(0.0 0.0))
(command "._move" "all" "" "0,0" "@2.06155<194"))
          );

          (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "abcde"))))
          (setq obj (vlax-ename->vla-object (ssname ss 0)))  
    );   END OF COND
)

;--------------------------------------------------------------------------------------------------------------------------------------

  (COMMAND "-LAYER" "A" "R" "DEFAULT" "" "") ;RESTORES LAYER STATE
  (COMMAND "-LAYER" "A" "D" "DEFAULT" "" "")

(if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "abcde"))));MOVES BORDER TO BE REPLACE AWAY
(command "move" "p" "" "0,0" "@60<0")
)
;--------------------------------------------------------------------------------------------------------------------------------------

(command "ZOOM" "E")
(load "B:\\CAD\\LISP\\ATTRENAME2.LSP");RENAMES SOME ATTRIBUTE TAG NAMES
(C:ATTRENAME2)
(command "-purge" "b" "*" "n")
(princ "\nType UNDO then B to undo border change")
(command "zoom" "E")
(princ)
)

;*****************************************************************;*****************************************************************
;INFO: Change NEW TB border - use NEW TB

;*****************************************************************;*****************************************************************;

(defun c:NEWTB ()
(command "-purge" "b" "*" "n")
(command "UNDO" "M")

(if (tblsearch "LAYER" "G-ANNO-TTLB")
(command "-layer" "thaw" "G-ANNO-TTLB" "on" "G-ANNO-TTLB" "s" "G-ANNO-TTLB" "")
(command "-layer" "n" "G-ANNO-TTLB" "c" "7" "G-ANNO-TTLB" "s" "G-ANNO-TTLB" "")
)

(COMMAND "UCS" "W")

;*********CONDITION STATEMENT IN CASE NEW IS USED BY ITSELF - BUT PROBLEM WHEN BLOCK ABCDE ALREADY EXISTED********

(cond

  ((and (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "i3042sht"))))

           (not

            (vl-catch-all-error-p

               (vl-catch-all-apply

                   'vla-put-name

                      (list (vla-item (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) "i3042sht") "abcde")

               )

           )



);END OF IF

)))

;--------------------------------------------------------------------------------------------------------------------------------------

  (command "-insert" "B:\\CAD\\30x42\\i3042sht" "0,0" "1" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "")

(command "-purge" "b" "*" "n")

(load "B:\\CAD\\LISP\\MTB1270.LSP");THIS AUTOSELECTS ABCDE BLOCK AND TRANSFER IT TO NEW TITLEBLOCK
(C:MTB1270)

(if (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "abcde"))));ERASES ABCDE BLOCK AFTER TRANSFER
(command "erase" ss ""))
(command "zoom" "E")
(command "-purge" "b" "*" "n")
(princ "\nType UNDO then B to undo border change")
(princ "\nType MTB to update OLD titleblock with NEW titleblock")
(princ)
)

;*****************************************************************
;INFO: Match old blocks by selecting the old and clicking on the new to Transfer Attributes

;*****************************************************************
;(princ "\nType MTB to Run")
(defun C:MTB2 (/)

(setq ename (ssget "_x" '((0 . "INSERT")(2 . "abcde"))))
(setq ename1 (ssget "_x" '((0 . "INSERT")(2 . "i3042sht"))))
   (setq ename (entnext ename))
   (setq elist (entget ename))   ;the entity list of the base border
   (setq etype (cdr (assoc 0 elist)))   ;should be attrib
   (while (= etype "ATTRIB")      ;puts all the attribute in a list
      (setq tag (cdr (assoc 2 elist)))      ;the attribute tag
      (setq val (cdr (assoc 1 elist)));the attribute value
      (setq baselist (append (list (list tag val)) baselist));put the attribute in list
      (setq ename (entnext ename))         ;move onto the next attribute
      (setq elist (entget ename))
      (setq etype (cdr (assoc 0 elist)))
   );end while
   (setq ename1 (entnext ename1))            ;get the next entity, should be "ATTRIB"
   (setq elist1 (entget ename1))            ;the entity list of the border
   (setq etype1 (cdr (assoc 0 elist1)))         ;should be attrib
   (while (= etype1 "ATTRIB")
      (setq attval nil)
      (setq tag (cdr (assoc 2 elist1)));the attribute tag
      (foreach item baselist
         (if (= tag (nth 0 item))
            (progn  
               (setq attval (nth 1 item))
            );end then
            (progn);else do nothing go to next in list till tag matches
         );end if
      );end foreach
      (if (/= attval nil)
         (progn   (setq elist1 (subst (cons 1 attval) (assoc 1 elist1) elist1))
            (entmod elist1));end then
         (progn);end else
      );end if
      (setq ename1 (entnext ename1))   ;move onto the next attribute
      (setq elist1 (entget ename1))
      (setq etype1 (cdr (assoc 0 elist1)))
   );end while
   (command "REGEN")
);end defun
(princ)

;==================AUTO DWG PROPS UPDATE==============

(defun c:DWGUPD ( / sum tags ss ) (vl-load-com)
  ;; © Lee Mac 2011 - THANKS LEE!

  (setq sum
    (vla-get-SummaryInfo
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
  )

  (setq tags
   '(
      ("TITLE-1" .    title)
      ("TITLE-2" .  subject)
      ("TITLE-3" .   author)
      ("TITLE-4" . keywords)
    )
  )

  (if (setq ss (ssget "_X" '((0 . "INSERT") (66 . 1) (2 . "i3042SHT"))))
    (mapcar
      (function
        (lambda ( attrib / prop )
          (if (setq prop (cdr (assoc (strcase (vla-get-TagString attrib)) tags)))
            (vlax-put-property sum prop (vla-get-TextString attrib))
          )
        )
      )
      (vlax-invoke (vlax-ename->vla-object (ssname ss 0)) 'GetAttributes)
    )
  )

  (setq tags
   '(
      ("DATE" . comments)
      ("#" . hyperlinkbase)
    )
  )

  (if (setq ss (ssget "_X" '((0 . "INSERT") (66 . 1) (2 . "i3042RD"))));DIFFERENT BLOCKNAME
    (mapcar
      (function
        (lambda ( attrib / prop )
          (if (setq prop (cdr (assoc (strcase (vla-get-TagString attrib)) tags)))
            (vlax-put-property sum prop (vla-get-TextString attrib))
          )
        )
      )
      (vlax-invoke (vlax-ename->vla-object (ssname ss 0)) 'GetAttributes)
    )
  )
  (princ)
)
(c:dwgupd)

<edit: adjusted code tags>