TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: T-Square on April 06, 2008, 03:47:08 PM
-
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!
-
It's a start...
(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)
)
-
Getting there...
(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)
)
-
Works for me... Anyone care to critique... additions... subtractions?
"INITERR" & "RESET" are functions within my local error trap loaded at startup.
(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)
)
)
)
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.
-
I made a few changes, not knowing exactly what you are trying to acheave.
(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
)
)
)
-
CAB,
It has been a long time since I visited this one line topic.
Is there a way to modify the one line routine to utilize the "true" block name? I am using annotative/dynamic blocks now and the routine crashes when it encounters an anonymous block name.
I know this is a very old topic, I have started another job where I am utilizing this again.
Any help is appreciated.
Tim
-
Hello all,
I have attached a dwg file showing a fire alarm block I have created. It is dynamic and annotative.
The problem I am having is how to pass the "actual" block name to the one line creation tool and not the anonymous block name.
I have included (3) different dwg versions for convenience.
Basically what I do is...
Convert room names from blocks/dtext/mtext to a combined mtext of the room name
Layout the devices
Create the one line by picking a start point and then picking the block and it being added to the one line
Currently it does not select the room name, which would be a nice addition as I manually add this to the one line.
This would be a HUUUUUGE time saver for me.
If anyone can help me it would be greatly appreciated.
The attached code was created by CAB.
(defun c:ONELINE (/ DIMSC BLK1 BLKENT BLK2)
(INITERR)
(setvar "CMDECHO" 1)
(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 "FA-ANNO-ONELINE")
;;;
(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)
)
)
)
-
Make these additions
This needs to go above/below/within the lisp file.
This gets the block name of any block
selected_entity = (car (entsel)) so from your code (car BLK1).
Hope that all makes sense.
-
Dlanor,
Thanks for the response and I apologize for the delayed reply.
Unfortunately I am, and always have been, a hack when it comes to coding. Consequently I do not know how to add the code to the routine. I understand the vl-load-com part.
Thanks for the assistance