Block dissolving object's scaling and then back to block

[dani]

Hello!

I hava lisp whith disolve a block, and than I can edit it.

I will skale it and make it back to a block.

By skaling the block lisp brake down.

(defun c:eb ( / wucs)
                         
  (setq wucs (getvar "WORLDUCS"))                 ; if it is not at WORLD UCS
  (if (= wucs 0)
     (command "_UCS" "W")                          ; set it to WORLD
  ); end if
  (if G_blname                                    ; if this variable exists 
     (redefinebl)                                 ; redfine the previously edited block
     (editbl)                                     ; otherwise edit a block
  ); end if
  (if (= wucs 0)                                  ; if it was not at WORLD UCS
     (command "_UCS" "v")                          ; set it to the previous UCS
  ); end if
  (princ)
)

; error trapping - clears toggle variable on error or cancel
; the only trouble is that the "undo" command does not clear the toggle as well!

(defun traperr (s)
 (if (or (/= s "Function cancelled")(= s "quit / exit abort") )
   (progn 
      (if G_blname 
         (progn
            (setq G_blname nil)

         ); end progn
      ); end if 
      (setq G_pt nil) 
      (princ)
   ); end progn   
   (princ (strcat "\nError: " s))
 )
) ;end traperr

(defun editbl (/ ent entl pt pt1 b)
 (setq temperr *error*)
 (setq *error* traperr)
 (setq ent nil)                                   ; initialise
 (while (= ent nil)                               ; loop till a block is chosen
   (while (= ent nil)                             ; loop to stop user clicking off the target entity and causing an error
     (setq ent (entsel "\nWählen Sie einen Block zum Bearbeiten")) ; Sets ent to the selected entity
     (if (= ent nil) (prompt "\nKein Objekt gewählt, versuchen Sie es nochmals.")) 
   ); end while
   (setq entl (entget (car ent)))                 ; Sets entl to the selected entity's association list of the chosen 

entity
   (setq b (cdr (assoc 0 entl)))                  ; finds the entity type
   (setq pt1 (cdr (assoc 10 entl)))               ; finds the insertion point
   (if (/= b "INSERT")
      (progn
        (setq ent nil)                            ; re-set if not a block to loop again
        (prompt "\nDas ist kein Block.")
      ); end progn
   )            
 ); end while
 (setq G_blname (cdr (assoc 2 entl)))             ; finds the block name & puts it in a global variable
 (setq pt (GETPOINT pt1 "\nCopy des Blocks für Bearbeitung: "))
 (command "_INSERT" G_blname pt 1.0 0.0 0.0)           ; inserts the block again for redefining
 (setq ent (entlast))                             ; Sets en to the name of the last entity in the drawing 
 (setq entl (entget ent))                         ; Sets ed to the entity data of entity ent 
 (setq G_pt (cdr (assoc 10 entl)))                ; finds the insertion point & puts it in a global variable
 (command "_EXPLODE" "_L" "")                     ; explodes this last entity
 (alert (strcat"\nDiese Copy vom \"" G_blname "\" würde Aufgelöst.\nRe-type: <EB> eingeben um den Block neu zu definieren nach Bearbeiten"))
 ;;(command "_scale")
 (setq *error* temperr)
 (princ)
); program ends

(defun redefinebl ()
 (setq temperr *error*)
 (setq *error* traperr)
 (command "_-Block" G_blname "_y" G_pt)              ; the "Y" is because the commands asks if you want to re-define the block
 (setq G_blname nil)                              ; set to nil as this is used as a redefine/edit toggle
 (setq G_pt nil)                                  ; set to nil to free up memory
 (setq *error* temperr)
)

Can you help me?

[JohnM]

i do not understand the need for a lisp here

can you not just scale the block in autocad?

[dani]

i do not understand the need for a lisp here

can you not just scale the block in autocad?

 

 

I will scale my blocks without changing the factor 1

when I scale the block in autocad for example I take 10 then the factor is also 10 but I want 1

(because I must change the size of 400 blocks but the factor should be 1)

[JohnM]

are the 400 blocks in the same drawing?

[JohnM]

I’m not sure exactly what you are looking for but this is a step in the right direction.

It is as simple as it can get and can be easily modified.

 

[font=Times New Roman][font=Times New Roman](defun c:blsc (/ ss sslnt cnt nentlst entn ent blnam inpt plst)[/font]
[font=Times New Roman](setq ss (ssget "_x" '((0 . "insert")(410 . "Model") )))[/font]
[font=Times New Roman](setq sslnt (sslength ss))[/font]
[font=Times New Roman](setq cnt 0)[/font]
[font=Times New Roman](while (< cnt sslnt)[/font]
[font=Times New Roman](setq entn (ssname ss cnt));_entity name[/font]
[font=Times New Roman](setq ent(entget entn));_entity list[/font]
[font=Times New Roman] (setq blnam (cdr(assoc 2 ent)));_block name[/font]
[font=Times New Roman](setq inpt (cdr (assoc 10 ent)));_insert pt[/font]
[font=Times New Roman](command "scale" entn "" inpt 10);_scale block[/font]
[font=Times New Roman](setq plst (gtbox entn));_call to get bounging bos points[/font]
[font=Times New Roman](command "explode" entn);_explode block[/font]
[font=Times New Roman](setq nentlst (ssget "_W" (nth 0 plst)(nth 1 plst)));_all entities in the block[/font]
[font=Times New Roman](command "-block" blnam "Y" inpt nentlst "");_remake block[/font]
[font=Times New Roman](command "insert" blnam inpt "" "" "")[/font]
[font=Times New Roman](setq cnt (1+ cnt))[/font]
[font=Times New Roman]);_while[/font]
[font=Times New Roman]  );_defun[/font]
[font=Times New Roman](defun gtbox (aug1 / rect llc urc ) [/font]
[font=Times New Roman](vla-GetBoundingBox (vlax-ename->vla-object aug1) 'minpt 'maxpt);_check for heigth /width[/font]
[font=Times New Roman](setq[/font]
[font=Times New Roman]llc (vlax-safearray->list minpt)[/font]
[font=Times New Roman]urc (vlax-safearray->list maxpt)[/font]
[font=Times New Roman]);_setq[/font]
[font=Times New Roman](setq trlst (list urc llc));_return upper right and lower left corners[/font]
[font=Times New Roman]  );_defun[/font]
[/font]

[dani]

Hallo John M

Scale x =1

Scale y=1

1. Block Explode

2. Scale 10

3. again Block

Scale x=1

Scaley=1

 

[/code]

(defun c:blsc (/ ss sslnt cnt nentlst entn ent blnam inpt plst)

(setq ss (ssget))

(setq sslnt (sslength ss))

(setq cnt 0)

(while (

(setq entn (ssname ss cnt));_entity name

(setq ent(entget entn));_entity list

(setq blnam (cdr(assoc 2 ent)));_block name

(setq inpt (cdr (assoc 10 ent)));_insert pt

(command "_explode" entn);_explode block

(setq nentlst (ssget "_W" (nth 0 plst)(nth 1 plst)));_all entities in the block

(setq plst (gtbox entn));_call to get bounging bos points

(command "_scale" entn "" inpt 10);_scale block

(command "_block" blnam "Y" inpt nentlst "");_remake block

(command "_insert" blnam inpt "" "" "")

(setq cnt (1+ cnt))

);_while

);_defun

(defun gtbox (aug1 / rect llc urc )

(vla-GetBoundingBox (vlax-ename->vla-object aug1) 'minpt 'maxpt);_check for heigth /width

(setq

llc (vlax-safearray->list minpt)

urc (vlax-safearray->list maxpt)

);_setq

(setq trlst (list urc llc));_return upper right and lower left corners

);_defun

[/code]

 

danke

[JohnM]

your call to gtbox should be above the (setq nentlst) because it returns the points used by setq nentlst

[dani]

your call to gtbox should be above the (setq nentlst) because it returns the points used by setq nentlst

 

Hallo JohnM

Will not out

The following error message

Befehl: ; Fehler: Fehlerhafter Argumenttyp: VLA-OBJECT nil

 

(defun c:blsc (/ ss sslnt cnt nentlst entn ent blnam inpt plst)
(vl-load-com)
(setq ss (ssget))
(setq sslnt (sslength ss))
(setq cnt 0)
(while (< cnt sslnt)
(setq entn (ssname ss cnt));_entity name
(setq ent(entget entn));_entity list
(setq blnam (cdr(assoc 2 ent)));_block name
(setq inpt (cdr (assoc 10 ent)));_insert pt
(setq plst (gtbox entn));_call to get bounging bos points
(command "_explode" entn);_explode block
(setq nentlst (ssget "_W" (nth 0 plst)(nth 1 plst)));_all entities in the block
(command "_scale" nentlst "" inpt 10);_scale block
(command "_block" blnam "Y" inpt nentlst "");_remake block
(command "_insert" blnam inpt "" "" "")
(setq cnt (1+ cnt))
);_while
);_defun


(defun gtbox (aug1 / rect llc urc )
(vla-GetBoundingBox (vlax-ename->vla-object aug1) 'minpt 'maxpt);_check for heigth /width
(setq
llc (vlax-safearray->list minpt)
urc (vlax-safearray->list maxpt)
);_setq
(setq trlst (list urc llc));_return upper right and lower left corners
);_defun

 

 

Thanks Thanks

[dani]

Hallo JohnM

 

Does it

 

(defun c:blsc (/ ss sslnt cnt nentlst entn ent blnam inpt plst)

(vl-load-com)

(setq ss (ssget))

(setq sslnt (sslength ss))

(setq cnt 0)

(while (

(setq entn (ssname ss cnt));_entity name

(setq ent(entget entn));_entity list

(setq blnam (cdr(assoc 2 ent)));_block name

(setq plst (gtbox entn));_call to get bounging bos points

(setq inpt (cdr (assoc 10 ent)));_insert pt

(command "_explode" entn);_explode block

(setq nentlst (ssget "_W" (nth 0 plst)(nth 1 plst)));_all entities in the block

(command "_scale" nentlst "" inpt 2);_scale block

(command "_block" blnam "j" inpt nentlst "");_remake block

(command "_insert" blnam inpt "" "" "")

(setq cnt (1+ cnt))

);_while

);_defun

 

 

(defun gtbox (aug1 / rect llc urc )

(vla-GetBoundingBox (vlax-ename->vla-object aug1) 'minpt 'maxpt);_check for heigth /width

(setq

llc (vlax-safearray->list minpt)

urc (vlax-safearray->list maxpt)

);_setq

(setq trlst (list urc llc));_return upper right and lower left corners

);_defun

 

 

 

1000 x Thanks Thanks

[JohnM]

THIS WORKS FINE ON MY MACHINE

I FORGOT TO KILL THE VARAIBLE trlst IN THE GTBOX DEFUN

THY THIS ONE ANF LET ME KNOW

 

 
(defun c:blsc (/ ss sslnt cnt nentlst entn ent blnam inpt plst)
(vl-load-com)
(setq ss (ssget))
(setq sslnt (sslength ss))
(setq cnt 0)
(while (< cnt sslnt)
(setq entn (ssname ss cnt));_entity name
(setq ent(entget entn));_entity list
(setq blnam (cdr(assoc 2 ent)));_block name
(setq inpt (cdr (assoc 10 ent)));_insert pt
(setq plst (gtbox entn));_call to get bounging bos points
(command "_explode" entn);_explode block
(setq nentlst (ssget "_W" (nth 0 plst)(nth 1 plst)));_all entities in the block
(command "_scale" nentlst "" inpt 10);_scale block
(command "_block" blnam "Y" inpt nentlst "");_remake block
(command "_insert" blnam inpt "" "" "")
(setq cnt (1+ cnt))
);_while
);_defun

(defun gtbox (aug1 / rect llc urc trlst ) 
(vla-GetBoundingBox (vlax-ename->vla-object aug1) 'minpt 'maxpt);_check for heigth /width
(setq
llc (vlax-safearray->list minpt)
urc (vlax-safearray->list maxpt)
);_setq
(setq trlst (list urc llc));_return upper right and lower left corners
);_defun

[dani]

Hallo JohnM

 

Does it

(defun c:blsc (/ ss sslnt cnt nentlst entn ent blnam inpt plst)
 (vl-load-com)
(setq ss (ssget))
(setq sslnt (sslength ss))
(setq cnt 0)
(while (< cnt sslnt)
(setq entn (ssname ss cnt));_entity name
(setq ent(entget entn));_entity list
(setq blnam (cdr(assoc 2 ent)));_block name
(setq plst (gtbox entn));_call to get bounging bos points
 (setq inpt (cdr (assoc 10 ent)));_insert pt
 (command "_explode" entn);_explode block
 (setq nentlst (ssget "_W" (nth 0 plst)(nth 1 plst)));_all entities in the block
 (command "_scale" nentlst "" inpt 2);_scale block
 (command "_block" blnam "j" inpt nentlst "");_remake block
 (command "_insert" blnam inpt "" "" "")
(setq cnt (1+ cnt))
);_while
);_defun


(defun gtbox (aug1 / rect llc urc )
(vla-GetBoundingBox (vlax-ename->vla-object aug1) 'minpt 'maxpt);_check for heigth /width
(setq
llc (vlax-safearray->list minpt)
urc (vlax-safearray->list maxpt)
);_setq
(setq trlst (list urc llc));_return upper right and lower left corners
);_defu

 

 

 

1000 x Thanks Thanks