;Title - Erin Stephens Lisp Page
;Lisp Page from Internet - Internet Worldwide Communications
; ***  MakeBlock   [Version 1.0] 4/28/95  ***
;
;Copyright 1995 Manu-Soft Computer Services
;
; ***************************************
; ****  Author:  Owen Wengerd        ****
; ****                               ****
; ****  Manu-Soft Computer Services  ****
; ****  P.O. Box 84                  ****
; ****  Fredericksburg, OH  44627    ****
; ****  (330) 695-5903               ****
; ****  Compu-Serve ID:  71324,3252  ****
; ***************************************
;
;
; This program takes selected objects, defines an anonymous block,
; then inserts the block at the original location.

(defun C:MAKEBLOCK

  (/ tmp ss ip errexit mbx BLAYER)


;**************************************************************************
                           
                           ;Layer For Block Placement:
    (setq BLAYER nil)      ;   "XXXX" = Place on layer XXXX
                           ;   nil    = Use current layer

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


  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )

  (defun mbx ()
    (setvar "CMDECHO" (car oldvar))
    (setq *error* olderr)
    (princ)
  )

  ;*** Main Program ***
  (setq T (not nil))
  (setq olderr  *error*
        restore mbx
        *error* errexit
  )
  (setq oldvar 
    (list 
      (getvar "CMDECHO") 
    )
  )
  (setvar "CMDECHO" 0)
  (terpri)
  (if BLAYER  
    (command "._LAYER"
      (if (tblsearch "LAYER" BLAYER) "_S" "_M")
      BLAYER
      ""
    )
  )
  (if
    (and
      (setq ip (getpoint "Pick Insertion Point (<0,0,0>): "))
      (setq ss (ssget))
    )
    (progn
      (entmake (list 
        (cons '0 "BLOCK") 
        (cons '2 "*U") 
        (cons '70 1) 
        (cons '10 ip)
      ))
      (setq cnt (sslength ss))
      (while (>= (setq cnt (1- cnt)) 0)
        (setq tmp (ssname ss cnt))
        (entmake (setq el (entget tmp)))
        (if (> (cdr (assoc 66 el)) 0)
          (while
            (/= "SEQEND"
              (cdr
                (assoc 0
                  (entmake (setq el (entget (entnext (cdr (assoc -1 el))))))
                )
              )
            )
          )
        )
        (entdel tmp)
      ) 
      (setq tmp (entmake (list (cons '0 "ENDBLK"))))
      (entmake (list 
        (cons '0 "INSERT") 
        (cons '2 tmp) 
        (cons '10 ip)
      ))
    )
  )  
  (restore)
)