@imegusta02 hi,
Attached ConnectStackedBlocks command to do want you after.
it start by asking [Select object(s)], select all your blocks (only 1 group of array). the block name does not
matter as long as it is dynamic and it has the TOP\BOTTOM dynamic properties.
The array must be rectangle align to WCS.
The blocks in a row must be aligned (same y) but small Y_FAZZ (default = 0.02) is allowed to consider them on the same row. the same rule is applied between 2 close blocks: Bottom and Top. if x value of both is equal or within X_FAZZ (default = 0.02), they consider one above other.
X_FAZZ and Y_FAZZ are 2 constant variables define at the start of the command. if you need a different fuzz, you are invite to reset them.
line 215 => (setq X_FAZZ 1e-2 Y_FAZZ 1e-2) ; const
1e-2 is equal to 0.02 😀
if the array contains blocks that are not dynamic and\or does not have the TOP\BOTTOM properties they are skipped.
if the program cannot find the matched block (same x) the block below is skipped.
if the array has empty space (missing block) the block bellow is skipped.
i use (entmake) function to draw the lines to achieve maximum drawing speed.
In your sample dwg, the first block (the bottom left) has no dynamic properties - is this ok?
Special thanks to Gils from France and Lee Mac for providing us (the world) these beautiful functions without them this program would not be made.
enjoy
Moshe
(vl-load-com) ; load activex suppport
;; TransNested (gile)
;; Translates a point coordinates from WCS or UCS to RCS -coordinates system of a
;; reference (xref or block) whatever its nested level-
;;
;; Arguments
;; pt : the point to translate
;; rlst : the parents entities list from the deepest nested to the one inserted in
;; current space -same as (last (nentsel)) or (last (nentselp))
;; from to : as with trans function: 0 for WCS, 1 for current UCS, 2 for RCS
(defun TransNested (pt rlst from to)
(setq mat '((1 0 0) (0 1 0) (0 0 1)))
(and (= 1 from) (setq pt (trans pt 1 0)))
(and (= 2 to) (setq rlst (reverse rlst)))
(and (or (= 2 from) (= 2 to))
(while rlst
(setq geom (if (= 2 to)
(RevRefGeom (car rlst))
(RefGeom (car rlst))
)
rlst (cdr rlst)
pt (mapcar '+ (mxv (car geom) pt) (cadr geom))
)
)
)
(if (= 1 to)
(trans pt 0 1)
pt
)
)
;; RefGeom (gile)
;; Returns a list which first item is a 3x3 transformation matrix (rotation,
;; scales, normal) and second item the object insertion point in its parent
;; (xref, bloc or space)
;;
;; Argument : an ename
(defun RefGeom (ename / elst ang norm mat)
(setq elst (entget ename)
ang (cdr (assoc 50 elst))
norm (cdr (assoc 210 elst))
)
(list
(setq mat
(mxm
(mapcar (function (lambda (v) (trans v 0 norm T)))
'((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
)
(mxm
(list (list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(list (list (cdr (assoc 41 elst)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 elst)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 elst)))
)
)
)
)
(mapcar
'-
(trans (cdr (assoc 10 elst)) norm 0)
(mxv mat
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))
)
)
)
)
;; RevRefGeom (gile)
;; RefGeom inverse function
(defun RevRefGeom (ename / entData ang norm mat)
(setq entData (entget ename)
ang (- (cdr (assoc 50 entData)))
norm (cdr (assoc 210 entData))
)
(list
(setq mat
(mxm
(list (list (/ 1 (cdr (assoc 41 entData))) 0.0 0.0)
(list 0.0 (/ 1 (cdr (assoc 42 entData))) 0.0)
(list 0.0 0.0 (/ 1 (cdr (assoc 43 entData))))
)
(mxm
(list (list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar (function (lambda (v) (trans v norm 0 T)))
'((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
)
)
)
)
(mapcar '-
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 entData)))))
(mxv mat (trans (cdr (assoc 10 entData)) norm 0))
)
)
)
;;; VXV Returns the dot product of 2 vectors
(defun vxv (v1 v2)
(apply '+ (mapcar '* v1 v2))
)
;; TRP Transpose a matrix -Doug Wilson-
(defun trp (m)
(apply 'mapcar (cons 'list m))
)
;; MXV Apply a transformation matrix to a vector -Vladimir Nesterovsky-
(defun mxv (m v)
(mapcar '(lambda (r) (vxv r v)) m)
)
;; MXM Multiply two matrices -Vladimir Nesterovsky-
(defun mxm (m q)
(mapcar '(lambda (r) (mxv (trp q) r)) m)
)
; ==================================================================================================================================
;; Get Dynamic Block Property Value - Lee Mac
;; Returns the value of a Dynamic Block property (if present)
;; blk - [vla] VLA Dynamic Block Reference object
;; prp - [str] Dynamic Block property name (case-insensitive)
(defun LM:getdynpropvalue ( blk prp )
(setq prp (strcase prp))
(vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
(vlax-invoke blk 'getdynamicblockproperties)
)
)
; ==================================================================================================================================
(defun C:ConnectStackedBlocks (/ isDynamicBlock build_data_list get_match_block_above drawline ; local functions
X_FAZZ Y_FAZZ dynamicBlocks^ adoc blocks bname ss i item0 item1 ; local variables
ename0 ename1 lst AcDbBlkRef0 AcDbBlkRef1 dx0 dy0 dx1 dy1 p0 p1 p2 p3) ; local variables
(defun isDynamicBlock (ent / bname)
(setq bname (cdr (assoc '2 (entget ent))))
(cond
((member bname dynamicBlocks^)
:vlax-true
); case
((eq (vla-get-isDynamicBlock (vla-item blocks bname)) :vlax-false)
:vlax-false
); case
( t
(setq dynamicBlocks^ (cons bname dynamicBlocks^))
:vlax-true
); case
); cond
); isDynamicBlock
(defun build_data_list (ss / lst ename pt item)
(foreach ename (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq pt (cdr (assoc '10 (entget ename))))
(if (eq (isDynamicBlock ename) :vlax-true)
(cond
((not (vl-some '(lambda (item) (equal (car item) (cadr pt) X_FAZZ)) lst))
(setq lst (cons (cons (cadr pt) (list ename)) lst))
); case
( t
(setq lst (vl-remove (setq item (assoc (cadr pt) lst)) lst))
(setq lst (cons (cons (car item) (cons ename (cdr item))) lst))
); case
); cond
); if
); foreach
lst
); build_data_list
(defun get_match_block_above (ename0 item1 / pt0)
(setq pt0 (cdr (assoc '10 (entget ename0))))
(vl-some
'(lambda (ename1 / pt1)
(setq pt1 (cdr (assoc '10 (entget ename1))))
(if (equal (car pt0) (car pt1) Y_FAZZ)
ename1 ; return
)
); lambda
(cdr item1)
); vl-some
); get_match_block_above
(defun drawline (t0 t1)
(entmake
(list
'(0 . "LINE")
(cons 10 t0)
(cons 11 t1)
)
)
); drawline
; here start C:ConnectStackedBlocks
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startUndoMark adoc)
(setq X_FAZZ 1e-2 Y_FAZZ 1e-2) ; const
(setq blocks (vla-get-blocks adoc))
(if (setq ss (ssget (list '(0 . "insert"))))
(progn
(setq lst (vl-sort (build_data_list ss) (function (lambda (e0 e1) (< (car e0) (car e1))))))
(setq i 0 item0 (nth i lst))
(repeat (vl-list-length lst) ; loop main list
(setq i (1+ i) item1 (nth i lst))
(foreach ename0 (cdr item0) ; loop through bottom objects
(if (setq ename1 (get_match_block_above ename0 item1)) ; get match block from above
(progn
(setq AcDbBlkRef0 (vlax-ename->vla-object ename0))
(setq AcDbBlkRef1 (vlax-ename->vla-object ename1))
(if (and
(setq dx0 (LM:getdynpropvalue AcDbBlkRef0 "top x"))
(setq dy0 (LM:getdynpropvalue AcDbBlkRef0 "top y"))
(setq dx1 (LM:getdynpropvalue AcDbBlkRef1 "bottom x"))
(setq dy1 (LM:getdynpropvalue AcDbBlkRef1 "bottom y"))
(setq p0 (TransNested (list dx0 dy0 0.0) (list ename0) 2 1))
(setq p1 (list (+ (car p0) 0.1) (cadr p0)))
(setq p2 (TransNested (list dx1 dy1 0.0) (list ename1) 2 1))
(setq p3 (list (+ (car p2) 0.1) (cadr p2)))
)
(progn
(drawline p0 p2) ; main wire
(drawline p1 p3) ; paralle wire
); progn
); if
(vlax-release-object AcDbBlkRef1)
(vlax-release-object AcDbBlkRef0)
); progn
); if
); foreach
(setq item0 item1)
); repeat
); progn
); if
(vlax-release-object blocks)
(vla-endUndoMark adoc)
(vlax-release-object adoc)
(princ)
); C:ConnectStackedBlocks
