Array Block - Aligned Distance
Hi All,Im trying to achieve a path array so that the chord distance (aligned distance) is constant.
Similar to the lisp that Lee Mac has created here but for aligned distance between points or better still a block.
http://www.cadtutor.net/forum/showthread.php?82224-Measure-or-Divide-object-without-use-aligned-distance... Try this, based on Lee's code...
This is from half of distance from start point of curve...
(defun c:mymeasure-bl ( / *error* bd bn ci cm di en il im in io ob p1 p2 sp ) ;(setq bn "x") ;; Name of block to insert (setq bn (getstring t "\nEnter block Name: ")) (defun *error* ( msg ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if (and (= 'vla-object (type ci)) (not (vlax-erased-p ci))) (vl-catch-all-apply 'vla-delete (list ci)) ) (if (= 'int (type cm)) (setvar 'cmdecho cm) ) (if msg (princ (strcat "\nError: " msg)) ) (princ) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (cond ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (princ "\nCurrent layer locked.") ) ( (not (or (tblsearch "block" bn) (and (setq bd (findfile (strcat bn ".dwg"))) (progn (setq cm (getvar 'cmdecho)) (setvar 'cmdecho 0) (command "_.-insert" bd nil) (setvar 'cmdecho cm) (tblsearch "block" bn) ) ) ) ) (princ (strcat "\nBlock \"" bn "\" not found.")) ) ( (progn (while (progn (setvar 'errno 0) (setq en (car (entsel "\nSelect object to measure: "))) (cond ( (= 7 (getvar 'errno)) (princ "\nMissed, try again.") ) ( (= 'ename (type en)) (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list en))) (princ "\nInvalid object selected.") ) ) ) ) ) (/= 'ename (type en)) ) ) ( (progn (initget 7) (setq di (getdist "\nSpecify length of segment: ")) ) (setq p1 (vlax-curve-getstartpoint en) p2 (vlax-curve-getendpoint en) ob (vlax-ename->vla-object en) sp (vlax-get-property (vla-get-activedocument (vlax-get-acad-object)) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace ) ) ci (vlax-invoke sp 'addcircle p1 (/ di 2.0)) ) (if (setq il (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0))) (vlax-invoke sp 'insertblock il bn 1.0 1.0 1.0 (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ob (vlax-curve-getparamatpoint ob il)))) ) (vla-delete ci) (setq ci (vlax-invoke sp 'addcircle il di)) (if (setq im (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0))) (vlax-invoke sp 'insertblock im bn 1.0 1.0 1.0 (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ob (vlax-curve-getparamatpoint ob im)))) ) (vla-delete ci) (setq ci (vlax-invoke sp 'addcircle im di)) (setq io T) (while io (if (setq in (list (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0)) (if (= (length (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))) 3) (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))))) (progn (setq io (apply 'append (vl-remove-if '(lambda ( x ) (equal x il 1e-6)) in))) (if io (vlax-invoke sp 'insertblock io bn 1.0 1.0 1.0 (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ob (vlax-curve-getparamatpoint ob io)))) ) ) ) (vla-delete ci) (if io (setq ci (vlax-invoke sp 'addcircle io di))) (setq il im im io) ) ) ) (*error* nil) (princ))(vl-load-com) (princ)M.R.
P.S. Of course it will work in situations if curve path isn't self-crossing or curving too much and if path isn't 3d curve... This one is from start point of curve...
(defun c:mymeasure-bl ( / *error* bd bn ci cm di en il im in io ob p1 p2 sp ) ;(setq bn "x") ;; Name of block to insert (setq bn (getstring t "\nEnter block Name: ")) (defun *error* ( msg ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if (and (= 'vla-object (type ci)) (not (vlax-erased-p ci))) (vl-catch-all-apply 'vla-delete (list ci)) ) (if (= 'int (type cm)) (setvar 'cmdecho cm) ) (if msg (princ (strcat "\nError: " msg)) ) (princ) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (cond ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (princ "\nCurrent layer locked.") ) ( (not (or (tblsearch "block" bn) (and (setq bd (findfile (strcat bn ".dwg"))) (progn (setq cm (getvar 'cmdecho)) (setvar 'cmdecho 0) (command "_.-insert" bd nil) (setvar 'cmdecho cm) (tblsearch "block" bn) ) ) ) ) (princ (strcat "\nBlock \"" bn "\" not found.")) ) ( (progn (while (progn (setvar 'errno 0) (setq en (car (entsel "\nSelect object to measure: "))) (cond ( (= 7 (getvar 'errno)) (princ "\nMissed, try again.") ) ( (= 'ename (type en)) (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list en))) (princ "\nInvalid object selected.") ) ) ) ) ) (/= 'ename (type en)) ) ) ( (progn (initget 7) (setq di (getdist "\nSpecify length of segment: ")) ) (setq p1 (vlax-curve-getstartpoint en) p2 (vlax-curve-getendpoint en) ob (vlax-ename->vla-object en) sp (vlax-get-property (vla-get-activedocument (vlax-get-acad-object)) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace ) ) ) (if (setq il p1) (vlax-invoke sp 'insertblock il bn 1.0 1.0 1.0 (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ob (vlax-curve-getparamatpoint ob il)))) ) (setq ci (vlax-invoke sp 'addcircle il di)) (if (setq im (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0))) (vlax-invoke sp 'insertblock im bn 1.0 1.0 1.0 (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ob (vlax-curve-getparamatpoint ob im)))) ) (vla-delete ci) (setq ci (vlax-invoke sp 'addcircle im di)) (setq io T) (while io (if (setq in (list (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0)) (if (= (length (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))) 3) (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))))) (progn (setq io (apply 'append (vl-remove-if '(lambda ( x ) (equal x il 1e-6)) in))) (if io (vlax-invoke sp 'insertblock io bn 1.0 1.0 1.0 (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ob (vlax-curve-getparamatpoint ob io)))) ) ) ) (vla-delete ci) (if io (setq ci (vlax-invoke sp 'addcircle io di))) (setq il im im io) ) ) ) (*error* nil) (princ))(vl-load-com) (princ)
M.R. Thanks so much Marko, this works great.
Any chance of changing the blocks rotation angle from tangent with the curve to just 0 degrees for all.
Or even better that the rotation of a block, is the same angle as a line drawn from the blocks insertion point to the next blocks insertion point. Maybe this, but note that last inserted block doesn't have next reference block from witch it would get alignment, so rotation of last and one block before last one is the same...
This is from half of distance from start point of curve...
(defun c:mymeasure-bl ( / *error* bd bn ci cm di el en il im in io ob p1 p2 sp ) ;(setq bn "x") ;; Name of block to insert (setq bn (getstring t "\nEnter block Name: ")) (defun *error* ( msg ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if (and (= 'vla-object (type ci)) (not (vlax-erased-p ci))) (vl-catch-all-apply 'vla-delete (list ci)) ) (if (= 'int (type cm)) (setvar 'cmdecho cm) ) (if msg (princ (strcat "\nError: " msg)) ) (princ) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (cond ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (princ "\nCurrent layer locked.") ) ( (not (or (tblsearch "block" bn) (and (setq bd (findfile (strcat bn ".dwg"))) (progn (setq cm (getvar 'cmdecho)) (setvar 'cmdecho 0) (command "_.-insert" bd nil) (setvar 'cmdecho cm) (tblsearch "block" bn) ) ) ) ) (princ (strcat "\nBlock \"" bn "\" not found.")) ) ( (progn (while (progn (setvar 'errno 0) (setq en (car (entsel "\nSelect object to measure: "))) (cond ( (= 7 (getvar 'errno)) (princ "\nMissed, try again.") ) ( (= 'ename (type en)) (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list en))) (princ "\nInvalid object selected.") ) ) ) ) ) (/= 'ename (type en)) ) ) ( (progn (initget 7) (setq di (getdist "\nSpecify length of segment: ")) ) (setq p1 (vlax-curve-getstartpoint en) p2 (vlax-curve-getendpoint en) ob (vlax-ename->vla-object en) sp (vlax-get-property (vla-get-activedocument (vlax-get-acad-object)) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace ) ) ci (vlax-invoke sp 'addcircle p1 (/ di 2.0)) ) (if (setq il (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0))) (vlax-invoke sp 'insertblock il bn 1.0 1.0 1.0 0.0) ) (setq el (entlast)) (vla-delete ci) (setq ci (vlax-invoke sp 'addcircle il di)) (if (setq im (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0))) (vlax-invoke sp 'insertblock im bn 1.0 1.0 1.0 0.0) ) (vla-put-rotation (vlax-ename->vla-object el) (angle il im)) (setq el (entlast)) (vla-delete ci) (setq ci (vlax-invoke sp 'addcircle im di)) (setq io T) (while io (if (setq in (list (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0)) (if (= (length (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))) 3) (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))))) (progn (setq io (apply 'append (vl-remove-if '(lambda ( x ) (equal x il 1e-6)) in))) (if io (progn (vla-put-rotation (vlax-ename->vla-object el) (angle im io)) (vlax-invoke sp 'insertblock io bn 1.0 1.0 1.0 (angle im io)) (setq el (entlast)) ) ) ) ) (vla-delete ci) (if io (setq ci (vlax-invoke sp 'addcircle io di))) (setq il im im io) ) ) ) (*error* nil) (princ))(vl-load-com) (princ)
M.R. This one is from start point of curve...
(defun c:mymeasure-bl ( / *error* bd bn ci cm di el en il im in io ob p1 p2 sp ) ;(setq bn "x") ;; Name of block to insert (setq bn (getstring t "\nEnter block Name: ")) (defun *error* ( msg ) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if (and (= 'vla-object (type ci)) (not (vlax-erased-p ci))) (vl-catch-all-apply 'vla-delete (list ci)) ) (if (= 'int (type cm)) (setvar 'cmdecho cm) ) (if msg (princ (strcat "\nError: " msg)) ) (princ) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) (cond ( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer)))))) (princ "\nCurrent layer locked.") ) ( (not (or (tblsearch "block" bn) (and (setq bd (findfile (strcat bn ".dwg"))) (progn (setq cm (getvar 'cmdecho)) (setvar 'cmdecho 0) (command "_.-insert" bd nil) (setvar 'cmdecho cm) (tblsearch "block" bn) ) ) ) ) (princ (strcat "\nBlock \"" bn "\" not found.")) ) ( (progn (while (progn (setvar 'errno 0) (setq en (car (entsel "\nSelect object to measure: "))) (cond ( (= 7 (getvar 'errno)) (princ "\nMissed, try again.") ) ( (= 'ename (type en)) (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list en))) (princ "\nInvalid object selected.") ) ) ) ) ) (/= 'ename (type en)) ) ) ( (progn (initget 7) (setq di (getdist "\nSpecify length of segment: ")) ) (setq p1 (vlax-curve-getstartpoint en) p2 (vlax-curve-getendpoint en) ob (vlax-ename->vla-object en) sp (vlax-get-property (vla-get-activedocument (vlax-get-acad-object)) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace ) ) ) (if (setq il p1) (vlax-invoke sp 'insertblock il bn 1.0 1.0 1.0 0.0) ) (setq el (entlast)) (setq ci (vlax-invoke sp 'addcircle il di)) (if (setq im (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0))) (vlax-invoke sp 'insertblock im bn 1.0 1.0 1.0 0.0) ) (vla-put-rotation (vlax-ename->vla-object el) (angle il im)) (setq el (entlast)) (vla-delete ci) (setq ci (vlax-invoke sp 'addcircle im di)) (setq io T) (while io (if (setq in (list (mapcar '+ (vlax-invoke ob 'intersectwith ci acextendnone) '(0.0 0.0 0.0)) (if (= (length (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))) 3) (cdddr (vlax-invoke ob 'intersectwith ci acextendnone))))) (progn (setq io (apply 'append (vl-remove-if '(lambda ( x ) (equal x il 1e-6)) in))) (if io (progn (vla-put-rotation (vlax-ename->vla-object el) (angle im io)) (vlax-invoke sp 'insertblock io bn 1.0 1.0 1.0 (angle im io)) (setq el (entlast)) ) ) ) ) (vla-delete ci) (if io (setq ci (vlax-invoke sp 'addcircle io di))) (setq il im im io) ) ) ) (*error* nil) (princ))(vl-load-com) (princ)
M.R. Thanks heaps Marko, u have saved me loads of time doing this manually, as I have a few hundred blocks arrayed end to end. The rotation angle is exactly right! :thumbup: I am glad I could help, but most of all thank to Mr. Lee Mac for posting main body of the code...
You're very welcome...
M.R.
页:
[1]