Complex lisp?

December 29, 2012

Hello friends.

I'am using ProgeCad 2011 and I'am working on Lisp which will save my nerves, but I would not save a lot of time with it becouse I know how to use qselect function. I am new in programing cad lisp so I need your help.

The lisp should:

flatten all objects and point's (Z=0);

change text height (Layer1) to 0.3;

change text height (Layer2) to 0.1;

change text height (Layer3) to 0.3;

move text(Layer1) from its original position for some distance(eg. 20) in some direction (eg. 285°);

move text(Layer2) from its original position for some distance(eg. 30) in some direction (eg. 265°);

move text(Layer3) from its original position for some distance(eg. 40) in some direction (eg. 275°);

round text(=numbers) (Layer3) from three to two decimal places and than turn off that layer (Layer3).

And if it possible to take one layer(Layer4) and explode it and then delete layer(Layer4).

I hope you understand what I write

Any suggestion or code I would appreciate it.

Thanks in advanced.

December 29, 2012

I made mistake: "and explode it and then delete layer(Layer4)", it should be: "and explode it and then delete layer(Layer5)"...

If someone know just one of this functions You can also write them...

December 30, 2012

You need to read up on SSGET and FOREACH

 (setq ss1 (ssget "x" '((2 . "text,mtext")(8 . "LAYER1"))))
this picks all text on layer1 you hen step through and modify the text parameters

It probably best done with VL just looking for example.

Edited December 30, 2012 by BIGAL
layer fixed

December 30, 2012

Bigal , there is not any entity type called LAYER (0 . "LAYER")

December 30, 2012

The only complex part of your request is flatten all objects and point's (Z=0);. especially with a "not parallel to the UCS" entities.

The rest is easy.

December 30, 2012

Thanks to everyone who responded.

For flatten all objects and point's (Z=0) I found:

(command "_change""_all""""p""e""0""")
(command "_move""_all""""""0,0,1e99""_move""_all""""""0,0,-1e99")

and that works for me, but I think it could be a cleaner code but do not know how it should look like.

I found a solution on how to move text and delete layer.

Now I have to found a solution to change text height based on its layer and round text(=numbers) (Layer3) from three to two decimal places and than turn off that layer (Layer3).

December 30, 2012

maybe something like:

     (if (setq sst (ssget "_X" '((0 . "TEXT") (8 . "layer1"))))
(progn
  (command "_.move" sst "" "0,0,0" "\@20\<285")
  (setq itm 0
 num (sslength sst)
  )
  (while (< itm num)
    (setq ent (ssname sst itm)
          obj (vlax-ename->vla-object ent))
    (vlax-put-property obj 'HEIGHT 0.3)
    (setq itm (1+ itm))
  );; while
);; progn
     );; if 
     (if (setq sst (ssget "_X" '((0 . "TEXT") (8 . "layer2"))))
(progn
  (command "_.move" sst "" "0,0,0" "\@30\<265")
  (setq itm 0
 num (sslength sst)
  )
  (while (< itm num)
    (setq ent (ssname sst itm)
          obj (vlax-ename->vla-object ent))
    (vlax-put-property obj 'HEIGHT 0.1)
    (setq itm (1+ itm))
  );; while
);; progn
     );; if 
     (if (setq sst (ssget "_X" '((0 . "TEXT") (8 . "layer3"))))
(progn
  (command "_.move" sst "" "0,0,0" "\@40\<275")
  (setq itm 0
 num (sslength sst)
  )
  (while (< itm num)
    (setq ent (ssname sst itm)
          obj (vlax-ename->vla-object ent))
    (vlax-put-property obj 'HEIGHT 0.3)
    (setq entlst (entget ent)
          txtold (cdr (assoc 1 entlst)))
    (if (distof txtold)
      (progn
 (setq txtnw (rtos (atof txtold) 2 2)
       entlst
        (subst (cons 1 txtnw) (assoc 1 entlst) entlst)
 )
 (entmod entlst)
      )
    );; if
    (setq itm (1+ itm))
  );; while
);; progn
     );; if

Henrique

December 30, 2012

(defun c:demo ( / data ss cur e ent p)
[color="blue"](defun _sub (d v en)
     (subst (cons d v)(assoc d en) en))[/color]
(setq data '(("LAYER1" 0.3 285 20 )
     ("LAYER2" 0.1 265 30 )
     ("LAYER3" 0.3 275 40 )
     ("LAYER4")("LAYER5")))
(if (setq ss (ssget [b][color="blue"]"_X"[/color][/b] (list '(0 . "TEXT")
		    (cons 8 (apply 'strcat  (mapcar (function (lambda (j)
			    (strcat (car j) ","))) data)))
		    '(1 . "*#*"))))
(repeat (sslength ss)
  	[color="blue"](setq e (ssname ss 0) ent (entget e))[/color]
        (setq cur (assoc (strcase (cdr (assoc 8 ent))) data))
  (cond
    ((cdr cur)                            
      [color="blue"] (setq ent (entmod (_sub 40 (cadr cur) ent))
             ent (entmod (_sub 10 (polar (cdr (assoc 10 ent))
                      (* pi (/ (caddr cur) 180.0)) (last cur)) ent)))
       (if (eq (car cur) (car (nth 2 data)))
           	(setq ent (entmod (_sub 1 (rtos (read (cdr (assoc 1 ent))) 2 2) ent)))[/color]
           )
       )

   [color="red"] ;;;; other options ;;;;;
    
    ;;; Layer4
    ;;; i'm at lost at the last part
    ;;; explode? does that mean its a block?

    ;;;	Layer5
    ;;;	Delete Layer regardless of entity type?
    
    ;;; other options	;;;[/color]
    )
(ssdel (ssname ss 0) ss)
    )
 )
     (princ)
 )

to be continued....

EDIT: Non ActiveX code

Edited December 31, 2012 by pBe
Vanilla version

December 30, 2012

Becouse I don't have so much knowledge and understanding like you have, I build this program part by part, more lisps in one lisp, also because ProgeCad who may not support all the functions such AutoCad. So far i resolved problem for: moving text, flatten all objects and point's, take one layer and explode it and then delete another layer.

Henrique, when I take a part of your code and run it, it moves text but not changing height; ProgeCad returns an error at "(vlax-ename->vla-object ent)", maybe I run it wrong.

And there is problem with rounding numbers.

Can we write something like this (and also for text height):

(setq n (ssget "X" ' ((8 . "Layer3"))))
(rtos n 2 2)

This code doesn't work.

I haven't mentioned that each layers contains only one type (information about point) of text and nothing else. Layer3 contains only numbers.

Thx for support. At the end I will paste the code witch works for me.

December 30, 2012

Sivke,

I've never worked with progeCAD, can you post the error you get with the vlax-ename-> ...

Henrique

December 30, 2012

Sivke,

try this code:

(defun c:test (/ sst itm num ent entlst txtold txtnw)
 (if (setq sst (ssget "_X" '((0 . "TEXT") (8 . "layer1"))))
   (progn
     (command "_.move" sst "" "0,0,0" "\@20\<285")
     (setq itm 0
    num (sslength sst)
     )
     (while (< itm num)
(setq ent    (ssname sst itm)
      entlst (entget ent)
      entlst
      (subst (cons 40 0.3) (assoc 40 entlst) entlst)
)
(entmod entlst)
(setq itm (1+ itm))
     );; while
   );; progn
 );; if 
 (if (setq sst (ssget "_X" '((0 . "TEXT") (8 . "layer2"))))
   (progn
     (command "_.move" sst "" "0,0,0" "\@30\<265")
     (setq itm 0
    num (sslength sst)
     )
     (while (< itm num)
(setq ent    (ssname sst itm)
      entlst (entget ent)
      entlst
      (subst (cons 40 0.1) (assoc 40 entlst) entlst)
)
(entmod entlst)
(setq itm (1+ itm))
     );; while
   );; progn
 );; if 
 (if (setq sst (ssget "_X" '((0 . "TEXT") (8 . "layer3"))))
   (progn
     (command "_.move" sst "" "0,0,0" "\@40\<275")
     (setq itm 0
    num (sslength sst)
     )
     (while (< itm num)
(setq ent    (ssname sst itm)
      entlst (entget ent)
      entlst
      (subst (cons 40 0.3) (assoc 40 entlst) entlst)
)
(entmod entlst)
(setq entlst (entget ent)
      txtold (cdr (assoc 1 entlst))
)
(if (distof txtold)
  (progn
    (setq txtnw  (rtos (atof txtold) 2 2)
   entlst
   (subst (cons 1 txtnw) (assoc 1 entlst) entlst)
    )
    (entmod entlst)
  )
);; if
(setq itm (1+ itm))
     );; while
   );; progn
 );; if 
);; defun

Henrique

December 30, 2012

Thanks Tharwat fixed write stuff of the top of my head sometimes.

Just a suggestion another approach would be to make a list of the 4 parts to be searched and changed (("TEXT" "layer1" "\@30\

December 31, 2012

.... take one layer and explode it and then delete another layer....

Code updated : Chocolate to Vanilla

I still don't get the explode [Layer4], are these blocks?

and "delete another layer" [Layer5]... are you wanting to delete entities on this layer and remove "layer5" from layer table?

Dry run

(defun c:demo ( / data ss cur e name p cur)
(defun _sub (d v en)
     (subst (cons d v)(assoc d en) en))
(setq data '(("LAYER1" 0.3 285 20 )
     ("LAYER2" 0.1 265 30 )
     ("LAYER3" 0.3 275 40 )
     ("LAYER4")("LAYER5")))
(if (setq ss [color="blue"](ssget "_X" (list '(-4 . "<OR")
            (cons 8 (car (last data)))
            '(-4 . "<AND") '(0 . "INSERT")
            (cons 8 (car (cadddr data)))
            '(-4 . "AND>") '(-4 . "<AND")
            '(0 . "TEXT")
            (cons 8
                  (strcat (caar data) ","
                          (caadr data) ","
                          (caaddr data)
                          ) ;_ end of strcat
                  ) ;_ end of cons
            '(-4 . "AND>") '(-4 . "OR>")
            ) ;_ end of list
      )[/color])
(repeat (sslength ss)
  	(setq e (ssname ss 0) ent (entget e))
    [color="blue"](setq cur (assoc (strcase (cdr (assoc 8 ent))) data)
               name (car cur))[/color]
  (cond
    ((cdr cur)                            
       (setq ent (entmod (_sub 40 (cadr cur) ent))
             ent (entmod (_sub 10 (polar (cdr (assoc 10 ent))
                      (* pi (/ (caddr cur) 180.0)) (last cur)) ent)))
       (if (and (eq name (caaddr data))
                [color="blue"](numberp (setq num (read (cdr (assoc 1 ent))))))
           	(setq ent (entmod (_sub 1 (rtos num 2 2) ent)))[/color]
           )
       )
   [color="blue"]  ((eq name (car (cadddr data)))
      				(command _."Explode" e)
    	)
     ((eq name (car (last data)))
      				(entdel e)
    	)
     )[/color]
  (ssdel (ssname ss 0) ss)
    )
 )
     (princ)
 )

Selection mode: EDIT

Numerical Text entities on "Layer1,Layer2,Layer3"

Blocks on "Layer4"

All Entities on "Layer5"

Edited December 31, 2012 by pBe

January 2, 2013

Sorry for not responding, I am currently on the trip.

Sign In

Complex lisp?

Recommended Posts

Sivke

Sivke

BIGAL

Tharwat

pBe

Sivke

hmsilva

pBe

Sivke

hmsilva

hmsilva

BIGAL

pBe

Sivke

Join the conversation

Tutorials

Forums

Activity