Author Topic: Block replacement lisp  (Read 30175 times)

0 Members and 1 Guest are viewing this topic.

Cad64

  • Guest
Block replacement lisp
« on: February 25, 2006, 06:19:24 PM »
I found this great prog that will replace one instance of a block with another block. The only prob is the Cancel button doesn't work. Hit cancel or esc and the prog continues on as if you had hit Ok. At first it would just lock up when I hit cancel. I was able to fix that prob, but now cancel works the same as Ok. Can anyone help?

Also, I would like the default to be Individually rather than Globally.

TIA for any help you can give. I am running acad2006 by the way.

Here's the code for the lisp:

Code: [Select]
;;===========================================================================
;;
;; Automated Design Services Limited
;; AutoLisp Programming
;; Ewald P. Ruceis
;; SUB_BLK.lsp
;; Version 1.80
;; 07/31/00
;;
;; Modified: 09/17/00 by Jeff Tippit, SPAUG President, www.spaug.org
;;===========================================================================
;;
;; Main function -- no arguments
;;

;SUB_BLK.LSP      Substitute blocks     (c)2001, Pete Ruceis

(defun SUB_BLK (/ #BLK1            ; Block to be replaced
                  #BLK2            ; Block to do the replacing
                  BLK_ENT1         ; First block entity
                  BLK_ENT2         ; Second block entity
                  cht_ot
                  cht_oh
                  CME              ; The orginal "cmdecho" value
                  COUNT            ; The number of block changed
                  DCL_ID           ; The id for the dialog definition
                  DO_ALL           ; Toggle for individual or global processing
                  DO_MORE          ; The flag to control looping of the selection routine
                  FRAMUS_DONE      ; Dialog return control variable
                  IDX              ; Index to access selection set
                  INS_1            ; Old block insertion point
                  LYR_1            ; Old block layer
                  LYR_2            ; New block layer
                  LYR_FLG          ; Flag to control layer changes
                  NAM_1            ; Old block name
                  NAM_2            ; New block name
                  NEW_ERR          ; The internal "*error*" value
                  NSSET            ; Clean selection set
                  ERASE_BLOCK      ; Block to be erased
                  OLD_ERR          ; The orginal "*error*" value
                  OLD_LAY          ; The orginal "clayer" value
                  OLD_MOD          ; The orginal "osmode" value
                  OLD_STL          ; The orginal "textstyler" value
                  REP_INS          ; Replacement block insertion point
                  REP_LAY          ; Replacement block layer
                  REP_NAM          ; Replacement block name
                  REP_ROT          ; Replacement block rotation
                  REP_XSF          ; Replacement block X-scale
                  REP_YSF          ; Replacement block Y-scale
                  REP_ZSF          ; Replacement block Z-scale
                  ROT_1            ; Old block rotation
                  ROT_2            ; New block rotation
                  ROT_FLG          ; Flag to control rotation changes
                  SCL_FLG          ; Flag to control scaling changes             
                  SSBLKS           ; Selection set of all blocks in drawing
                  SSL              ; Length of selection set
                  TEMP             ; Temporary list used to build clean selection set
                  XSF_1            ; Old block X-scale
                  XSF_2            ; New block X-scale
                  YSF_1            ; Old block Y-scale
                  YSF_2            ; New block Y-scale
                  ZSF_1            ; Old block Z-scale
                  ZSF_2            ; New block Z-scale
                 
               ); End local variables for SUB_BLK
      ;;
      ;; Internal error handler defined locally
      ;;
      (defun NEW_ERR (s)                   ; If an error (such as CTRL-C) occurs
                                           ; while this command is active...
         (if (/= s "Function cancelled")
            (if (= s "quit / exit abort")
               (princ)
               (princ (strcat "\nError: " s))
            ); End if
         ); End if
         (eval(read U:E))
         (if OLD_ERR                        ; If an old error routine exists
            (setq *error* OLD_ERR)           ; then, reset it
         ); End if
         (if TEMP
            (redraw TEMP 1)
         ); End if
         (if CME
            (setvar "cmdecho" CME)
         ); Reset command echoing
         (if cht_ot
            (setvar "texteval" cht_ot)
         ); End if
         (if cht_oh
            (setvar "highlight" cht_oh)
         ); End if
         (princ)
      ); End defun NEW ERR

      (if *error*                         ; Set our new error handler
         (setq OLD_ERR *error* *error* NEW_ERR)
         (setq *error* NEW_ERR)
      ); End if

      ;; Set undo groups and ends with (eval(read U:G)) or (eval(read U:E))
      (setq U:G "(command \"undo\" \"group\")"
            U:E "(command \"undo\" \"en\")"
      ); End setq
 
      (setq cht_oh (getvar "highlight"))

      (setq CME   (getvar "cmdecho"))
      (setvar "cmdecho" 0)
      (command "ucs" "W")
      (setq OLD_LAY (getvar "clayer"))
      (setq OLD_STL (getvar "textstyle"))
      (setq OLD_MOD (getvar "osmode"))

      (eval(read U:G))

;;
;; *********************************************************************
;;                        START OF MAIN LOOP
;; *********************************************************************
;;
      (setq DO_MORE "Y")
      (while (= DO_MORE "Y")
         (BIG_LOOP)
      ); End while
;;
;; *********************************************************************
;;                        END OF MAIN LOOP
;; *********************************************************************
;;
      (if OLD_ERR                            ; Reset old error function
         (setq *error* OLD_ERR)
      ); End if

      (eval(read U:E))

      (if cht_ot
         (setvar "texteval" cht_ot)
      ); End if

      (if cht_oh
         (setvar "highlight" cht_oh)
      ); End if

      (setvar "clayer" OLD_LAY)
      (setvar "textstyle" OLD_STL)
      (setvar "osmode" OLD_MOD)
      (command "ucs" "P")
      (if CME                                ; Reset command echoing
         (setvar "cmdecho" CME)
      ); End if

      (princ)

); End defun SUB_BLK.lsp

;;     
;; *********************************************************************
;;                        START OF BIG LOOP
;; *********************************************************************
;;
      (defun BIG_LOOP ()

         (USER_INPUT)
         (setq FRAMUS_DONE 0)     
         (while (/= FRAMUS_DONE 1)
            (SHOW_DIALOG)
         ); End while
         (I_OR_G)
         (initget "Y N")
         (setq DO_MORE (getkword "\nChange more blocks? Y/N <Y>: "))
            (if
               (or
                  (= DO_MORE "y")
                  (= DO_MORE "")
                  (= DO_MORE nil)
               ); End or
                  (setq DO_MORE "Y")
            ); End if
      ); End BIG LOOP
;;     
;; *********************************************************************
;;                        END OF BIG LOOP
;; *********************************************************************
;;                        START OF USER INPUT
;; *********************************************************************
;;
   (defun USER_INPUT ()
         (setq DO_ALL nil)
         (setq #BLK1 nil)
         (setq #BLK2 nil)
      (while (not #BLK1)
         (progn
            (setq #BLK1 (entsel "\nPick a block to Replace: "))
            (if #BLK1
               (progn
                  (setq ERASE_BLOCK #BLK1)
                  (setq BLK_ENT1 (entget (car #BLK1)))
                  (if (= (cdr (assoc 0 BLK_ENT1)) "INSERT")
                     (progn
                        (setq NAM_1 (cdr (assoc 2 BLK_ENT1)))     ; Old block name
                        (setq LYR_1 (cdr (assoc 8 BLK_ENT1)))     ; Old block layer
                        (setq INS_1 (cdr (assoc 10 BLK_ENT1)))    ; Old block insertion point
                        (setq ROT_1 (cdr (assoc 50 BLK_ENT1)))    ; Old block rotation
                        (setq XSF_1 (cdr (assoc 41 BLK_ENT1)))    ; Old block X-scale
                        (setq YSF_1 (cdr (assoc 42 BLK_ENT1)))    ; Old block Y-scale
                        (setq ZSF_1 (cdr (assoc 43 BLK_ENT1)))    ; Old block Z-scale
                        (princ (strcat "\nBlock \"" NAM_1 "\" selected."))
                     ) ; progn
                     ; Else
                     (progn
                        (setq #BLK1 nil)
                        (prompt "\nSelected object is not a Block. Try again. ")
                     ); End progn
                  ); End if
               ); End progn
               (princ "\nMissed the Block to Replace. Try again...")
            ); End if
         ); End progn
      ); End while

      (while (not #BLK2)
         (progn
            (setq #BLK2 (entsel "\nPick a block to Replace with: "))
            (if #BLK2
               (progn
                  (setq BLK_ENT2 (entget (car #BLK2)))
                  (if (= (cdr (assoc 0 BLK_ENT2)) "INSERT")
                     (progn
                        (setq NAM_2 (cdr (assoc 2 BLK_ENT2)))     ; new block name
                        (setq LYR_2 (cdr (assoc 8 BLK_ENT2)))     ; new block layer
                        (setq ROT_2 (cdr (assoc 50 BLK_ENT2)))    ; new block rotation
                        (setq XSF_2 (cdr (assoc 41 BLK_ENT2)))    ; new block X-scale
                        (setq YSF_2 (cdr (assoc 42 BLK_ENT2)))    ; new block Y-scale
                        (setq ZSF_2 (cdr (assoc 43 BLK_ENT2)))    ; new block Z-scale
                        (princ (strcat "\nBlock \"" NAM_2 "\" selected."))
                     ); End progn
                     ; Else
                     (progn
                        (setq #BLK2 nil)
                        (prompt "\nSelected object is not a Block. Try again. ")
                     ); End progn
                  ); End if
               ); End progn
               (princ "\nMissed the Block to Replace with. Try again...")
            ); End if
         ); End progn
      ); End while
   ); End USER INPUT
;;     
;; *********************************************************************
;;                        END OF USER INPUT
;; *********************************************************************
;;                        START OF DIALOG BOX
;; *********************************************************************
;;
   (defun SHOW_DIALOG ()
      (setq DCL_ID (load_dialog "sub_blk.dcl"))
      (if (not (new_dialog "sub_blk" DCL_ID))
         (exit)
      ); End if

      (set_tile "txt_old_nam" NAM_1)
      (set_tile "txt_old_lyr" LYR_1)
      (set_tile "txt_old_rot" (rtos (/ (* ROT_1 180.0) PI) 2 8))
      (set_tile "txt_old_xscl" (rtos XSF_1 2 8))
      (set_tile "txt_old_yscl" (rtos YSF_1 2 8))
      (set_tile "txt_old_zscl" (rtos ZSF_1 2 8))
      (set_tile "txt_new_nam" NAM_2)
      (set_tile "txt_new_lyr" LYR_2)
      (set_tile "txt_new_rot" (rtos (/ (* ROT_2 180.0) PI) 2 8))
      (set_tile "txt_new_xscl" (rtos XSF_2 2 8))
      (set_tile "txt_new_yscl" (rtos YSF_2 2 8))
      (set_tile "txt_new_zscl" (rtos ZSF_2 2 8))
;;
;;================== DIALOG ACTIONS =======================
;;
         (action_tile "btn_cng_ind" "(setq DO_ALL 1)")
         (action_tile "btn_cng_glb" "(setq DO_ALL nil)")
         (action_tile "tgl_lyr"     "(setq LYR_FLG $value)")
         (action_tile "tgl_rot"     "(setq ROT_FLG $value)")
         (action_tile "tgl_scl"     "(setq SCL_FLG $value)")
         (action_tile "accept" "(CHECKOUT) (setq FRAMUS_DONE 1) (done_dialog)")
         (action_tile "cancel" "(setq FRAMUS_DONE 1) (done_dialog)")
         (start_dialog)
    ); End SHOW DIALOG

;;     
;; *********************************************************************
;;                        END OF DIALOG BOX
;; *********************************************************************
;;                        START OF CHECKOUT
;; *********************************************************************
;;
      (defun CHECKOUT ()
         (unload_dialog DCL_ID)
      ); End CHECKOUT
;;     
;; *********************************************************************
;;                        END OF CHECKOUT
;; *********************************************************************
;;                        START OF I OR G OF ROUTINE
;; *********************************************************************
;;
      (defun I_OR_G ()
         (setq COUNT 0)
         (setq REP_NAM NAM_2)      ; Set default to block 2 name
         (setq REP_INS INS_1)      ; Set default to block 1 insertion point
         (setq REP_LAY LYR_2)      ; Set default to block 2 layer
         (setq REP_ROT ROT_2)      ; Set default to block 2 rotation
         (setq REP_XSF XSF_2)      ; Set default to block 2 X-scale
         (setq REP_YSF YSF_2)      ; Set default to block 2 Y-scale
         (setq REP_ZSF ZSF_2)      ; Set default to block 2 Z-scale
         (if (= DO_ALL nil)
            (MAK_GLOBAL)
         ; Else
            (progn
               (CHK_FLG)
               (MAK_CNG)
            ); End progn
         ); End if
         (princ (strcat "\n"
                        (rtos COUNT 2 0)
                        " Instance(s) of \""
                        NAM_1
                        "\" was/were replaced with \""
                        NAM_2
                        "\""
                ); End strcat
         ); End princ
      ); End I OR G
;;     
;; *********************************************************************
;;                        END OF I OR G OF ROUTINE
;; *********************************************************************
;;                        START OF MAKE GLOBAL ROUTINE
;; *********************************************************************
;;     

      (defun MAK_GLOBAL ()
         (setq SSBLKS (ssget "X" '((0 . "INSERT"))))
         (setq SSL (sslength SSBLKS)
               NSSET (ssadd)
         ); End setq
         (if (> SSL 10)
            (princ "\nVerifying the selected entities -- please wait. ")
         ); End
         (while (> SSL 0)
            (setq TEMP (ssname SSBLKS (setq SSL (1- SSL))))
            (if (= (cdr (assoc 2 (entget TEMP))) NAM_1)
               (ssadd TEMP NSSET)
            ); End if
         ); End while
         (setq SSL (sslength NSSET))
         (setq SSBLKS NSSET)
         (setq IDX 0)
         (repeat (sslength SSBLKS)
            (setq BLK_ENT1 (entget (ssname SSBLKS IDX)) IDX (1+ IDX))
            (setq REP_INS (cdr (assoc 10 BLK_ENT1)))    ; Old block insertion point
            (setq ERASE_BLOCK (cdr (assoc -1 BLK_ENT1)))
            (CHK_FLG)
            (MAK_CNG)
         ); End repeat
       ); End MAK GLOBAL
;;
;; *********************************************************************
;;                        END OF MAKE GLOBAL ROUTINE
;; *********************************************************************
;;                        START OF CHECK FLAG ROUTINE
;; *********************************************************************
;;     
      (defun CHK_FLG ()
         (if (= LYR_FLG "0")
            (setq REP_LAY (cdr (assoc 8 BLK_ENT1)))     ; Set to block 1 layer
         ); End if
         (if (= ROT_FLG "0")
            (setq REP_ROT (/ (* (cdr (assoc 50 BLK_ENT1)) 180.0) PI)) ; Set to block 1 rotation
         ); End if
         (if (= SCL_FLG "0")
            (progn
               (setq REP_XSF (cdr (assoc 41 BLK_ENT1))) ; Set to block 1 X-scale
               (setq REP_YSF (cdr (assoc 42 BLK_ENT1))) ; Set to block 1 Y-scale
               (setq REP_ZSF (cdr (assoc 43 BLK_ENT1))) ; Set to block 1 Z-scale
            ); End progn
         ); End if
      ); End CHK_FLG
;;     
;; *********************************************************************
;;                        END OF CHECK FLAG ROUTINE
;; *********************************************************************
;;                        START OF MAKE CHANGE ROUTINE
;; *********************************************************************
;;
      (defun MAK_CNG ()
         (command "._ERASE" ERASE_BLOCK "")
         (setvar "clayer" REP_LAY)
         (command "._INSERT" REP_NAM REP_INS "xyz" REP_XSF REP_YSF REP_ZSF REP_ROT)
         (setq COUNT (+ COUNT 1))
       ); End MAK_CNG
;;
;; *********************************************************************
;;                        END OF MAKE CHANGE ROUTINE
;; *********************************************************************
;;
;; The C: function definition.
;;

(defun c:SUB   () (SUB_BLK))
(princ "\nc:Sub_Blk loaded.  Start command with SUB.")
(princ)

Code tags Added


« Last Edit: February 25, 2006, 08:23:33 PM by Cad64 »

Cad64

  • Guest
Re: Block replacement lisp
« Reply #1 on: February 25, 2006, 06:20:10 PM »
Here's the dcl:


Code: [Select]
//SUB_BLK.DCL      Substitute blocks     (c)2001, Pete Ruceis

sub_blk : dialog {
          label = "Pete's Magic Block Replacer";
          : boxed_radio_row {
            label = "Make Changes";
            spacer_1;
            : radio_button {
                  label = "Individually:";
                  key = "btn_cng_ind";
                }// End radio button
         
                : radio_button {
                  label = "Globally:";
                  key = "btn_cng_gbl";
                  value = "1";
                }// End radio button
             
             }// End boxed radio row

          : row {
             : boxed_row {
               label = "Old Block";
                : column {
                   : text {
                      label = "Name:    ";
                   }// End text

                   : text {
                      label = "Layer:   ";
                   }// End text
               
                   : text {
                      label = "Rotation:";
                   }// End text

                   : text {
                      label = "X Scale: ";
                   }// End text

                   : text {
                      label = "Y Scale: ";
                   }// End text

                   : text {
                      label = "Z Scale: ";
                   }// End text
                 }// End column

                 : column {
                   : text {
                      key = "txt_old_nam";
                      label = "                           ";
                   }// End text

                   : text {
                      key = "txt_old_lyr";
                      label = "                           ";
                   }// End text

                   : text {
                      key = "txt_old_rot";
                      label = "                           ";
                   }// End text

                  : text {
                      key = "txt_old_xscl";
                      label = "                           ";
                   }// End text

                  : text {
                      key = "txt_old_yscl";
                      label = "                           ";
                   }// End text

                  : text {
                      key = "txt_old_zscl";
                      label = "                           ";
                   }// End text
                }// End column
             }// End boxed row

            : boxed_row {
               label = "New Block";
             
                : column {
                   width = "9";
                   : text {
                      label = "Name:    ";
                   }// End text

                   : text {
                      label = "Layer:   ";
                   }// End text
               
                   : text {
                      label = "Rotation:";
                   }// End text

                   : text {
                      label = "X Scale: ";
                   }// End text

                   : text {
                      label = "Y Scale: ";
                   }// End text

                   : text {
                      label = "Z Scale: ";
                   }// End text
                 }// End column

                 : column {
                    width = "30";
                   : text {
                      key = "txt_new_nam";
                      label = "                           ";
                   }// End text

                   : text {
                      key = "txt_new_lyr";
                      label = "                           ";
                   }// End text

                   : text {
                      key = "txt_new_rot";
                      label = "                           ";
                   }// End text

                  : text {
                      key = "txt_new_xscl";
                      label = "                           ";
                   }// End text
                  : text {
                      key = "txt_new_yscl";
                      label = "                           ";
                   }// End text

                  : text {
                      key = "txt_new_zscl";
                      label = "                           ";
                   }// End text
                 }// End column
             }// End boxed column
          }// End row

          : boxed_column {
               label = "Change Attributes:";
               : toggle {
                  label = "New Block's Layer:";
                  key = "tgl_lyr";
                  value = "1";
                }// End toggle

               : toggle {
                  label = "New Block's Rotation:";
                  key = "tgl_rot";
                  value = "1";
                }// End toggle

               : toggle {
                  label = "New Block's Scale:";
                  key = "tgl_scl";
                  value = "1";
                }// End toggle             
          }// End boxed column
          spacer_1;
     ok_cancel;
}// End dialog

Code Tags Added
« Last Edit: February 25, 2006, 08:25:23 PM by Cad64 »

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Block replacement lisp
« Reply #2 on: February 25, 2006, 07:31:06 PM »
First thing .. Check your parenthesis balancing .. the SHOW_DIALOG visually scans wonky ...

Second .. Why are both cancel and accept setting FRAMUS_DONE  to 1 ?

Third ..
investigate this for both cancel and accept ...

(setq DCLreturn (start_dialog))
instead of (start_dialog)

check the value of DCLreturn < leave it global to check >

Just for interests sake, who wrote that  ...
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

Cad64

  • Guest
Re: Block replacement lisp
« Reply #3 on: February 25, 2006, 07:42:28 PM »
Thanks for the reply Kerry.

The author was Pete Ruceis.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Block replacement lisp
« Reply #4 on: February 25, 2006, 08:04:09 PM »
Looks like CAB may have fixed the Parenthesis balancing for you.

Would be nice if you restored the original (c) notice , even if you do make mods to the routine.

I'm a little short of time at the moment, so someone else may have this solved before I return.


 
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

Cad64

  • Guest
Re: Block replacement lisp
« Reply #5 on: February 25, 2006, 08:18:05 PM »
I still have the (c) notice in the file. I just stripped off all of the non-code lines because I was having trouble posting. I wanted to get the message small enough. I guess I should have put everything back once I split the post in half. Next time I will make sure to include everything. I will always give credit where credit is due.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Block replacement lisp
« Reply #6 on: February 25, 2006, 08:20:20 PM »
This is where I found it.
  http://tinyurl.com/nfzpf
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

Cad64

  • Guest
Re: Block replacement lisp
« Reply #7 on: February 25, 2006, 08:49:42 PM »
Thanks Cab.

Still can't get cancel to work correctly though.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Block replacement lisp
« Reply #8 on: February 25, 2006, 09:30:50 PM »
I took a quick look and made a few changes but did not test.
Sorry no time tonght.
Code: [Select]
;;===========================================================================
;;
;; Automated Design Services Limited
;; AutoLisp Programming
;; Ewald P. Ruceis
;; SUB_BLK.lsp
;; Version 1.80
;; 07/31/00
;;
;; Modified: 09/17/00 by Jeff Tippit, SPAUG President, www.spaug.org
;; Mods by CAB 02/5/06
;;===========================================================================
;;
;; Main function -- no arguments
;;

(defun SUB_BLK (/ #BLK1            ; Block to be replaced
                  #BLK2            ; Block to do the replacing
                  BLK_ENT1         ; First block entity
                  BLK_ENT2         ; Second block entity
                  cht_ot
                  cht_oh
                  CME              ; The orginal "cmdecho" value
                  COUNT            ; The number of block changed
                  DCL_ID           ; The id for the dialog definition
                  DO_ALL           ; Toggle for individual or global processing
                  DO_MORE          ; The flag to control looping of the selection routine
                  FRAMUS_DONE      ; Dialog return control variable
                  IDX              ; Index to access selection set
                  INS_1            ; Old block insertion point
                  LYR_1            ; Old block layer
                  LYR_2            ; New block layer
                  LYR_FLG          ; Flag to control layer changes
                  NAM_1            ; Old block name
                  NAM_2            ; New block name
                  NEW_ERR          ; The internal "*error*" value
                  NSSET            ; Clean selection set
                  ERASE_BLOCK      ; Block to be erased
                  OLD_ERR          ; The orginal "*error*" value
                  OLD_LAY          ; The orginal "clayer" value
                  OLD_MOD          ; The orginal "osmode" value
                  OLD_STL          ; The orginal "textstyler" value
                  REP_INS          ; Replacement block insertion point
                  REP_LAY          ; Replacement block layer
                  REP_NAM          ; Replacement block name
                  REP_ROT          ; Replacement block rotation
                  REP_XSF          ; Replacement block X-scale
                  REP_YSF          ; Replacement block Y-scale
                  REP_ZSF          ; Replacement block Z-scale
                  ROT_1            ; Old block rotation
                  ROT_2            ; New block rotation
                  ROT_FLG          ; Flag to control rotation changes
                  SCL_FLG          ; Flag to control scaling changes             
                  SSBLKS           ; Selection set of all blocks in drawing
                  SSL              ; Length of selection set
                  TEMP             ; Temporary list used to build clean selection set
                  XSF_1            ; Old block X-scale
                  XSF_2            ; New block X-scale
                  YSF_1            ; Old block Y-scale
                  YSF_2            ; New block Y-scale
                  ZSF_1            ; Old block Z-scale
                  ZSF_2            ; New block Z-scale
                 
               ); End local variables for SUB_BLK
      ;;
      ;; Internal error handler defined locally
      ;;
      (defun NEW_ERR (s)                   ; If an error (such as CTRL-C) occurs
                                           ; while this command is active...
         (if (/= s "Function cancelled")
            (if (= s "quit / exit abort")
               (princ)
               (princ (strcat "\nError: " s))
            ); End if
         ); End if
         (eval(read U:E))
         (if OLD_ERR                        ; If an old error routine exists
            (setq *error* OLD_ERR)           ; then, reset it
         ); End if
         (if TEMP
            (redraw TEMP 1)
         ); End if
         (if CME
            (setvar "cmdecho" CME)
         ); Reset command echoing
         (if cht_ot
            (setvar "texteval" cht_ot)
         ); End if
         (if cht_oh
            (setvar "highlight" cht_oh)
         ); End if
         (princ)
      ); End defun NEW ERR

      (if *error*                         ; Set our new error handler
         (setq OLD_ERR *error* *error* NEW_ERR)
         (setq *error* NEW_ERR)
      ); End if

      ;; Set undo groups and ends with (eval(read U:G)) or (eval(read U:E))
      (setq U:G "(command \"undo\" \"group\")"
            U:E "(command \"undo\" \"en\")"
      ); End setq
 
      (setq cht_oh (getvar "highlight"))

      (setq CME   (getvar "cmdecho"))
      (setvar "cmdecho" 0)
      (command "ucs" "W")
      (setq OLD_LAY (getvar "clayer"))
      (setq OLD_STL (getvar "textstyle"))
      (setq OLD_MOD (getvar "osmode"))

      (eval(read U:G))

;;
;; *********************************************************************
;;                        START OF MAIN LOOP
;; *********************************************************************
;;
      (setq DO_MORE "Y")
      (while (= DO_MORE "Y")
         (BIG_LOOP)
      ); End while
;;
;; *********************************************************************
;;                        END OF MAIN LOOP
;; *********************************************************************
;;
      (if OLD_ERR                            ; Reset old error function
         (setq *error* OLD_ERR)
      ); End if

      (eval(read U:E))

      (if cht_ot
         (setvar "texteval" cht_ot)
      ); End if

      (if cht_oh
         (setvar "highlight" cht_oh)
      ); End if

      (setvar "clayer" OLD_LAY)
      (setvar "textstyle" OLD_STL)
      (setvar "osmode" OLD_MOD)
      (command "ucs" "P")
      (if CME                                ; Reset command echoing
         (setvar "cmdecho" CME)
      ); End if

      (princ)

); End defun SUB_BLK.lsp

;;     
;; *********************************************************************
;;                        START OF BIG LOOP
;; *********************************************************************
;;
      (defun BIG_LOOP ()

         (USER_INPUT)
         (setq FRAMUS_DONE 0)     
         (while (= FRAMUS_DONE 0)
            (SHOW_DIALOG)
         ); End while
         (if (= FRAMUS_DONE 1) (I_OR_G))
         (initget "Y N")
         (setq DO_MORE (getkword "\nChange more blocks? Y/N <Y>: "))
            (if
               (or
                  (= DO_MORE "y")
                  (= DO_MORE "")
                  (= DO_MORE nil)
               ); End or
                  (setq DO_MORE "Y")
            ); End if
      ); End BIG LOOP
;;     
;; *********************************************************************
;;                        END OF BIG LOOP
;; *********************************************************************
;;                        START OF USER INPUT
;; *********************************************************************
;;
   (defun USER_INPUT ()
         (setq DO_ALL nil)
         (setq #BLK1 nil)
         (setq #BLK2 nil)
      (while (not #BLK1)
         (progn
            (setq #BLK1 (entsel "\nPick a block to Replace: "))
            (if #BLK1
               (progn
                  (setq ERASE_BLOCK #BLK1)
                  (setq BLK_ENT1 (entget (car #BLK1)))
                  (if (= (cdr (assoc 0 BLK_ENT1)) "INSERT")
                     (progn
                        (setq NAM_1 (cdr (assoc 2 BLK_ENT1)))     ; Old block name
                        (setq LYR_1 (cdr (assoc 8 BLK_ENT1)))     ; Old block layer
                        (setq INS_1 (cdr (assoc 10 BLK_ENT1)))    ; Old block insertion point
                        (setq ROT_1 (cdr (assoc 50 BLK_ENT1)))    ; Old block rotation
                        (setq XSF_1 (cdr (assoc 41 BLK_ENT1)))    ; Old block X-scale
                        (setq YSF_1 (cdr (assoc 42 BLK_ENT1)))    ; Old block Y-scale
                        (setq ZSF_1 (cdr (assoc 43 BLK_ENT1)))    ; Old block Z-scale
                        (princ (strcat "\nBlock \"" NAM_1 "\" selected."))
                     ) ; progn
                     ; Else
                     (progn
                        (setq #BLK1 nil)
                        (prompt "\nSelected object is not a Block. Try again. ")
                     ); End progn
                  ); End if
               ); End progn
               (princ "\nMissed the Block to Replace. Try again...")
            ); End if
         ); End progn
      ); End while

      (while (not #BLK2)
         (progn
            (setq #BLK2 (entsel "\nPick a block to Replace with: "))
            (if #BLK2
               (progn
                  (setq BLK_ENT2 (entget (car #BLK2)))
                  (if (= (cdr (assoc 0 BLK_ENT2)) "INSERT")
                     (progn
                        (setq NAM_2 (cdr (assoc 2 BLK_ENT2)))     ; new block name
                        (setq LYR_2 (cdr (assoc 8 BLK_ENT2)))     ; new block layer
                        (setq ROT_2 (cdr (assoc 50 BLK_ENT2)))    ; new block rotation
                        (setq XSF_2 (cdr (assoc 41 BLK_ENT2)))    ; new block X-scale
                        (setq YSF_2 (cdr (assoc 42 BLK_ENT2)))    ; new block Y-scale
                        (setq ZSF_2 (cdr (assoc 43 BLK_ENT2)))    ; new block Z-scale
                        (princ (strcat "\nBlock \"" NAM_2 "\" selected."))
                     ); End progn
                     ; Else
                     (progn
                        (setq #BLK2 nil)
                        (prompt "\nSelected object is not a Block. Try again. ")
                     ); End progn
                  ); End if
               ); End progn
               (princ "\nMissed the Block to Replace with. Try again...")
            ); End if
         ); End progn
      ); End while
   ); End USER INPUT
;;     
;; *********************************************************************
;;                        END OF USER INPUT
;; *********************************************************************
;;                        START OF DIALOG BOX
;; *********************************************************************
;;
   (defun SHOW_DIALOG ()
      (setq DCL_ID (load_dialog "sub_blk.dcl"))
      (if (not (new_dialog "sub_blk" DCL_ID))
         (exit)
      ); End if

      (set_tile "txt_old_nam" NAM_1)
      (set_tile "txt_old_lyr" LYR_1)
      (set_tile "txt_old_rot" (rtos (/ (* ROT_1 180.0) PI) 2 8))
      (set_tile "txt_old_xscl" (rtos XSF_1 2 8))
      (set_tile "txt_old_yscl" (rtos YSF_1 2 8))
      (set_tile "txt_old_zscl" (rtos ZSF_1 2 8))
      (set_tile "txt_new_nam" NAM_2)
      (set_tile "txt_new_lyr" LYR_2)
      (set_tile "txt_new_rot" (rtos (/ (* ROT_2 180.0) PI) 2 8))
      (set_tile "txt_new_xscl" (rtos XSF_2 2 8))
      (set_tile "txt_new_yscl" (rtos YSF_2 2 8))
      (set_tile "txt_new_zscl" (rtos ZSF_2 2 8))
;;
;;================== DIALOG ACTIONS =======================
;;
         (action_tile "btn_cng_ind" "(setq DO_ALL 1)")
         (action_tile "btn_cng_glb" "(setq DO_ALL nil)")
         (action_tile "tgl_lyr"     "(setq LYR_FLG $value)")
         (action_tile "tgl_rot"     "(setq ROT_FLG $value)")
         (action_tile "tgl_scl"     "(setq SCL_FLG $value)")
         (action_tile "accept" "(CHECKOUT) (setq FRAMUS_DONE 1) (done_dialog)")
         (action_tile "cancel" "(setq FRAMUS_DONE 2) (done_dialog)")
         (start_dialog)
    ); End SHOW DIALOG

;;     
;; *********************************************************************
;;                        END OF DIALOG BOX
;; *********************************************************************
;;                        START OF CHECKOUT
;; *********************************************************************
;;
      (defun CHECKOUT ()
         (unload_dialog DCL_ID)
      ); End CHECKOUT
;;     
;; *********************************************************************
;;                        END OF CHECKOUT
;; *********************************************************************
;;                        START OF I OR G OF ROUTINE
;; *********************************************************************
;;
      (defun I_OR_G ()
         (setq COUNT 0)
         (setq REP_NAM NAM_2)      ; Set default to block 2 name
         (setq REP_INS INS_1)      ; Set default to block 1 insertion point
         (setq REP_LAY LYR_2)      ; Set default to block 2 layer
         (setq REP_ROT ROT_2)      ; Set default to block 2 rotation
         (setq REP_XSF XSF_2)      ; Set default to block 2 X-scale
         (setq REP_YSF YSF_2)      ; Set default to block 2 Y-scale
         (setq REP_ZSF ZSF_2)      ; Set default to block 2 Z-scale
         (if (= DO_ALL nil)
            (MAK_GLOBAL)
         ; Else
            (progn
               (CHK_FLG)
               (MAK_CNG)
            ); End progn
         ); End if
         (princ (strcat "\n"
                        (rtos COUNT 2 0)
                        " Instance(s) of \""
                        NAM_1
                        "\" was/were replaced with \""
                        NAM_2
                        "\""
                ); End strcat
         ); End princ
      ); End I OR G
;;     
;; *********************************************************************
;;                        END OF I OR G OF ROUTINE
;; *********************************************************************
;;                        START OF MAKE GLOBAL ROUTINE
;; *********************************************************************
;;     

      (defun MAK_GLOBAL ()
         (setq SSBLKS (ssget "X" '((0 . "INSERT"))))
         (setq SSL (sslength SSBLKS)
               NSSET (ssadd)
         ); End setq
         (if (> SSL 10)
            (princ "\nVerifying the selected entities -- please wait. ")
         ); End
         (while (> SSL 0)
            (setq TEMP (ssname SSBLKS (setq SSL (1- SSL))))
            (if (= (cdr (assoc 2 (entget TEMP))) NAM_1)
               (ssadd TEMP NSSET)
            ); End if
         ); End while
         (setq SSL (sslength NSSET))
         (setq SSBLKS NSSET)
         (setq IDX 0)
         (repeat (sslength SSBLKS)
            (setq BLK_ENT1 (entget (ssname SSBLKS IDX)) IDX (1+ IDX))
            (setq REP_INS (cdr (assoc 10 BLK_ENT1)))    ; Old block insertion point
            (setq ERASE_BLOCK (cdr (assoc -1 BLK_ENT1)))
            (CHK_FLG)
            (MAK_CNG)
         ); End repeat
       ); End MAK GLOBAL
;;
;; *********************************************************************
;;                        END OF MAKE GLOBAL ROUTINE
;; *********************************************************************
;;                        START OF CHECK FLAG ROUTINE
;; *********************************************************************
;;     
      (defun CHK_FLG ()
         (if (= LYR_FLG "0")
            (setq REP_LAY (cdr (assoc 8 BLK_ENT1)))     ; Set to block 1 layer
         ); End if
         (if (= ROT_FLG "0")
            (setq REP_ROT (/ (* (cdr (assoc 50 BLK_ENT1)) 180.0) PI)) ; Set to block 1 rotation
         ); End if
         (if (= SCL_FLG "0")
            (progn
               (setq REP_XSF (cdr (assoc 41 BLK_ENT1))) ; Set to block 1 X-scale
               (setq REP_YSF (cdr (assoc 42 BLK_ENT1))) ; Set to block 1 Y-scale
               (setq REP_ZSF (cdr (assoc 43 BLK_ENT1))) ; Set to block 1 Z-scale
            ); End progn
         ); End if
      ); End CHK_FLG
;;     
;; *********************************************************************
;;                        END OF CHECK FLAG ROUTINE
;; *********************************************************************
;;                        START OF MAKE CHANGE ROUTINE
;; *********************************************************************
;;
      (defun MAK_CNG ()
         (command "._ERASE" ERASE_BLOCK "")
         (setvar "clayer" REP_LAY)
         (command "._INSERT" REP_NAM REP_INS "xyz" REP_XSF REP_YSF REP_ZSF REP_ROT)
         (setq COUNT (+ COUNT 1))
       ); End MAK_CNG
;;
;; *********************************************************************
;;                        END OF MAKE CHANGE ROUTINE
;; *********************************************************************
;;
;; The C: function definition.
;;

(defun c:SUB   () (SUB_BLK))
(princ "\nc:Sub_Blk loaded.  Start command with SUB.")
(princ)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

Cad64

  • Guest
Re: Block replacement lisp
« Reply #9 on: February 25, 2006, 10:22:26 PM »
Many thanks for your time Cab, Cancel works correctly now.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Block replacement lisp
« Reply #10 on: February 25, 2006, 11:10:04 PM »
Cool CAB.

It was also published in CADALYST Jun 2001 .. by the looks of it. ... interesting.

kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

Joe Burke

  • Guest
Re: Block replacement lisp
« Reply #11 on: February 26, 2006, 11:44:09 AM »
Maybe I don't get it, but I faill to ses what's interesting about this bloated code.

Express Tools has a perfectly good program for globally replacing one block with another, blockreplace.

If you want to substitute this block reference with that block reference on an individual basis, all you have to do is change the target block ref name to the source ref name. Yes, you can get fancy with questions about whether target block should inheret source block scale and/or rotation. Which takes a few more lines of code.

I don't know how others feel. My sense is code from sources other than folks I know here, or from the Autodesk forum. is generally trash. It may do what it claims to do, but that doesn't mean it's worth haviing or using.

Pete's Magic...? That should tell you the author is probably a CAD manager more interested in protecting his job than writing good code. If Pete is around, I won't retract that statement.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Block replacement lisp
« Reply #12 on: February 26, 2006, 12:40:58 PM »
Foot in mouth comment retracted.
« Last Edit: February 26, 2006, 08:49:45 PM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Block replacement lisp
« Reply #13 on: February 26, 2006, 12:51:13 PM »
Maybe I don't get it, but I faill to see what's interesting about this bloated code.

 < snip >

Joe, There's nothing to get ; I was being sarcastic ...  expressing by understatement my incredulity that CADALYST would publish it.

As you say, it' a lot of code to wrap

(vla-put-name (vlax-ename->vla-object entName) newBlockName)



added : perhaps that should have read .. ' interesting, but not for the reasons you'd imagine '




kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

MP

  • Seagull
  • Posts: 17750
  • Have thousands of dwgs to process? Contact me.
Re: Block replacement lisp
« Reply #14 on: February 26, 2006, 02:29:25 PM »
What the ... I thought this was the swamp ... this kind of attitude belongs back at the Autodesk new server.

I think it's easy to look down one's nose and get snotty about other people's code because it don't measure up to one's sense of cleverness, brevity etc.

Fact is, the last version of the code in question here was written 6 years ago according to its header (I would safely guess it predates Autodesk Express Tool) -- we don't know if there is a more up to version, or if he only spent 5 minutes on it.

If one thinks they can pen a more efficient version they should just step up and demonstrate better technique rather than besmirch the author, who incidentally, didn't even post said code.

Incidentally, Autodesk has a habit of lifting code and ideas from others without giving credit. Moreover, more often than not, when you look at their code it often appears as if it were written by some amateur they found in a bar.
« Last Edit: February 26, 2006, 02:54:00 PM by MP »
Engineering Technologist • CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client
cadanalyst@gmail.comhttp://cadanalyst.slack.comhttp://linkedin.com/in/cadanalyst