whosa Posted April 25, 2020 Share Posted April 25, 2020 (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. Edited April 25, 2020 by whosa Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 25, 2020 Share Posted April 25, 2020 Post a small sample drawing (saved as AutoCAD 2010 or earlier for me) for testing etc. Quote Link to comment Share on other sites More sharing options...
whosa Posted April 25, 2020 Author Share Posted April 25, 2020 (edited) here the test file v.2010 TEST-LEVEL.dwg Edited April 25, 2020 by whosa Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 25, 2020 Share Posted April 25, 2020 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 1 Quote Link to comment Share on other sites More sharing options...
BIGAL Posted April 26, 2020 Share Posted April 26, 2020 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. 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. 1 Quote Link to comment Share on other sites More sharing options...
BIGAL Posted April 26, 2020 Share Posted April 26, 2020 To whosa does the whiteline exist for all kerbs etc or did you add it ? Quote Link to comment Share on other sites More sharing options...
whosa Posted April 26, 2020 Author Share Posted April 26, 2020 (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 April 26, 2020 by whosa Quote Link to comment Share on other sites More sharing options...
whosa Posted April 26, 2020 Author Share Posted April 26, 2020 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*> Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 26, 2020 Share Posted April 26, 2020 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? Quote Link to comment Share on other sites More sharing options...
whosa Posted April 26, 2020 Author Share Posted April 26, 2020 8 minutes ago, dlanorh said: Are you working in AutoCAD? yes Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 26, 2020 Share Posted April 26, 2020 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? Quote Link to comment Share on other sites More sharing options...
whosa Posted April 26, 2020 Author Share Posted April 26, 2020 (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 April 26, 2020 by whosa Quote Link to comment Share on other sites More sharing options...
whosa Posted April 26, 2020 Author Share Posted April 26, 2020 (edited) @dlanorh This lisp work well but it has 2 problems: 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 April 26, 2020 by whosa Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 26, 2020 Share Posted April 26, 2020 1 hour ago, whosa said: @dlanorh This lisp work well but it has 2 problems: 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. Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 26, 2020 Share Posted April 26, 2020 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 1 Quote Link to comment Share on other sites More sharing options...
whosa Posted April 26, 2020 Author Share Posted April 26, 2020 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. Quote Link to comment Share on other sites More sharing options...
dlanorh Posted April 26, 2020 Share Posted April 26, 2020 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. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.