Jump to content

Split Level by Height

whosa

By whosa
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

whosa Enthusiast

whosa

Posted
Posted (edited)

Hi guys,

 

I received a DWG with 7800 levels like the picture attached.

 

Each level is composed by:

 

  • Label (Mtext) + Point. Both this 2 elements was placed whit the same Z value.

 

I need a lisp that split this Levels in 2 layers "by height".

 

The high value on the 1st layer (Top of the kerbs) and the low value on the 2nd layer (Bottom of the kerbs).

 

Someone can kelp me?

 

Many thanks.

 

 

 

 

road.JPG

Edited by whosa
dlanorh Mentor

dlanorh

Posted
Posted

Post a small sample drawing  (saved as AutoCAD 2010 or earlier for me) for testing etc.

dlanorh Mentor

dlanorh

Posted
Posted

OK. First attempt. This seems to work having tested in various orientations. You can set your own layers and colors for top of kerb and bottom of kerb in the user settings (setq)

 

(if the layers don't exist they are created and the color set)

 

It assumes all the MTEXT items are on layer LEVEL. There are no checks for matching pairs.

  

(defun c:tbk ( / *error* c_doc c_lyrs sv_lst sv_vals bok_lyr bc tok_lyr tc ss cnt ent elst typ i_pt lst aent bent)

  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
    (princ)
  );end_*error*_defun

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vlax-get-property c_doc 'layers)
        sv_lst (list 'cmdecho 'osmode)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq

;; User Settings
  (setq bok_lyr "Bottom_Kerb" bc 3 ;Bottom of Kerb Layer and color
        tok_lyr "Top_Kerb" tc 6    ;Top of Kerb Layer and color
  );end_setq

  (cond ( (not (tblsearch "layer" bok_lyr)) (vla-add c_lyrs bok_lyr) (vlax-put (vla-item c_lyrs bok_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tok_lyr)) (vla-add c_lyrs tok_lyr) (vlax-put (vla-item c_lyrs tok_lyr) 'color tc)))

  (setq ss (ssget "_X" '((0 . "MTEXT") (8 . "LEVEL"))))

  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq elst (entget (setq ent (ssname ss (setq cnt (1- cnt)))))
                  typ (cdr (assoc 0 elst))
                  lst (cons (list (cdr (assoc 10 elst)) ent) lst)
            );end_setq
          );end_repeat
          (setq i_pt (caar lst)
                lst (vl-sort lst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
          )
          (while lst
            (setq aent (cadr (car lst)) bent (cadr (cadr lst)) lst (cddr lst))
            (cond ( (> (atof (cdr (assoc 1 (entget aent)))) (atof (cdr (assoc 1 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bok_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tok_lyr)
                  )
            );end_cond
          );end_while
        )
        (t (alert "Nothing Found"))
  );end_cond

  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

  • Like 1
BIGAL Grand Master

BIGAL

Posted
Posted

If think people are heading in wrong direction to many years in CIVIL, if you look more carefully at the dwg there are 2 Field survey "Points" these have a Z value. Top and bottom of kerb.

 

The 1st step is what type of kerb just because there are 2 points does not reveal a kerb type in this case its around 150 so this for me would suggest a "B1"

 

ok some kerb types 

 

B1 Backofkerb, Faceofkerb, Bottomofkerb 150mm wide

B2 Backofkerb, Faceofkerb, Invert, Lipofkerb 450mm wide

 

The white line is a red herring and it basically is a line between the points so then end required result is two 3dlines joining the "Points", a solution is to walk along the white line looking for points then join lowest and highest at each location so get a true kerb.

 

If these points were say a csv then it would be possible to join them automatically if they have a "Code" attached to each point PNEZC is a typical csv.

 

Just need some time have some actual work to do 1st.

 

image.thumb.png.40a155dc6a32ae2c30aeef3021c99957.png

 

Ps some issues point surveyed order left and right may not be in same order so sort 2 lists X&Y must have 2 points else compare dist and stop as missing points.

  • Like 1
BIGAL Grand Master

BIGAL

Posted
Posted

To whosa does the whiteline exist for all kerbs etc or did you add it ? 

whosa Enthusiast

whosa

Posted
  • Author
Posted (edited)
8 hours ago, BIGAL said:

To whosa does the whiteline exist for all kerbs etc or did you add it ? 

 

yes,  I have a sigle pline on zero. I need to convert it in 3Dpoly

 

So, After split the levels in 2 layer I need to: 

 

  • move all this point (parallel) under the pline and after
  • connect with 2 different  pline, one for the top and one for the bottom of the kerbs

 

Very time consuming

Edited by whosa
whosa Enthusiast

whosa

Posted
  • Author
Posted
11 hours ago, dlanorh said:

OK. First attempt. This seems to work having tested in various orientations. You can set your own layers and colors for top of kerb and bottom of kerb in the user settings (setq)

 

(if the layers don't exist they are created and the color set)

 

It assumes all the MTEXT items are on layer LEVEL. There are no checks for matching pairs.

  


(defun c:tbk ( / *error* c_doc c_lyrs sv_lst sv_vals bok_lyr bc tok_lyr tc ss cnt ent elst typ i_pt lst aent bent)

  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
    (princ)
  );end_*error*_defun

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vlax-get-property c_doc 'layers)
        sv_lst (list 'cmdecho 'osmode)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq

;; User Settings
  (setq bok_lyr "Bottom_Kerb" bc 3 ;Bottom of Kerb Layer and color
        tok_lyr "Top_Kerb" tc 6    ;Top of Kerb Layer and color
  );end_setq

  (cond ( (not (tblsearch "layer" bok_lyr)) (vla-add c_lyrs bok_lyr) (vlax-put (vla-item c_lyrs bok_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tok_lyr)) (vla-add c_lyrs tok_lyr) (vlax-put (vla-item c_lyrs tok_lyr) 'color tc)))

  (setq ss (ssget "_X" '((0 . "MTEXT") (8 . "LEVEL"))))

  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq elst (entget (setq ent (ssname ss (setq cnt (1- cnt)))))
                  typ (cdr (assoc 0 elst))
                  lst (cons (list (cdr (assoc 10 elst)) ent) lst)
            );end_setq
          );end_repeat
          (setq i_pt (caar lst)
                lst (vl-sort lst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
          )
          (while lst
            (setq aent (cadr (car lst)) bent (cadr (cadr lst)) lst (cddr lst))
            (cond ( (> (atof (cdr (assoc 1 (entget aent)))) (atof (cdr (assoc 1 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bok_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tok_lyr)
                  )
            );end_cond
          );end_while
        )
        (t (alert "Nothing Found"))
  );end_cond

  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

 

Many thanks

 

On my pc i receive this error: 

  

Error: bad argument type: numberp: #<SUBR @000002797090e548 *ERROR*>

 

 

 

dlanorh Mentor

dlanorh

Posted
Posted
23 minutes ago, whosa said:

 

Many thanks

 

On my pc i receive this error: 

  


Error: bad argument type: numberp: #<SUBR @000002797090e548 *ERROR*>

 

 

 

 

Are you working in AutoCAD?

 

whosa Enthusiast

whosa

Posted
  • Author
Posted
8 minutes ago, dlanorh said:

 

Are you working in AutoCAD?

 

yes

dlanorh Mentor

dlanorh

Posted
Posted
2 hours ago, whosa said:

yes

 

I have retested this and cannot reproduce the error, which, according to your error message seems to stem from the local *error* function. What happens if you comment out the the entire *error* defun?

whosa Enthusiast

whosa

Posted
  • Author
Posted (edited)
2 hours ago, dlanorh said:

 

I have retested this and cannot reproduce the error, which, according to your error message seems to stem from the local *error* function. What happens if you comment out the the entire *error* defun?

 

Working. I delete all the comment and I get it work

 

  

(defun c:tbk ( / *error* c_doc c_lyrs sv_lst sv_vals bok_lyr bc tok_lyr tc ss cnt ent elst typ i_pt lst aent bent)

  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
    (princ)
  )

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vlax-get-property c_doc 'layers)
        sv_lst (list 'cmdecho 'osmode)
        sv_vals (mapcar 'getvar sv_lst)
  )


  (setq bok_lyr "Bottom_Kerb" bc 3 
        tok_lyr "Top_Kerb" tc 6
  )

  (cond ( (not (tblsearch "layer" bok_lyr)) (vla-add c_lyrs bok_lyr) (vlax-put (vla-item c_lyrs bok_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tok_lyr)) (vla-add c_lyrs tok_lyr) (vlax-put (vla-item c_lyrs tok_lyr) 'color tc)))

  (setq ss (ssget "_X" '((0 . "MTEXT") (8 . "LEVEL"))))

  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq elst (entget (setq ent (ssname ss (setq cnt (1- cnt)))))
                  typ (cdr (assoc 0 elst))
                  lst (cons (list (cdr (assoc 10 elst)) ent) lst)
            )
          )
          (setq i_pt (caar lst)
                lst (vl-sort lst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
          )
          (while lst
            (setq aent (cadr (car lst)) bent (cadr (cadr lst)) lst (cddr lst))
            (cond ( (> (atof (cdr (assoc 1 (entget aent)))) (atof (cdr (assoc 1 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bok_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tok_lyr)
                  )
            )
          )
        )
        (t (alert "Nothing Found"))
  )

  (mapcar 'setvar sv_lst sv_vals)
  (princ)
)

 

 

 

 

 

Edited by whosa
whosa Enthusiast

whosa

Posted
  • Author
Posted (edited)

@dlanorh 

 

This lisp work well but it has 2 problems:

 

  1. I need to apply the lisp only on selected object. Fixed: 
(setq ss (ssget '((0 . "MTEXT") (8 . "LEVEL"))))

 

       2. The "Point" remain on Point Layer.  I would like to split the point as well. Maybe in separate layer as well Point_Top_Kerbs and Point_Bottom_Kerbs

 

You think It will be possible?

 

Many thanks for you time

Edited by whosa
dlanorh Mentor

dlanorh

Posted
Posted
1 hour ago, whosa said:

@dlanorh 

 

This lisp work well but it has 2 problems:

 

  1. I need to apply the lisp only on selected object. Fixed: 

(setq ss (ssget '((0 . "MTEXT") (8 . "LEVEL"))))

 

       2. The "Point" remain on Point Layer.  I would like to split the point as well. Maybe in separate layer as well Point_Top_Kerbs and Point_Bottom_Kerbs

 

You think It will be possible?

 

Many thanks for you time

 

OK, I wondered if that would be the case. Should have something later.

dlanorh Mentor

dlanorh

Posted
Posted

OK. Amended Lisp. I've removed the local  *error* and adjusted the ssget. Tested and working on your test drawing. As before you can adjust the text and point layers in the User Settings (setq). The same color is used for the bottom text and points (3) and the top text and points (6)

  

(defun c:tbk ( / c_doc c_lyrs sv_lst sv_vals bok_lyr bc tok_lyr tc bkp_lyr tkp_lyr ss cnt ent elst typ i_pt tlst plst aent bent)

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vlax-get-property c_doc 'layers)
        sv_lst (list 'cmdecho 'osmode)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq

;; User Settings
  (setq bok_lyr "Bottom_Kerb" bc 3  ;Bottom of Kerb Layer and color
        tok_lyr "Top_Kerb" tc 6     ;Top of Kerb Layer and color
        bkp_lyr "Kerb_Point_Top"    ;Top of Kerb Point Layer
        tkp_lyr "Kerb_Point_Bottom" ;Bottom of Kerb Point Layer
  );end_setq

  (cond ( (not (tblsearch "layer" bok_lyr)) (vla-add c_lyrs bok_lyr) (vlax-put (vla-item c_lyrs bok_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tok_lyr)) (vla-add c_lyrs tok_lyr) (vlax-put (vla-item c_lyrs tok_lyr) 'color tc)))
  (cond ( (not (tblsearch "layer" bkp_lyr)) (vla-add c_lyrs bkp_lyr) (vlax-put (vla-item c_lyrs bkp_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tkp_lyr)) (vla-add c_lyrs tkp_lyr) (vlax-put (vla-item c_lyrs tkp_lyr) 'color tc)))

  (setq ss (ssget '((0 . "POINT,MTEXT") (8 . "POINT,LEVEL"))))

  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq elst (entget (setq ent (ssname ss (setq cnt (1- cnt)))))
                  typ (cdr (assoc 0 elst))
            );end_setq
            (if (= typ "POINT") (setq plst (cons (list (cdr (assoc 10 elst)) ent) plst)) (setq tlst (cons (list (cdr (assoc 10 elst)) ent) tlst)))
          );end_repeat
          (setq i_pt (caar tlst)
                tlst (vl-sort tlst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
                plst (vl-sort plst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
          );end_setq
          (while tlst
            (setq aent (cadr (car tlst)) bent (cadr (cadr tlst)) tlst (cddr tlst))
            (cond ( (> (atof (cdr (assoc 1 (entget aent)))) (atof (cdr (assoc 1 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bok_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tok_lyr)
                  )
            );end_cond
          );end_while
          (while plst
            (setq aent (cadr (car plst)) bent (cadr (cadr plst)) plst (cddr plst))
            (cond ( (> (caddr (cdr (assoc 10 (entget aent)))) (caddr (cdr (assoc 10 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tkp_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bkp_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bkp_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tkp_lyr)
                  )
            );end_cond
          );end_while
        )
        (t (alert "Nothing Found"))
  );end_cond

  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

  • Thanks 1
whosa Enthusiast

whosa

Posted
  • Author
Posted
10 minutes ago, dlanorh said:

OK. Amended Lisp. I've removed the local  *error* and adjusted the ssget. Tested and working on your test drawing. As before you can adjust the text and point layers in the User Settings (setq). The same color is used for the bottom text and points (3) and the top text and points (6)

  


(defun c:tbk ( / c_doc c_lyrs sv_lst sv_vals bok_lyr bc tok_lyr tc bkp_lyr tkp_lyr ss cnt ent elst typ i_pt tlst plst aent bent)

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vlax-get-property c_doc 'layers)
        sv_lst (list 'cmdecho 'osmode)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq

;; User Settings
  (setq bok_lyr "Bottom_Kerb" bc 3  ;Bottom of Kerb Layer and color
        tok_lyr "Top_Kerb" tc 6     ;Top of Kerb Layer and color
        bkp_lyr "Kerb_Point_Top"    ;Top of Kerb Point Layer
        tkp_lyr "Kerb_Point_Bottom" ;Bottom of Kerb Point Layer
  );end_setq

  (cond ( (not (tblsearch "layer" bok_lyr)) (vla-add c_lyrs bok_lyr) (vlax-put (vla-item c_lyrs bok_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tok_lyr)) (vla-add c_lyrs tok_lyr) (vlax-put (vla-item c_lyrs tok_lyr) 'color tc)))
  (cond ( (not (tblsearch "layer" bkp_lyr)) (vla-add c_lyrs bkp_lyr) (vlax-put (vla-item c_lyrs bkp_lyr) 'color bc)))
  (cond ( (not (tblsearch "layer" tkp_lyr)) (vla-add c_lyrs tkp_lyr) (vlax-put (vla-item c_lyrs tkp_lyr) 'color tc)))

  (setq ss (ssget '((0 . "POINT,MTEXT") (8 . "POINT,LEVEL"))))

  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq elst (entget (setq ent (ssname ss (setq cnt (1- cnt)))))
                  typ (cdr (assoc 0 elst))
            );end_setq
            (if (= typ "POINT") (setq plst (cons (list (cdr (assoc 10 elst)) ent) plst)) (setq tlst (cons (list (cdr (assoc 10 elst)) ent) tlst)))
          );end_repeat
          (setq i_pt (caar tlst)
                tlst (vl-sort tlst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
                plst (vl-sort plst '(lambda (x y) (< (distance i_pt (car x)) (distance i_pt (car y)))))
          );end_setq
          (while tlst
            (setq aent (cadr (car tlst)) bent (cadr (cadr tlst)) tlst (cddr tlst))
            (cond ( (> (atof (cdr (assoc 1 (entget aent)))) (atof (cdr (assoc 1 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bok_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bok_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tok_lyr)
                  )
            );end_cond
          );end_while
          (while plst
            (setq aent (cadr (car plst)) bent (cadr (cadr plst)) plst (cddr plst))
            (cond ( (> (caddr (cdr (assoc 10 (entget aent)))) (caddr (cdr (assoc 10 (entget bent)))))
                    (vlax-put (vlax-ename->vla-object aent) 'layer tkp_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer bkp_lyr)
                  )
                  (t
                    (vlax-put (vlax-ename->vla-object aent) 'layer bkp_lyr)
                    (vlax-put (vlax-ename->vla-object bent) 'layer tkp_lyr)
                  )
            );end_cond
          );end_while
        )
        (t (alert "Nothing Found"))
  );end_cond

  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

 

What can I say.... THANKSSSSS!!!!!!!!!!!!. You are a genius. 

 

This lisp will save hours of works.

 

Many thanks again for your help. 

 

 

dlanorh Mentor

dlanorh

Posted
Posted
46 minutes ago, whosa said:

 

What can I say.... THANKSSSSS!!!!!!!!!!!!. You are a genius. 

 

This lisp will save hours of works.

 

Many thanks again for your help. 

 

 

 

No problem. 👍

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...