This may work like TORIENT is implemented inside main routine... Note : you must have Express Tools installed...
;; Rotate Blocks at their Centres - Lee Mac ;;; mod by M.R. source link :
;; http://www.cadtutor.net/forum/showthread.php?99538-Insert-Block-at-selected-objects&p=677321&viewfull=1#post677321
(defun c:rotblkcen ( / *error* bln idx ref sel box att obj )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(LM:startundo (LM:acdoc))
(if (and (setq sel (LM:ssget (strcat "\nSelect blocks to rotate at their centres: ") '(((0 . "INSERT")))))
;; Kent Cooper input from another code pasted by M.R.
(not (initget 2)); no zero
(setq *ang
(cond
( (getangle
; [can type in current angle units format, or pick two points;
; returns in radians, nil on Enter]
(strcat
"\nAngle to Rotate each Block <"
(if *ang (angtos *ang) "180")
; offer prior value if present as default, otherwise 180
">: "
); strcat
); getangle
); User-input [other than Enter] condition
(*ang); on Enter with prior value
(pi); on Enter without prior value
); cond
); setq
;; end of input
)
(repeat (setq idx (sslength sel))
(setq bln (cdr (assoc 2 (entget (ssname sel (setq idx (1- idx)))))))
(if (and
(not ; not Xref [no path in Block table listing]
(assoc 1
(tblsearch "block" bln)
); assoc
); not
(setq ref (vlax-ename->vla-object (ssname sel idx))
box (LM:blockreferenceboundingbox ref)
)
)
(progn
(vla-rotate ref
(vlax-3D-point (mapcar '/ (apply 'mapcar (cons '+ box)) '(4.0 4.0)))
*ang
)
;; Kent Cooper input from another code pasted by M.R.
(setq att (vlax-vla-object->ename ref)); starting point for orienting Attributes
(while ; re-orient Attributes if appropriate
(and
(setq att (entnext att))
(setq obj (vlax-ename->vla-object att))
(= (vla-get-ObjectName obj) "AcDbAttribute"); not end yet
); and
(if
(and ; in less-readable direction
(> (vla-get-Rotation obj) (/ pi 2))
(<= (vla-get-Rotation obj) (* pi 1.5))
); and
(vla-rotate obj
(vlax-3d-point (mapcar '/ (apply 'mapcar (cons '+ (acet-geom-textbox (entget att) 0.0))) '(4.0 4.0)))
pi); then -- turn around
); if
); while
;; end of input
)
)
)
)
(LM:endundo (LM:acdoc))
(princ)
)
;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)
;; Block Reference Bounding Box - Lee Mac
;; Returns a WCS point list describing a rectangular frame bounding all geometry of a supplied block reference.
;; Excludes Text, MText & Attribute Definitions.
;; ref - [vla] Block Reference Object
(defun LM:blockreferenceboundingbox ( ref )
(
(lambda ( lst )
(apply
(function
(lambda ( m v )
(mapcar (function (lambda ( p ) (mapcar '+ (mxv m p) v))) lst)
)
)
(refgeom (vlax-vla-object->ename ref))
)
)
(LM:blockdefinitionboundingbox
(vla-item
(vla-get-blocks (vla-get-document ref))
(vla-get-name ref)
)
)
)
)
;; Block Definition Bounding Box - Lee Mac
;; Returns a WCS point list describing a rectangular frame bounding all geometry of a supplied block definition.
;; Excludes Text, MText & Attribute Definitions.
;; def - [vla] Block Definition Object
(defun LM:blockdefinitionboundingbox ( def / llp lst urp )
(vlax-for obj def
(cond
( (= :vlax-false (vla-get-visible obj)))
( (= "AcDbBlockReference" (vla-get-objectname obj))
(setq lst (append lst (LM:blockreferenceboundingbox obj)))
)
( (and (not (wcmatch (vla-get-objectname obj) "AcDbAttributeDefinition,AcDb*Text"))
(vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
)
(setq lst (vl-list* (vlax-safearray->list llp) (vlax-safearray->list urp) lst))
)
)
)
(LM:points->boundingbox lst)
)
;; Points to Bounding Box - Lee Mac
;; Returns the rectangular extents of a supplied point list
(defun LM:points->boundingbox ( lst )
( (lambda ( l )
(mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) l)) a))
'(
(caar cadar)
(caadr cadar)
(caadr cadadr)
(caar cadadr)
)
)
)
(mapcar '(lambda ( f ) (apply 'mapcar (cons f lst))) '(min max))
)
)
;; 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, block or space)
;; Argument : an ename
(defun refgeom ( ent / ang ang mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(mapcar '(lambda ( v ) (trans v 0 ocs 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 enx)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 enx)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 enx)))
)
)
)
)
(mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
(mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
)
)
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Start Undo - Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo - Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Active Document - Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)P.S. It should find centers of blocks according to enames that reside in block and aren't TEXTs, MTEXTs or ATTRIBUTEs...
HTH., M.R.
(If you are satisfied with post, mark it as solution...)
Marko Ribar, d.i.a. (graduated engineer of architecture)
