TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: Andrea on January 26, 2010, 04:32:08 PM
-
Hi all,...
I would like to share my new program with all ...but i'm stucked for now.
I need a little Help on this one..
Diso (Dynamic ISOmetric)
Diso draw lines projections of selected object allowing Isometric view result.
For now i've create this only for test and work great on any Plines. (see Gif 1 below)
the problem is I can't found a way to have a condition on wich side I need to hide the line when having an intersection.
For now, I know how to detect intersection of selected object (see Gif 2) but startpoints and Endpoint of each lines are always differents.
I also add an options by pressing + or - to scale extracted object allowing perspective illusion.. ;-)
I would like to have as the final result something like (see pic 3)
any suggestions ?
-
Just hacked this together, but got nowhere with it...
(defun c:test (/ ENT1 ENT2 INT OBJ1PTS_NEW OBJ2PTS OBJ2PTS_NEW OBJ3 SPC X Y)
(vl-load-com)
(defun getVerts (entity / lst)
(setq lst
(mapcar
(function cdr)
(vl-remove-if-not
(function
(lambda (x) (= 10 (car x)))) (entget entity)))))
(setq spc (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-acad-object))))
(while
(progn
(setq ent (entsel "\nSelect LWPoly: "))
(cond ( (eq 'ENAME (type (setq ent1 (car ent))))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget ent1))))
(progn
(vla-getBoundingBox
(setq obj1 (vlax-ename->vla-object ent1)) 'MiP 'MaP)
(setq bsvec (mapcar (function -)
(vlax-safearray->list MiP)
(setq pt (vlax-curve-getClosestPointto ent1 (cadr ent))))
obj2 (vla-copy obj1) obj1pts (GetVerts ent1)
ent2 (vlax-vla-object->ename obj2))
(while (and (= 5 (car (setq gr (grread 't 5 0)))) (listp (cadr gr)))
(redraw)
(vla-getBoundingBox obj2 'MiP 'MaP)
(vla-move obj2 (vlax-3D-point
(mapcar (function -)
(vlax-safearray->list MiP) bsVec))
(vlax-3D-point (cadr gr)))
(setq obj2pts (getVerts ent2))
(if (not (vlax-invoke obj1 'IntersectWith obj2 acExtendnone))
(progn
(setq obj1pts_new obj1pts)
(while (setq x (car obj1pts_new))
(setq obj3 (vla-addline spc (vlax-3D-point x)
(vlax-3D-point (setq y (car obj2pts)))))
(setq obj2pts_new
(cons
(if (setq int (vlax-invoke obj2 'Intersectwith obj3 acExtendNone))
(list (car int) (cadr int) (caddr int)) y) obj2pts_new))
(setq obj2pts (cdr obj2Pts) obj1pts_new (cdr obj1pts_new))
(vla-delete obj3))
(setq obj2pts_new (reverse obj2pts_new)))
(setq obj2pts_new obj2pts))
(mapcar
(function
(lambda (from to) (grdraw from to -1 0))) obj1pts obj2pts_new)
(setq obj1pts_new nil obj2pts_new nil)
))
(princ "\n** Object Must be and LWPoly **"))))))
(princ))
-
Just hacked this together, but got nowhere with it...
(defun c:test (/ ENT1 ENT2 INT OBJ1PTS_NEW OBJ2PTS OBJ2PTS_NEW OBJ3 SPC X Y)
(vl-load-com)
(defun getVerts (entity / lst)
(setq lst
(mapcar
(function cdr)
(vl-remove-if-not
(function
(lambda (x) (= 10 (car x)))) (entget entity)))))
(setq spc (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-acad-object))))
(while
(progn
(setq ent (entsel "\nSelect LWPoly: "))
(cond ( (eq 'ENAME (type (setq ent1 (car ent))))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget ent1))))
(progn
(vla-getBoundingBox
(setq obj1 (vlax-ename->vla-object ent1)) 'MiP 'MaP)
(setq bsvec (mapcar (function -)
(vlax-safearray->list MiP)
(setq pt (vlax-curve-getClosestPointto ent1 (cadr ent))))
obj2 (vla-copy obj1) obj1pts (GetVerts ent1)
ent2 (vlax-vla-object->ename obj2))
(while (and (= 5 (car (setq gr (grread 't 5 0)))) (listp (cadr gr)))
(redraw)
(vla-getBoundingBox obj2 'MiP 'MaP)
(vla-move obj2 (vlax-3D-point
(mapcar (function -)
(vlax-safearray->list MiP) bsVec))
(vlax-3D-point (cadr gr)))
(setq obj2pts (getVerts ent2))
(if (not (vlax-invoke obj1 'IntersectWith obj2 acExtendnone))
(progn
(setq obj1pts_new obj1pts)
(while (setq x (car obj1pts_new))
(setq obj3 (vla-addline spc (vlax-3D-point x)
(vlax-3D-point (setq y (car obj2pts)))))
(setq obj2pts_new
(cons
(if (setq int (vlax-invoke obj2 'Intersectwith obj3 acExtendNone))
(list (car int) (cadr int) (caddr int)) y) obj2pts_new))
(setq obj2pts (cdr obj2Pts) obj1pts_new (cdr obj1pts_new))
(vla-delete obj3))
(setq obj2pts_new (reverse obj2pts_new)))
(setq obj2pts_new obj2pts))
(mapcar
(function
(lambda (from to) (grdraw from to -1 0))) obj1pts obj2pts_new)
(setq obj1pts_new nil obj2pts_new nil)
))
(princ "\n** Object Must be and LWPoly **"))))))
(princ))
Hi Lee,..
Thanks for the reply.
Nice neat code there...specialy the getVerts function. ;-)
You work is diffrent than mine...but I like it.
The problem is to be able to remove some lines...
the picure below have grey line that must me removed during process.
-
Yeah, I tried to remove some lines with that bit in the middle of the GrRead loop, but I think I was approaching it the wrong way. :|
-
Andrea salut,
On Pic3; shouldn't the lines at far face of your object be hidden as well? :|
-
Ah et puis aussi celle qui part du coin bas gauche
-
Andrea,
This is how I might go about it:
(http://www.theswamp.org/screens/leemac/diso.png)
Test for intersections between:
- The Original Polyline, and the Copied Polyline - if intersection, remove vertex.
- The Connecting Lines and each of the Polylines - if intersection, remove vertex.
My original code, (slightly updated here), tests for one of these cases, and removes the connecting line in that case:
(defun c:test (/ ENT1 ENT2 INT OBJ1PTS_NEW OBJ2PTS OBJ2PTS_NEW OBJ3 SPC X Y)
(vl-load-com)
(defun getVerts (entity / lst)
(setq lst
(mapcar
(function cdr)
(vl-remove-if-not
(function
(lambda (x) (= 10 (car x)))) (entget entity)))))
(defun list->3D-point (lst / result)
(while lst
(setq result (cons (list (car lst) (cadr lst) (caddr lst)) result)
lst (cdddr lst)))
(reverse result))
(setq spc (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-acad-object))))
(while
(progn
(setq ent (entsel "\nSelect LWPoly: "))
(cond ( (eq 'ENAME (type (setq ent1 (car ent))))
(if (eq "LWPOLYLINE" (cdr (assoc 0 (entget ent1))))
(progn
(vla-getBoundingBox
(setq obj1 (vlax-ename->vla-object ent1)) 'MiP 'MaP)
(setq bsvec (mapcar (function -)
(vlax-safearray->list MiP)
(setq pt (vlax-curve-getClosestPointto ent1 (cadr ent))))
obj2 (vla-copy obj1) obj1pts (GetVerts ent1)
ent2 (vlax-vla-object->ename obj2))
(while (and (= 5 (car (setq gr (grread 't 5 0)))) (listp (cadr gr)))
(redraw)
(vla-getBoundingBox obj2 'MiP 'MaP)
(vla-move obj2 (vlax-3D-point
(mapcar (function -)
(vlax-safearray->list MiP) bsVec))
(vlax-3D-point (cadr gr)))
(setq obj2pts (getVerts ent2) tmp obj2pts)
(if (not (vlax-invoke obj1 'IntersectWith obj2 acExtendnone))
(progn
(setq obj1pts_new obj1pts)
(while (setq x (car obj1pts_new))
(setq obj3 (vla-addline spc (vlax-3D-point x)
(vlax-3D-point (setq y (car obj2pts)))))
(setq obj2pts_new
(cons
(if (setq int (vl-remove-if
(function
(lambda (x)
(vl-position x tmp)))
(list->3D-point (vlax-invoke obj2 'Intersectwith obj3 acExtendNone))))
(car int) y) obj2pts_new))
(setq obj2pts (cdr obj2Pts) obj1pts_new (cdr obj1pts_new))
(vla-delete obj3))
(setq obj2pts_new (reverse obj2pts_new)))
(setq obj2pts_new obj2pts))
(mapcar
(function
(lambda (from to) (grdraw from to -1 0))) obj1pts obj2pts_new)
(setq obj1pts_new nil obj2pts_new nil)
))
(princ "\n** Object Must be and LWPoly **"))))))
(princ))
(http://www.theswamp.org/screens/leemac/diso1.gif)
I hope this helps clarify your thoughts :-)
Lee
-
Thanks Lee.. ;-)
OK,...as you can see on GIF1
the projection lines are already trimmed..
the challenge is to trim the line who are the part of the second PLINE object (in your case is the ENT2 variable)
ex:
Below RED lines represent the Projection lines (already trimmed)
Blue lines represent what do I need to trim. (part of second entity)
I think this is more thought..
also,...The cube exemple you show on your post is an easy model and can work when removing vertex point..
but what about another geometric model ?...like the picture below ?
-
Ah et puis aussi celle qui part du coin bas gauche
Hey Sergio...come stai ? ;-)
In fact, it is an Open object (Metal Sheet) :-P
-
Ah et puis aussi celle qui part du coin bas gauche
Hey Sergio...come stai ? ;-) Va bene grazie, e tu?
In fact, it is an Open object (Metal Sheet) :-P La prossima volta la imbrocchero giusta, that makes sense adesso