Code Red > AutoLISP (Vanilla / Visual)

One Line Diagram via copy F1

(1/2) > >>

T-Square:
Hello All,

Does anyone have a lisp routine that allows you to consecutively select existing blocks and copy it to another location in a one line format?

Thanks in advance!

T-Square:
It's a start...


--- Code: ---(defun c:ONELINE (/ DIMSC INSPT BLK1 BLKENT BLK2)
(setvar "attreq" 0)
(setq DIMSC(getvar "dimscale"))
(setq INSPT(getpoint "\nSelect One Line Start Point: "))
;;;
(setq BLK1(entsel "\nSelect A Block: "))
(if BLK1
(progn
(setq BLKENT(entget (car BLK1)))
(if (= (cdr (assoc 0 BLKENT)) "INSERT")
(progn
(setq BLK2(cdr (assoc 2 BLKENT)))
(command ".insert" BLK2 INSPT DIMSC DIMSC 0)
);progn
(princ "\nNot A Block... Please Select Again: ")
);if
);progn
(princ "\nNothing Selected... Please Select Again: ")
);if
(princ)
)
--- End code ---

T-Square:
Getting there...


--- Code: ---(defun c:ONELINE (/ DIMSC BLK1 BLKENT BLK2)
(setvar "attreq" 0)
(setq DIMSC(getvar "dimscale"))
(setq INSPT(getpoint "\nSelect One Line Start Point: "))
;;;
(while
(setq BLK1(entsel "\nSelect A Block: "))
(if BLK1
(progn
(setq BLKENT(entget (car BLK1)))
(if (= (cdr (assoc 0 BLKENT)) "INSERT")
(progn
(setq BLK2(cdr (assoc 2 BLKENT)))
(command ".insert" BLK2 INSPT DIMSC DIMSC 0)
(setq INSPT(list (+ (car INSPT) (* DIMSC 0.75)) (- (cadr INSPT) 0.0)))
);progn
(princ "\nNot A Block... Please Select Again: ")
);if
);progn
(princ "\nNothing Selected... Please Select Again: ")
);if
);while
(princ)
)
--- End code ---

T-Square:
Works for me... Anyone care to critique... additions... subtractions?

"INITERR" & "RESET" are functions within my local error trap loaded at startup.


--- Code: ---(defun c:ONELINE (/ DIMSC BLK1 BLKENT BLK2)
(INITERR)
(setvar "CMDECHO" 0)
(command ".undo" "end")
(command ".undo" "m")
(setvar "CECOLOR" "bylayer")
(setvar "CELTYPE" "bylayer")
(setvar "CELWEIGHT" -1)
(setvar "SNAPMODE" 0)
(setvar "ATTREQ" 0)
(graphscr)
;;;
(GETSPACE)
(MAKEONELINELAYER)
;;;
(setq INSPT(getpoint "\nSelect One Line Start Point: "))
;;;
(while
(setq BLK1(entsel "\nSelect A Block: "))
(if BLK1
(progn
(setq BLKENT(entget (car BLK1)))
(if (= (cdr (assoc 0 BLKENT)) "INSERT")
(progn
(setq BLK2(cdr (assoc 2 BLKENT)))
(command ".insert" BLK2 INSPT DIMSC DIMSC 0)
(setq INSPT(list (+ (car INSPT) (* DIMSC 0.75)) (- (cadr INSPT) 0.0)))
)
(princ "\nNot A Block... Please Select Again: ")
)
)
(princ "\nNothing Selected... Please Select Again: ")
)
)
;;;
(command ".undo" "end")
(RESET)
(princ)
)
;;;
;;;;;;;;;;Sub Functions
;;;
(defun GETSPACE (/)
(if (and (equal (getvar "TILEMODE") 0)
(equal (getvar "CVPORT") 1)
)
(setq CSPACE 1);paper space
(setq CSPACE 0);model space.
)
(if (= CSPACE 1)
(setq DIMSC 1.0)
(setq DIMSC(getvar "DIMSCALE"))
)
)
;;;
(defun MAKEONELINELAYER (/)
(setq LAY "YOURLAYERHERE")
;;;
(if (not (tblsearch "layer" LAY))
(command ".-layer" "thaw" LAY "on" LAY "unlock" LAY "make" LAY "color" "1" LAY "lt" "continuous" LAY "")
(progn
(princ (strcat "\nLayer " LAY " Already Exists... Layer Un-Changed... "))
(setvar "clayer" LAY)
)
)
)
--- End code ---

Couple of things I am not sure if I want to tackle. Not all of my blocks are inserted about the center of the block. Thus, some are slightly off the center of the one line. Oh, and I can't remember how to keep the loop going if "Nothing Selected... Please Select Again" comes up.

CAB:
I made a few changes, not knowing exactly what you are trying to acheave.

--- Code: ---(defun c:ONELINE (/ DIMSC BLK1 BLKENT BLK2)
          ; (INITERR) ; ???
                 ;| turned off during debug
  (setvar "CMDECHO" 0)
  (command ".undo" "end")
  (command ".undo" "m")
  (setvar "CECOLOR" "bylayer")
  (setvar "CELTYPE" "bylayer")
  (setvar "CELWEIGHT" -1)
  (setvar "SNAPMODE" 0)
  (setvar "ATTREQ" 0)
  (graphscr) |;
;;;
  (setq DIMSC (GETDIMSCALE)) ; CAB
  (MAKEONELINELAYER "YOURLAYERHERE") ; CAB
;;;
  (if (setq INSPT (getpoint "\nSelect One Line Start Point: "))
    (while
      (cond
        ((null (setvar "ErrNo" 0))) ; reset var, cond never stops here
        ((and (setq BLK1 (entsel "\nSelect A Block: "))
              (setq BLKENT (entget (car BLK1)))
              (= (cdr (assoc 0 BLKENT)) "INSERT")
         )
         (setq BLK2 (cdr (assoc 2 BLKENT)))
         (command ".insert" BLK2 INSPT DIMSC DIMSC 0)
         (setq
           INSPT (list (+ (car INSPT) (* DIMSC 0.75)) (- (cadr INSPT) 0.0))
         )
        )

        ((= (getvar "errno") 52) (prompt "\nUser Quit.")) ; Exit on ENTER key
       
        (BLK1 (princ "\nNot A Block... Please Select Again: "))

        ((princ "\nNothing Selected... Please Select Again: "))
        ;; note that princ returns not nil
        ;;  using prompt will cause an exit from the loop
      )
    )
  )
;;;
  (command ".undo" "end")
          ; (RESET) ; ???
  (princ)
)


;;;
;;;;;;;;;;Sub Functions
;;;
(defun GETDIMSCALE () ; CAB revised
  (if (and (equal (getvar "TILEMODE") 0)
           (equal (getvar "CVPORT") 1)
      )
    1.0   ; paper space
    (getvar "DIMSCALE") ; model space.
  )
)
;;;
(defun MAKEONELINELAYER (LAY /) ; let the calling routine supply the layer
  ;;  (setq LAY "YOURLAYERHERE")
;;;
  (if (not (tblsearch "layer" LAY))
    (command ".-layer" "thaw" LAY "on" LAY "unlock" LAY "make" LAY "color" "1"
             LAY "lt" "continuous" LAY ""
            )
    (progn
      (princ (strcat "\nLayer " LAY " Already Exists... Layer Un-Changed... "))
      ;;(setvar "clayer" LAY)  <---<<  change this
      (command "._Layer" "_Thaw" LAY "_On" LAY "_UnLock" LAY "_Set" LAY "")
          ; to this
    )
  )
)
--- End code ---

Navigation

[0] Message Index

[#] Next page