Leaderboard

Use Visual lisp command to explode things. It keeps the original and makes copies of the individual entities. So as you step though them to test just delete as you go. Then there isn't a need to undo. This method works with blocks, polylines, hatches, mtext basically anything you can explode into sub entities. (setq poly (vlax-invoke (vlax-ename->vla-object (car (entsel "\nSelect Main Polyline:"))) 'explode)) (setq poly2 (vlax-ename->vla-object (car (entsel "\nSelect 2nd Polyline:"))) (foreach obj poly ;gives a list of all entities created in vla-object name. (setq pt (vlax-invoke obj 'intersectWith poly2 acextendnone)) ;dont know if this works with diff elevation ;or make a list of points (vla-delete obj) ;after test delete entity ) -Edit Over thinking it again. I was like why delete very thing to come back and use entmake!?!? This will work with arc's too. example ;;----------------------------------------------------------------------;; ;; Make a Copy of Poly Segment if intersect (defun C:CPS (/ e p c l) (setq e (vla-get-elevation (setq p (vlax-ename->vla-object (car (entsel "\nSelect Main Polyline: ")))))) (setq c (vla-copy (vlax-ename->vla-object (car (entsel "\nSelect 2nd Polyline: "))))) (vla-put-elevation c e) ;move it to same eleveation as first poly (foreach obj (vlax-invoke p 'explode) (if (vlax-invoke obj 'intersectWith c acextendnone) (vla-put-Color obj 1) ;or change layer, or nothing (progn) (vla-delete obj) ;delete object if intersection not found ) ) (vla-delete c) ;delete copy polyline (princ) )

Give this a try: (defun c:foo (/ c n s) (cond ((and (or (setq n (getdist "\nEnter area value to check:<300> ")) (setq n 300)) (setq c (acad_truecolordlg 1)) (setq s (ssget '((0 . "LWPOLYLINE") (8 . "living")))) ) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (if (>= (vlax-curve-getarea e) n) (entmod (append (entget e) c)) (ssdel e s) ) ) (sssetfirst nil s) ) ) (princ) )

Whoops hate naming variables. half way thought i was like this is the check polyline but its also the copied lets jut name it c I prob should have put 2 and 2 together there. Your are using 3d poly lines. Those don't have elevation because they have x y z coords. So that code won't work. What your probably going to have to do now is Select Crossing 3d polyline get bounding box info for min max z elevation. select Route polyline convert it to 2d set to min or beloew elevation of crossing polyline make a 3d face/region to or above max elevaton edit the following to find points of crossing https://www.cadtutor.net/forum/topic/75018-get-points-on-a-3d-curve-with-the-same-z-coordinate-corresponding/?do=findComment&comment=593874 Use points found in the original code in the manual selection copy segments.

Perfect! (mostly - are we ever happy?) Last line (vla-delete check) should be (vla-delete c) , just a typo Am breaking my own rules and looking at CAD on a Saturday, whoops, so on Monday I think I am going alter your code slightly, if I move the vla-get-elevation, vla-put-elevation into the foreach to do that for each segment individually that should cover the case where a polyline elevation changes along it length Something like: (defun C:CPS (/ e p c l) ;; (setq e (vla-get-elevation (setq p (vlax-ename->vla-object (car (entsel "\nSelect Main Polyline: ")))))) (setq p (vlax-ename->vla-object (car (entsel "\nSelect Crossing Polyline: ")))) (setq c (vla-copy (vlax-ename->vla-object (car (entsel "\nSelect Route Polyline: "))))) ;; (vla-put-elevation c e) ;move it to same eleveation as first poly (foreach obj (vlax-invoke p 'explode) (setq e (vla-get-elevation obj)) (vla-put-elevation c e) ;move it to same eleveation as first poly (if (vlax-invoke obj 'intersectWith c acextendnone) (vla-put-Color obj 1) ;or change layer, or nothing (progn) (vla-delete obj) ;delete object if intersection not found ) ) (vla-delete c) ;delete copy polyline (princ) ) Very quickly though gives the error "; error: ActiveX Server returned the error: unknown name: Elevation" - so 90% there will do the rest next week (unless i get bored later today)

Ok had a play and you can just pass a value into a cell using a direct method of Autocad/Bricscad talking to excel. No Csv. So I put 10 in A1 20 in B1 then did (putcell "C1 "=A1+B1") the result as required. If you get a copy of getexcel.lsp it has a putcell function. I used my own version of a excel.lsp program. This is the very cut down version but worked. The full code does much more options like pick a excel file etc. (defun putcell (cellname val1 / ) (setq myRange (vlax-get-property (vlax-get-property myxl "ActiveSheet") "Range" cellname)) (vlax-put-property myRange 'Value2 val1) ) ; have excel already open (or (setq myxl (vlax-get-object "Excel.Application")) (setq myxl (vlax-get-or-create-object "excel.Application")) ) (vla-put-visible myXL :vlax-true) (vlax-put-property myxl 'ScreenUpdating :vlax-true) (vlax-put-property myXL 'DisplayAlerts :vlax-true) ; putcell example (putcell "C1" "=A1+B1")

Here is a manual way using code above. line is created on current layer ;;----------------------------------------------------------------------;; ;; Make a Copy of Poly Segment. (defun C:CopySegment (/ x poly v Strpt Endpt ) (while (setq x (entsel "\nSelect Polyline Segment to Copy: ")) (setq poly (vlax-ename->vla-object (car x))) (setq v (fix (vlax-curve-getParamAtPoint poly (vlax-curve-getClosestPointTo poly (cadr x))))) (setq StrPt (vlax-Curve-GetPointAtParam poly v)) (setq EndPt (vlax-Curve-GetPointAtParam poly (1+ v))) (entmake (list '(0 . "LINE") (cons 10 StrPT) (cons 11 EndPt))) ) (princ) ) --Edit Only works with straight lines.

Given that we're working with reals, I would suggest the use of the equal function with an appropriate tolerance - I would reserve zerop for when testing integer values. Hence: (vl-remove-if '(lambda ( x ) (or (equal (car x) 0.0 1e-8) (equal (cadr x) 0.0 1e-8))) lst) Or, for any coordinate: (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (equal y 0.0 1e-8)) x)) lst)

Latest code: ;; Txt2Att ( Lee Mac ) ;; Converts Single-line Text to Attribute Definition (defun c:txt2att ( / StringSubst RemovePairs ss ent eLst str dx73 ) (vl-load-com) ;; Lee Mac ~ 27.04.10 (defun StringSubst ( new pat str ) (while (vl-string-search pat str) (setq str (vl-string-subst new pat str)) ) str ) (defun RemovePairs ( lst pairs ) (vl-remove-if (function (lambda ( pair ) (vl-position (car pair) pairs) ) ) lst ) ) (if (setq ss (ssget "_:L" '((0 . "TEXT")))) ( (lambda ( i ) (while (setq ent (ssname ss (setq i (1+ i)))) (setq eLst (entget ent) str (StringSubst "_" " " (cdr (assoc 1 eLst))) dx73 (cdr (assoc 73 eLst))) (setq eLst (RemovePairs eLst '( 0 100 1 73 ))) (if (entmake (append '( (0 . "ATTDEF") ) eLst (list (cons 70 0) (cons 74 dx73) (cons 1 str) (cons 2 str) (cons 3 str)))) (entdel ent) ) ) ) -1 ) ) (princ))

This should deal with spaces: (defun c:txt2atta (/ ss i en ed) (vl-load-com) (while (not ss) (princ "\nSelect TEXT to Convert to ATTDEF: ") (setq ss (ssget (list (cons 0 "TEXT") (cons 410 (getvar "CTAB")))))) (setq i (sslength ss)) (while (not (minusp (setq i (1- i)))) (setq en (ssname ss i) ed (entget en) ed (subst (cons 1 (vl-string-subst "_" " " (cdr (assoc 1 ed)))) (assoc 1 ed) ed)) (entmake (list (cons 0 "ATTDEF") (assoc 8 ed) (assoc 10 ed) (assoc 11 ed) (assoc 7 ed) (assoc 40 ed) (assoc 41 ed) (assoc 50 ed) (assoc 51 ed) (cons 70 0) (assoc 71 ed) (assoc 72 ed) (cons 74 (cdr (assoc 73 ed))) (assoc 210 ed) (assoc 1 ed) (cons 2 (cdr (assoc 1 ed))) (cons 3 (cdr (assoc 1 ed))) (if (assoc 6 ed) (assoc 6 ed)'(6 . "BYLAYER")) (if (assoc 39 ed) (assoc 39 ed)'(39 . 0)) (if (assoc 62 ed) (assoc 62 ed)'(62 . 256)))) (entdel en)) (redraw) (prin1))