Help with a lisp

June 29, 2019

Hi I am using this lisp code to add dimensions to polygons .I need to update the code, to select multyple polygons without add duplicate dimension.

;******************************************************
(Defun C:qqAnnot (/ txtstl txtsze stryn prfx sufx svr scl ht pt pti ptx pty
                   old oldpl nodpl ptyp pllst i n prin meta distmeta ptdist
                   angprin angmeta angtxt ptp alfa nlin xlin ylin dlin flg 
                   xreg yreg na xa ya)
;*************drawing set-up***************************
;
   (command "undo" "m")
   (setvar "unitmode" 0)
   (setvar "aunits" 2)
   (setvar "angbase" (/ pi 2))
   (setvar "angdir" 1)
   (setvar "auprec" 4)
   (setvar "lunits" 2)
   (setvar "luprec" 3)
   (setvar "dimzin" 0)
 (setq svr(getvar "osmode"))
 (setq txtstl(getvar "textstyle"))
 (setq txtsze(getvar "textsize"))
 (setvar "cmdecho" 0)
 (setq flg 1)
 (setvar "cmdecho" 0)
 (command "_layer" "m" "_dimensions" "c" "93" "" "lw" "0.30" "" "")
:********BOUNDARY LINE**********
 (setvar "osmode" 0)
 (setq old(entsel "\n select lwpolyline: "))
 (setq oldpl(entget(car old)))
 (setq nodpl(cdr(assoc 90 oldpl)))
 (setq ptyp (cdr(assoc 70 oldpl)))
 (command "area" "e" old)
 (setq pllst '())
 (setq i 0)
 (setq n 0)
 (while (car(nth i oldpl))
        (if (= (car(nth i oldpl)) 10) 
               (progn
                     (setq pllst (append pllst (list (cdr(nth i oldpl)))))
                     (setq n(+ 1 n))
               );endprogn
        );endif
         (setq i (+ i 1))
 );endwhile
 (if (= ptyp 1)
   (progn
         (setq pllst (append pllst (list(nth 0 pllst))))
         (setq pllst (cdr pllst))
   );endprogn     
 );endif
; (main)
;);close defun
;(defun main()
;*******CIRCLES ON LANDMARKS***********
 (command "_.-style" "_diast" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "_no")
 (setq ht 1.75)
 (setq alfa 193)
 (command "circle" pt (/ ht 5))
 (command "copy" pt "" "m" pt)
 (foreach n pllst (command n))
 (command "")
 (command "erase" pt "")
 (setq i 0 prin 0 meta 0)
 (while (car(nth i pllst))
  (setq prin (- i 1))
  (setq meta (+ i 1))
    (if (= i 0)
               (setq prin (- n 1))
    )
    (if (= i (- n 1))
               (setq meta 0)
    )
  (setq angprin (angle (nth i pllst) (nth prin pllst)))
  (setq angmeta (angle (nth i pllst) (nth meta pllst)))
  (setq distmeta (distance (nth i pllst) (nth meta pllst)))
  
;**************DISTANCES BETWEEN LANDMARKS********************** 
  (setq ptdist (polar 
                     (polar (nth i pllst) angmeta (/ distmeta 2)) 
                     (+ angmeta (* (/ pi 2) flg)) (* 0.30 ht)))
  (setq angtxt(- 500 (/ (* 400 angmeta) (* 2 pi)))) 
   (if (> angtxt 400)
              (setq angtxt (- angtxt 400))
  )
  (if (> angtxt 200)
        (progn
              (setq ptdist (polar 
                                 (polar (nth i pllst) angmeta (/ distmeta 2)) 
                                 (+ angmeta (* (/ pi 2) flg)) (* 0.3 ht)))
              (setq angtxt (- angtxt 200))
        );endprogn
  )
  (command "_.-text" "_justify" "_mc" "_non" ptdist angtxt (rtos distmeta 2 2)) 


    (setq i (+ i 1))
 );endwhile
 (if (= ptyp 0)
               (command "erase" "l" "")
 )


;**********
; (initget "Yes No")
; (setq stryn(getkword "\nSatisfied? (Yes or No) :")) 
; (if (= stryn "Yes")
;     (ok)
; );end if
; (if (= stryn "No")
;     (progn
;           (command "undo" "b")
;           (command "undo" "m")
;           (setq flg(* -1 flg))
;           (main)
;     )
; );end if
; (ok)
;);close defun
;(defun ok ()
;*********END*********************************** 
 (setvar "osmode" svr)
 (setvar "cmdecho" 1)
 (setvar "textstyle" txtstl)
 (setvar "textsize"  txtsze)
(command "setvar" "clayer" "0") 
 (princ)
);close defun

Thanks

Edited June 29, 2019 by prodromosm

June 29, 2019

When you say dimension do you mean annotate each polyline segment with its length (no duplicates) or do you actually need a dimension?

Your lisp has a line getting an area. Do you need an area for each polyline and/or a total area? If so, is the hatched area also surrounded by a polyline?

The lisp is also drawing circles at each vertex, but the image doesn't show any. Do you require this?

Are any "open" polylines still deleted or do you only want to select closed polylines?

What about "open" polylines where the polyline has been drawn with the start point and end point the same (not closed but drawn closed)?

June 29, 2019

Hi dlanorh. ;

I mean annotate each polyline (open and close polylines) segment with its length (no duplicates) . I don't want the area

Thanks

June 30, 2019

OK

June 30, 2019

Try this. Let me know if you want any tweaks. It currently creates a layer, "_dimensions", asks for a selection set of lwpolylines and annotates each line (no duplicates), putting the text on layer "_dimensions". Text ht is 1.75 (can be user input if required). Text style is current text style.

;******************************************************
(defun c:qqannot (/ *error* sv_lst sv_vals c_doc c_spc c_lyrs t_ht n_lyr ss ent obj e_lst p_lst e_p seg dist t_ang i_pt t_lst t_obj)
;*************drawing set-up***************************
;
  (defun *error* ( msg )
	(mapcar 'setvar sv_lst sv_vals)
	(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
	(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
	(princ)
  );end_*error*_defun
	
  (setq sv_lst (list 'osmode 'cmdecho 'unitmode 'aunits 'angbase 'angdir 'auprec 'lunits 'luprec 'dimzin 'textstyle 'textsize 'clayer)
        sv_vals (mapcar 'getvar sv_lst)
        c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get c_doc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace))
        c_lyrs (vla-get-layers c_doc)
        t_ht 1.75
  );end_setq
  
  (mapcar 'setvar sv_lst (list 0 0 0 2 (/ pi 2.0) 1 4 2 3 0))
  (cond ( (not (tblsearch "layer" "_dimensions"))
          (setq n_lyr (vla-add c_lyrs "_dimensions"))
          (mapcar '(lambda (x y) (vlax-put-property n_lyr x y)) (list 'color 'lineweight) (list 93 0.3))
        )
  );end_cond
  
  (prompt "\nSelect Polylines : ")
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  
  (cond (ss
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          
          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (setq ent (ssname ss (setq cnt (1- cnt)))))
                  e_lst (entget ent)
                  p_lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) e_lst))
            );end_setq
            (cond ( (and (equal (car p_lst) (last p_lst) 0.001) (= :vlax-false (vlax-get-property obj 'closed))) 
                    (setq p_lst (reverse (cdr (reverse p_lst))))
                    (vlax-put obj 'coordinates (apply 'append p_lst))
                    (vlax-put-property obj 'closed :vlax-true)
                  )
            );end_cond
            (setq e_p (vlax-curve-getendparam ent)
                  seg 0.0
            );end_setq
            (while (< seg e_p)
              (setq dist (distance (vlax-curve-getpointatparam ent seg) (vlax-curve-getpointatparam ent (1+ seg)))
                    t_ang (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (+ seg 0.5)))
                    i_pt (vlax-curve-getpointatparam ent (+ seg 0.5))
                    seg (1+ seg)
              );end_setq
              
              (cond ( (< (/ pi 2.0) t_ang (* (/ pi 2.0) 3)) (setq t_ang (if (> t_ang pi) (- t_ang pi) (+ t_ang pi)))))
              
              (cond ( (not (vl-position i_pt t_lst))
                      (setq t_lst (cons i_pt t_lst)
                            t_obj (vla-addtext c_spc (rtos dist 2 3) (vlax-3d-point i_pt) t_ht)
                      );end_setq
                      (mapcar '(lambda (x y) (vlax-put-property t_obj x y)) (list 'rotation 'alignment 'textalignmentpoint 'layer) (list t_ang acAlignmentBottomCenter (vlax-3d-point i_pt) "_dimensions"))
                    )
              );end_cond
            );end_while
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))          
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

June 30, 2019

Hi dlanorh

I update the code to support annotate dimensions but i have problem with the text size. I want in paper space the text size 1.75 . I want to ask you somethig. if i select one polygon (open or close) and add dimensions and then i add another polygon and add dimension Is any way not to add duplicate dimesions ?

An something else. The perimetric dimension all the time must be inside the polygon

;******************************************************
(defun c:qqannot (/ *error* sv_lst sv_vals c_doc c_spc c_lyrs t_ht n_lyr ss ent obj e_lst p_lst e_p seg dist t_ang i_pt t_lst t_obj)
;*************drawing set-up***************************
;
  (defun *error* ( msg )
	(mapcar 'setvar sv_lst sv_vals)
	(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
	(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
	(princ)
  );end_*error*_defun
	
  (setq sv_lst (list 'osmode 'cmdecho 'unitmode 'aunits 'angbase 'angdir 'auprec 'lunits 'luprec 'dimzin 'textstyle 'textsize 'clayer)
        sv_vals (mapcar 'getvar sv_lst)
        c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get c_doc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace))
        c_lyrs (vla-get-layers c_doc)
        t_ht 1.75
  );end_setq
  
  (mapcar 'setvar sv_lst (list 0 0 0 2 (/ pi 2.0) 1 4 2 3 0))
  (command "_.-style" "_diast" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "_no")
  (cond ( (not (tblsearch "layer" "_dimensions"))
          (setq n_lyr (vla-add c_lyrs "_dimensions"))
          (mapcar '(lambda (x y) (vlax-put-property n_lyr x y)) (list 'color 'lineweight) (list 93 0.3))
        )
  );end_cond
  
  (prompt "\nSelect Polylines : ")
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  
  (cond (ss
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          
          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (setq ent (ssname ss (setq cnt (1- cnt)))))
                  e_lst (entget ent)
                  p_lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) e_lst))
            );end_setq
            (cond ( (and (equal (car p_lst) (last p_lst) 0.001) (= :vlax-false (vlax-get-property obj 'closed))) 
                    (setq p_lst (reverse (cdr (reverse p_lst))))
                    (vlax-put obj 'coordinates (apply 'append p_lst))
                    (vlax-put-property obj 'closed :vlax-true)
                  )
            );end_cond
            (setq e_p (vlax-curve-getendparam ent)
                  seg 0.0
            );end_setq
            (while (< seg e_p)
              (setq dist (distance (vlax-curve-getpointatparam ent seg) (vlax-curve-getpointatparam ent (1+ seg)))
                    t_ang (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (+ seg 0.5)))
                    i_pt (vlax-curve-getpointatparam ent (+ seg 0.5))
                    seg (1+ seg)
              );end_setq
              
              (cond ( (< (/ pi 2.0) t_ang (* (/ pi 2.0) 3)) (setq t_ang (if (> t_ang pi) (- t_ang pi) (+ t_ang pi)))))
              
              (cond ( (not (vl-position i_pt t_lst))
                      (setq t_lst (cons i_pt t_lst)
                            t_obj (vla-addtext c_spc (rtos dist 2 2) (vlax-3d-point i_pt) t_ht)
                      );end_setq
                      (mapcar '(lambda (x y) (vlax-put-property t_obj x y)) (list 'rotation 'alignment 'textalignmentpoint 'layer) (list t_ang acAlignmentBottomCenter (vlax-3d-point i_pt) "_dimensions"))
                    )
              );end_cond
            );end_while
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))          
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

Edited June 30, 2019 by prodromosm

June 30, 2019

1 hour ago, prodromosm said:

Hi dlanorh

I update the code to support annotate dimensions but i have problem with the text size. I want in paper space the text size 1.75 . I want to ask you somethig. if i select one polygon (open or close) and add dimensions and then i add another polygon and add dimension Is any way not to add duplicate dimesions ?

An something else. The perimetric dimension all the time must be inside the polygon

1. The lisp is currently set up so that you can select all the polygons at once into a selection set, as opposed to a loop to select one at a time.

2. Will look into text sizes

3. Will look at perimeter dimensions, shouldn't be difficult (kiss of death)

June 30, 2019

OK try Mk2 attached.

Things to note.

1. If you want the correct paper space height the lisp needs to be run in paper space through the required viewport. The viewport scale must have been set otherwise the text height will not be correct. If you change the scale of the viewport you will need to erase the text and re-run the lisp.

2. I don't have the stipulated text style font so I have changed it to romans.shx so I could test. You will need to change it back to your required font. Please note the comment at the end of the line as it will prevent error if you change the font to a *.ttf.

3. Perimeter text problem solved, but not as neatly as I would have like.

qqannot.lsp

June 30, 2019

when i run the lisp in paper space through the required viewport i have duplicate dimensions !!! I want to run the code through model space

Wgsimpl.shx

Edited June 30, 2019 by prodromosm

June 30, 2019

1 hour ago, prodromosm said:

when i run the lisp in paper space through the required viewport i have duplicate dimensions !!! I want to run the code through model space

I don't get duplicate dimensions unless I run the lisp multiple times, each time selecting a different polyline. You're supposed to select ALL the polylines at the same time to form a selection set as you asked in your first post. It won't work if you don't use it properly.

If you want to run it in model space then run it in model space, but the text won't be the correct height in paper space through a scaled viewport as model space scale is 1:1.

June 30, 2019

I select all boundaries one time and i have duplicate dimensions

June 30, 2019

Ok . Let me ask something else. Is any way to read all the text of the "_diast" text style and delete find the same texts and keep one of them or give you an option what text to delete?

Thanks

June 30, 2019

Maybe you can get better help, if you upload your sample.dwg , and all the task to do.

June 30, 2019

Here is my sample.dwg

sample.dwg

June 30, 2019

I will try to make a LISP to clean duplicate text at both side of each segment.

June 30, 2019

1 hour ago, prodromosm said:

Here is my sample.dwg

sample.dwg 142.81 kB · 1 download

This is a great help. For some reason the check for the mid point of each segment works on my test drawing but fails in yours. I've check the system vars I think could be affecting it but cannot find anything. I may have to try changing and resetting the units, or find another way of checking for a duplicate segment.

June 30, 2019

OK. I knew I had a snippet around that did this. Try the attached. This works on your drawing on my system, but takes a little longer.

qqannot2.lsp

June 30, 2019

is not working with the open polylines

June 30, 2019

Amended attached.

They lisp cannot know whether text is inside or outside an open polyline, because by its nature it is open. The attached now puts the distance text onto open polyline segments, but you'll have to move it if it is incorrect.

I'm too tired to think so I'm off to bed.

qqannot2.lsp

June 30, 2019

Have you looked at CIV3D labelling is built in.

Re duplicates could do a box ssget and look at what text is found if same as new do'nt create another.

Edited June 30, 2019 by BIGAL

Sign In

Help with a lisp

Recommended Posts

Guest

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Posted Images

dlanorh

Guest

dlanorh

dlanorh

Guest

dlanorh

dlanorh

Guest

dlanorh

Guest

Guest

devitg

Guest

devitg

dlanorh

dlanorh

Guest

dlanorh

BIGAL

Join the conversation

Tutorials

Forums

Activity