MVMV Posted December 10, 2013 Author Posted December 10, 2013 Stefan, The magician is born. Thx man! Quote
Stefan BMR Posted December 10, 2013 Posted December 10, 2013 You are very welcome MVMV. If you'll stay around here long enough, you will meet the true magicians... Back to your work, how do you manage these situations? And another question: Do you need the horizontal lines in dwg? I wish to discuss more about this but I have to go now. Quote
marko_ribar Posted December 10, 2013 Posted December 10, 2013 (edited) I know this isn't the answer on your question, but I couldn't resist to experiment a little... (defun vlax-curve-getclosestpointtoprojection-a ( curve pt nor / adoc *error* v^v unit v1e-3 ape osm c p pl1 pl2 pp l d px fd vd nf ) (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) (defun *error* ( m ) (if ape (setvar 'aperture ape)) (if osm (setvar 'osmode osm)) (vla-endundomark adoc) (if m (prompt m)) (princ) ) (defun v^v ( u v / cda ) (defun cda ( p ) (cdr (append p p))) (mapcar '- (mapcar '* (cda u) (cdr (cda v))) (mapcar '* (cdr (cda u)) (cda v)) '(0.0 0.0 0.0)) ) (defun unit ( v ) (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v) ) (defun v1e-3 ( v ) (mapcar '(lambda ( x ) (/ x 1000.0)) v) ) (command "_.zoom" "e") (setq ape (getvar 'aperture)) (setq osm (getvar 'osmode)) (setvar 'aperture 10) (setvar 'osmode 0) (vla-copy (vlax-ename->vla-object curve)) (setq c (entlast)) (entdel curve) (setq p (vlax-curve-getclosestpointtoprojection c pt nor)) (setq pl1 (cons p pl1)) (if (not (equal p (vlax-curve-getendpoint c) 1e-) (progn (setq pp (vlax-curve-getpointatparam c (+ (vlax-curve-getparamatpoint c p) 1e-4))) (while p (while (not (equal pp (vlax-curve-getstartpoint c) 1e-2)) (setq l (entmakex (list '(0 . "LINE") (cons 10 pp) (cons 11 (vlax-curve-getstartpoint c))))) (setq d (distance (vlax-curve-getstartpoint c) (setq px (vlax-curve-getpointatparam c (+ (vlax-curve-getstartparam c) 1e-4))))) (setq fd (vlax-curve-getfirstderiv c (vlax-curve-getparamatpoint c px))) (setq vd (unit (getvar 'viewdir))) (setq nf (v1e-3 (v^v fd vd))) (command "_.zoom" "c" px (* d 2.0)) (command "_.trim" l "" "f" (mapcar '+ px nf) (mapcar '- px nf) "" "") (entdel l) (command "_.erase" px "") (command "_.zoom" "p") (setq p (vlax-curve-getclosestpointtoprojection (setq c (car (nentselp (osnap pp "_end")))) pt nor)) (if p (progn (setq pl1 (cons p pl1)) (setq pp (vlax-curve-getpointatparam c (+ (vlax-curve-getparamatpoint c p) 1e-4))) ) ) ) (if (equal p (if (cadr pl1) (cadr pl1) p) 0.5) (setq p nil)) ) ) ) (entdel c) (entdel curve) (setq pl1 (reverse pl1)) (setq pl1 (acet-list-remove-duplicates pl1 0.5)) (vla-copy (vlax-ename->vla-object curve)) (setq c (entlast)) (entdel curve) (setq p (vlax-curve-getclosestpointtoprojection c pt nor)) (setq pl2 (cons p pl2)) (if (not (equal p (vlax-curve-getstartpoint c) 1e-) (progn (setq pp (vlax-curve-getpointatparam c (- (vlax-curve-getparamatpoint c p) 1e-4))) (while p (while (not (equal pp (vlax-curve-getendpoint c) 1e-2)) (setq l (entmakex (list '(0 . "LINE") (cons 10 pp) (cons 11 (vlax-curve-getendpoint c))))) (setq d (distance (vlax-curve-getendpoint c) (setq px (vlax-curve-getpointatparam c (- (vlax-curve-getendparam c) 1e-4))))) (setq fd (vlax-curve-getfirstderiv c (vlax-curve-getparamatpoint c px))) (setq vd (unit (getvar 'viewdir))) (setq nf (v1e-3 (v^v fd vd))) (command "_.zoom" "c" px (* d 2.0)) (command "_.trim" l "" "f" (mapcar '+ px nf) (mapcar '- px nf) "" "") (entdel l) (command "_.erase" px "") (command "_.zoom" "p") (setq p (vlax-curve-getclosestpointtoprojection (setq c (car (nentselp (osnap pp "_end")))) pt nor)) (if p (progn (setq pl2 (cons p pl2)) (setq pp (vlax-curve-getpointatparam c (- (vlax-curve-getparamatpoint c p) 1e-4))) ) ) ) (if (equal p (if (cadr pl2) (cadr pl2) p) 0.5) (setq p nil)) ) ) ) (entdel c) (entdel curve) (setq pl2 (acet-list-remove-duplicates pl2 0.5)) (command "_.zoom" "p") (*error* nil) (if (> (length pl1) (length pl2)) pl1 pl2) ) Edited December 14, 2013 by marko_ribar code changed Quote
MVMV Posted December 11, 2013 Author Posted December 11, 2013 Stefan, I think i need to find a way to make a more smooth halftone pattern. Need to figure that out. But I'm afraid i will have to clean the halftone manual. Also i need to split every spline so they dont touch each other Marco, I'll try your LISP later. Can you tell me what it does exactly? We have some sheet piling issues in the project, so other priorities now. Quote
MVMV Posted December 11, 2013 Author Posted December 11, 2013 BTW: i dont need the horizontal lines in DWG Quote
marko_ribar Posted December 11, 2013 Posted December 11, 2013 (edited) Here is Stefan's code with my mods that is applicable for cases posted in post #22... Although not tested, it should work I think slower, but correct... I've removed horizontal lines as your request... Test it and report if somethings wrong... ;; Subfunction is only applicable to open LWPOLYLINE entities that lies in WCS ;; (defun vlax-curve-getclosestpointtoprojection-a ( curve pt nor / add_vtx c p pl pp suf vn pre ) (defun add_vtx ( obj add_pt ent_name / bulg ) (vla-addVertex obj (1+ (fix add_pt)) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 1)) (list (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name)) (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name)) ) ) ) ) (setq bulg (vla-GetBulge obj (fix add_pt))) (vla-SetBulge obj (fix add_pt) (/ (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4)) (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4)) ) ) (vla-SetBulge obj (1+ (fix add_pt)) (/ (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4)) (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4)) ) ) (vla-update obj) ) (vla-copy (vlax-ename->vla-object curve)) (setq c (entlast)) (entdel curve) (setq p (vlax-curve-getclosestpointtoprojection c pt nor)) (setq pl (cons p pl)) (if (not (equal p (vlax-curve-getendpoint c) 1e-) (progn (setq pp (vlax-curve-getpointatparam c (+ (vlax-curve-getparamatpoint c p) 1e-)) (add_vtx (vlax-ename->vla-object c) (vlax-curve-getparamatpoint c pp) c) (while p (while (not (equal pp (vlax-curve-getstartpoint c) 1e-) (setq suf (vl-member-if '(lambda ( x ) (equal (cons 10 (list (car pp) (cadr pp))) x 1e-) (entget c))) (setq vn (length (acet-list-m-assoc 10 suf))) (setq pre (reverse (cdr (member (assoc 10 (entget c)) (reverse (entget c)))))) (setq pre (subst (cons 90 vn) (assoc 90 pre) pre)) (entmod (append pre suf)) (setq p (vlax-curve-getclosestpointtoprojection (setq c (car (nentselp (osnap pp "_end")))) pt nor)) (setq pl (cons p pl)) (setq pp (vlax-curve-getpointatparam c (+ (vlax-curve-getparamatpoint c p) 1e-)) (add_vtx (vlax-ename->vla-object c) (vlax-curve-getparamatpoint c pp) c) ) (if (equal p (if (cadr pl) (cadr pl) p) 1e-6) (setq p nil)) ) ) ) (entdel c) (entdel curve) (setq pl (reverse pl)) (setq pl (acet-list-remove-duplicates pl 1e-6)) pl ) (defun c:test ( / *error* d e1 e1f e2 e2f lst p p1 p2 y1 y11 y12 y2 y21 y22 pll dd ddd ) (vl-load-com) (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))) (vla-startundomark acDoc) (defun *error* (msg) (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*")) (princ (strcat "\nError: " msg)) ) (vla-endundomark acDoc) (princ) ) (if (and (princ "\nSelect first object") (setq e1 (ssget "_+.:E:S:L" '((0 . "LWPOLYLINE")))) (princ "\nSelect second object") (setq e2 (ssget "_+.:E:S:L" '((0 . "LWPOLYLINE")))) (not (eq (setq e1 (ssname e1 0)) (setq e2 (ssname e2 0)))) (setq d (getdist "\nInterval: ")) (setq p (getpoint "\nSelect insertion point: ")) ) (progn (setq y11 (cadr (vlax-curve-getstartpoint e1)) y12 (cadr (vlax-curve-getendpoint e1)) y21 (cadr (vlax-curve-getstartpoint e2)) y22 (cadr (vlax-curve-getendpoint e2)) ) (if (> y11 y12) (progn (setq e1f t) (command "_.reverse" e1 ""))) (if (> y21 y22) (progn (setq e2f t) (command "_.reverse" e2 ""))) (setq y11 (cadr (vlax-curve-getstartpoint e1)) y12 (cadr (vlax-curve-getendpoint e1)) y21 (cadr (vlax-curve-getstartpoint e2)) y22 (cadr (vlax-curve-getendpoint e2)) ) (mapcar 'set '(y11 y12) (list (min y11 y12) (max y11 y12))) (mapcar 'set '(y21 y22) (list (min y21 y22) (max y21 y22))) (if (or (<= y12 y21) (< y22 y11)) (princ "\Objects not overlaping...") (progn (setq y1 (max y11 y21) y2 (min y12 y22) d (/ (- y2 y1) (fix (/ (- y2 y1) d))) ) (entmake (list '(0 . "LINE") (list 10 (car p) y1 0) (list 11 (car p) y2 0) ) ) (while (or (< y1 y2) (equal y1 y2 1e-6)) (setq p1 (vlax-curve-getclosestpointtoprojection-a e1 (list 0.0 y1) '(1 0 0)) p2 (vlax-curve-getclosestpointtoprojection-a e2 (list 0.0 y1) '(1 0 0)) ) (setq pll (append p1 p2)) (setq pll (vl-sort pll '(lambda ( a b ) (< (car a) (car b))))) (setq ddd 0.0) (repeat (/ (length pll) 2) (setq dd (distance (car pll) (cadr pll))) (setq ddd (+ ddd dd)) (setq pll (cddr pll)) ) (setq lst (cons (list 10 (+ (car p) ddd) y1) lst) y1 (+ y1 d) ) ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) ) lst ) ) ) ) ) ) (if e1f (command "_.reverse" e1 "")) (if e2f (command "_.reverse" e2 "")) (vla-endundomark acDoc) (princ) ) This is what is my previous post for - it's extension of (vlax-curve-getclosestpointtoprojection) function... Study this code and you'll figure out its purpose... Edited December 14, 2013 by marko_ribar code changed Quote
marko_ribar Posted December 11, 2013 Posted December 11, 2013 I've changed both my codes and did tests - on spline entities code may error, but if you pedit splines into polylines it may do the job... Test it and tell me your results... M.R. Quote
Stefan BMR Posted December 11, 2013 Posted December 11, 2013 Stefan,I think i need to find a way to make a more smooth halftone pattern. Need to figure that out. But I'm afraid i will have to clean the halftone manual. Also i need to split every spline so they dont touch each other I hope you will find an easier way for that part of your work.About my lisp, just use it a while and if you think it need adjustments, improvements, don't be shy, come here and let me know. BTW: i dont need the horizontal lines in DWG All you have to do is to add 2 semicolons. Edit the lisp file, add semicolons, save file AND reload it in Autocad. ... (while (<= y1 y2) (setq p1 (vlax-curve-getclosestpointtoprojection e1 (list 0.0 y1) '(1 0 0)) p2 (vlax-curve-getclosestpointtoprojection e2 (list 0.0 y1) '(1 0 0)) ) [color=red][b] ;[/b][/color](entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))) [b][color=red] ;[/color][/b](entmake (list '(0 . "LINE") (list 10 (car p) y1 0) (list 11 (+ (car p) (distance p1 p2)) y1 0))) (setq l (cons (list 10 (+ (car p) (distance p1 p2)) y1) l) y1 (+ y1 d) ) ) ... Quote
marko_ribar Posted December 12, 2013 Posted December 12, 2013 After changing my subfunction for a few times, I discovered that I had mistake in (vl-sort) function... Now that's correct - look in my attachment - it worked on this example, but as my sub-function is highly unstable, I do suggest to avoid it and maybe try with intersectwith method and XLINE that is to be erased... M.R. profile-test.dwg Quote
marko_ribar Posted December 14, 2013 Posted December 14, 2013 New update of my last code... But it's only applicable for cases of open LWPOLYLINES that lie in WCS and that are aligned with equal Y coordinates of start/end vertices like posted request... Now routine works much faster and is predicted to work and with cases posted in post #22... HTH, M.R. Quote
marko_ribar Posted December 14, 2013 Posted December 14, 2013 I've noticed also that sometimes, when supplied point, entity and normal vector to (vlax-curve-getclosestpointtoprojection) it may return not first point on smallest parameter on curve, but sometimes just opposite on largest parameter, so I've updated my first code that is referenced to SPLINE, PLINE entities as long as start/end vertex isn't one of resulting vertex in a list of points... Note that my (vlax-curve-getclosestpointtoprojection-a) posted above isn't applicable to CIRCLES, full ELLIPSES, XLINES, RAYS and is also very unreliable if used in some other function - use it with very carefully... Quote
marko_ribar Posted December 14, 2013 Posted December 14, 2013 But I think, for your case and situations from post #22, the best is XLINE with intersectwith method... (defun GetIntersections ( obj1 obj2 ) (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3) ) (defun GroupByNum ( l n / f ) (defun f ( a b ) (if (and a (< 0 b)) (cons (car a) (f (setq l (cdr a)) (1- b))) ) ) (if l (cons (f l n) (GroupByNum l n))) ) (defun c:test ( / *error* d e1 e1f e2 e2f lst p p1 p2 y1 y11 y12 y2 y21 y22 xl ms pll dd ddd ) (vl-load-com) (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))) (vla-startundomark acDoc) (defun *error* (msg) (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*")) (princ (strcat "\nError: " msg)) ) (vla-endundomark acDoc) (princ) ) (if (and (princ "\nSelect first object") (setq e1 (ssget "_+.:E:S:L" '((0 . "LWPOLYLINE,SPLINE")))) (princ "\nSelect second object") (setq e2 (ssget "_+.:E:S:L" '((0 . "LWPOLYLINE,SPLINE")))) (not (eq (setq e1 (ssname e1 0)) (setq e2 (ssname e2 0)))) (setq d (getdist "\nInterval: ")) (setq p (getpoint "\nSelect insertion point: ")) ) (progn (setq y11 (cadr (vlax-curve-getstartpoint e1)) y12 (cadr (vlax-curve-getendpoint e1)) y21 (cadr (vlax-curve-getstartpoint e2)) y22 (cadr (vlax-curve-getendpoint e2)) ) (if (> y11 y12) (progn (setq e1f t) (command "_.reverse" e1 ""))) (if (> y21 y22) (progn (setq e2f t) (command "_.reverse" e2 ""))) (setq y11 (cadr (vlax-curve-getstartpoint e1)) y12 (cadr (vlax-curve-getendpoint e1)) y21 (cadr (vlax-curve-getstartpoint e2)) y22 (cadr (vlax-curve-getendpoint e2)) ) (mapcar 'set '(y11 y12) (list (min y11 y12) (max y11 y12))) (mapcar 'set '(y21 y22) (list (min y21 y22) (max y21 y22))) (if (or (<= y12 y21) (< y22 y11)) (princ "\Objects not overlaping...") (progn (setq y1 (max y11 y21) y2 (min y12 y22) d (/ (- y2 y1) (fix (/ (- y2 y1) d))) ) (entmake (list '(0 . "LINE") (list 10 (car p) y1 0) (list 11 (car p) y2 0) ) ) (while (or (< y1 y2) (equal y1 y2 1e-6)) (vla-addxline (if (null ms) (setq ms (vla-get-modelspace acDoc)) ms) (vlax-3d-point (list 0.0 y1)) (vlax-3d-point (list 1.0 y1))) (setq xl (entlast)) (setq p1 (GetIntersections (vlax-ename->vla-object e1) (vlax-ename->vla-object xl)) p2 (GetIntersections (vlax-ename->vla-object e2) (vlax-ename->vla-object xl)) ) (entdel xl) (setq pll (append p1 p2)) (setq pll (vl-sort pll '(lambda ( a b ) (< (car a) (car b))))) (setq ddd 0.0) (repeat (/ (length pll) 2) (setq dd (distance (car pll) (cadr pll))) (setq ddd (+ ddd dd)) (setq pll (cddr pll)) ) (setq lst (cons (list 10 (+ (car p) ddd) y1) lst) y1 (+ y1 d) ) ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) ) lst ) ) ) ) ) ) (if e1f (command "_.reverse" e1 "")) (if e2f (command "_.reverse" e2 "")) (vla-endundomark acDoc) (princ) ) See my newest attachment... It's also applicable and for SPLINES... HTH, M.R. profile-test-PLINES - new.dwg Quote
marko_ribar Posted December 14, 2013 Posted December 14, 2013 And here is the newest version of (vlax-curve-getclosestpointtoprojection-a)... (defun vlax-curve-getclosestpointtoprojection-a ( curve pt nor / GetIntersections GroupByNum p pl ) (defun GetIntersections ( obj1 obj2 ) (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3) ) (defun GroupByNum ( l n / f ) (defun f ( a b ) (if (and a (< 0 b)) (cons (car a) (f (setq l (cdr a)) (1- b))) ) ) (if l (cons (f l n) (GroupByNum l n))) ) (setq p (vlax-curve-getclosestpointtoprojection curve pt nor)) (vla-addxline (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point p) (vlax-3d-point (mapcar '+ p nor))) (setq pl (GetIntersections (vlax-ename->vla-object curve) (vlax-ename->vla-object (entlast)))) (entdel (entlast)) (if pl pl (list p)) ) The code that uses this newest version... (defun vlax-curve-getclosestpointtoprojection-a ( curve pt nor / GetIntersections GroupByNum p pl ) (defun GetIntersections ( obj1 obj2 ) (GroupByNum (vlax-invoke obj1 'IntersectWith obj2 acExtendNone) 3) ) (defun GroupByNum ( l n / f ) (defun f ( a b ) (if (and a (< 0 b)) (cons (car a) (f (setq l (cdr a)) (1- b))) ) ) (if l (cons (f l n) (GroupByNum l n))) ) (setq p (vlax-curve-getclosestpointtoprojection curve pt nor)) (vla-addxline (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point p) (vlax-3d-point (mapcar '+ p nor))) (setq pl (GetIntersections (vlax-ename->vla-object curve) (vlax-ename->vla-object (entlast)))) (entdel (entlast)) (if pl pl (list p)) ) (defun c:test ( / *error* d e1 e1f e2 e2f lst p p1 p2 y1 y11 y12 y2 y21 y22 pll dd ddd ) (vl-load-com) (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))) (vla-startundomark acDoc) (defun *error* (msg) (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*")) (princ (strcat "\nError: " msg)) ) (vla-endundomark acDoc) (princ) ) (if (and (princ "\nSelect first object") (setq e1 (ssget "_+.:E:S:L")) (princ "\nSelect second object") (setq e2 (ssget "_+.:E:S:L")) (not (eq (setq e1 (ssname e1 0)) (setq e2 (ssname e2 0)))) (setq d (getdist "\nInterval: ")) (setq p (getpoint "\nSelect insertion point: ")) ) (progn (setq y11 (cadr (vlax-curve-getstartpoint e1)) y12 (cadr (vlax-curve-getendpoint e1)) y21 (cadr (vlax-curve-getstartpoint e2)) y22 (cadr (vlax-curve-getendpoint e2)) ) (if (> y11 y12) (progn (setq e1f t) (command "_.reverse" e1 ""))) (if (> y21 y22) (progn (setq e2f t) (command "_.reverse" e2 ""))) (setq y11 (cadr (vlax-curve-getstartpoint e1)) y12 (cadr (vlax-curve-getendpoint e1)) y21 (cadr (vlax-curve-getstartpoint e2)) y22 (cadr (vlax-curve-getendpoint e2)) ) (mapcar 'set '(y11 y12) (list (min y11 y12) (max y11 y12))) (mapcar 'set '(y21 y22) (list (min y21 y22) (max y21 y22))) (if (or (<= y12 y21) (< y22 y11)) (princ "\Objects not overlaping...") (progn (setq y1 (max y11 y21) y2 (min y12 y22) d (/ (- y2 y1) (fix (/ (- y2 y1) d))) ) (entmake (list '(0 . "LINE") (list 10 (car p) y1 0) (list 11 (car p) y2 0) ) ) (while (or (< y1 y2) (equal y1 y2 1e-6)) (setq p1 (vlax-curve-getclosestpointtoprojection-a e1 (list 0.0 y1) '(1 0 0)) p2 (vlax-curve-getclosestpointtoprojection-a e2 (list 0.0 y1) '(1 0 0)) ) (setq pll (append p1 p2)) (setq pll (vl-sort pll '(lambda ( a b ) (< (car a) (car b))))) (setq ddd 0.0) (repeat (/ (length pll) 2) (setq dd (distance (car pll) (cadr pll))) (setq ddd (+ ddd dd)) (setq pll (cddr pll)) ) (setq lst (cons (list 10 (+ (car p) ddd) y1) lst) y1 (+ y1 d) ) ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) ) lst ) ) ) ) ) ) (if e1f (command "_.reverse" e1 "")) (if e2f (command "_.reverse" e2 "")) (vla-endundomark acDoc) (princ) ) Now is applicable to all curve entities... M.R. Quote
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.