hi~i found some bug.
if block rotate has error.
circle and LWPOLYLINE has same bug.
CIRCLE i fix easier than LWPOLYLINE,is not angle question.
but LWPOLYLINE i dont know how to fix.
(defun c:CTR (/ *error* i cpt dc el ent vals vars _Entsel _StartUndo _EndUndo doc _MCS-to-WCS p1 p2 p3 p4 rad cens lttype censc_list cendd cenlt censc npt ep sp ept spt bu)
(defun *error* (msg)
(_EndUndo doc)
(mapcar 'setvar vars vals)
(princ msg)
)
(defun _Nentsel (pr / ent)
(setvar "errno" 0)
(while (and (not (setq ent (nentsel pr)))(= (getvar "errno") 7))
(princ "\n->select circle:")
)
ent
)
(defun _MCS-to-WCS (pt mx)
(list
(+
(* (car (car mx)) (car pt))
(* (car (cadr mx)) (cadr pt))
(* (car (caddr mx)) (caddr pt))
(car (cadddr mx))
)
(+
(* (cadr (car mx)) (car pt))
(* (cadr (cadr mx)) (cadr pt))
(* (cadr (caddr mx)) (caddr pt))
(cadr (cadddr mx))
)
(+
(* (caddr (car mx)) (car pt))
(* (caddr (cadr mx)) (cadr pt))
(* (caddr (caddr mx)) (caddr pt))
(caddr (cadddr mx))
)
)
)
;| Description:
TransNested (original code by gile on TheSwamp.org)
Translates a point coordinates from WCS or UCS to RCS -coordinates system of a
reference (xref or block) whatever its nested level-
|;
(defun _TransNested (pt rlst from to / geom mxm mxv RefGeom RevRefGeom trp vxv)
;; 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)
)
;; Main Function.
(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)
) ;; End Function (_TransNested)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq vars '("cmdecho" "CELTSCALE" "cecolor" "celtype" "osmode")
vals (mapcar 'getvar vars)
)
(setq cens (getvar "CELTSCALE"))
(setvar "cmdecho" 0)
(_StartUndo doc)
(if (= (tblsearch "ltype" "center") nil)
(vl-cmdf "_.-linetype" "_load" "center" "acadiso.lin" "")
)
(setq lttype (cdr (assoc 49 (tblsearch "ltype" "CENTER"))))
(if (or (= lttype 31.75) (= lttype 19.05) (= lttype 63.5))
(setq censc_list 50.8)
(setq censc_list (/ 50.8 25.4))
)
(mapcar 'setvar (cddr vars) '("1" "CENTER" 0))
(while (setq ent (_Nentsel "\n->select circle:"))
(setq enm (cdr (assoc 0 (setq el (entget (car ent))))))
(cond
((wcmatch enm "ARC,CIRCLE")
[color=red](if (= (car (car (caddr ent))) (cadr (cadr (caddr ent))))
(progn
(if (> (length ent) 2)(setq cpt (_MCS-to-WCS (cdr (assoc 10 el)) (cons (cons 0.0 (cons 0.0 (list 1.0))) (cons (cons 0.0 (cons (cdr (assoc 42 (entget (car (cadddr ent))))) (list 0.0))) (cons (cons (cdr (assoc 41 (entget (car (cadddr ent))))) (list 0.0 0.0)) (list (cadddr (caddr ent))) ))) ))(setq cpt (cdr (assoc 10 el))))
(if (and (car (car (caddr ent))) (and (= (cdr (assoc 41 (entget (car (cadddr ent))))) (cdr (assoc 42 (entget (car (cadddr ent))))) ) (= (cdr (assoc 41 (entget (car (reverse (cadddr ent)))))) (cdr (assoc 42 (entget (car (reverse (cadddr ent)))))) ) ));and
(progn
(if (> (length (cadddr ent)) 1)
(setq rad (* (cdr (assoc 40 el)) (cdr (assoc 41 (entget (car (cadddr ent))))) (cdr (assoc 41 (entget (car (reverse (cadddr ent)))))) ))
(setq rad (* (cdr (assoc 40 el)) (cdr (assoc 41 (entget (car (cadddr ent))))) ))
);if
);progn[/color]
(setq rad (cdr (assoc 40 el)))
);if
(setq dc (/ (* rad 2) 20)
cendd (+ rad dc)
cenlt (getvar "LTSCALE")
censc (* (/ 1 cenlt) (/ (* cendd 2) censc_list))
p1 (list (car cpt) (+ (cadr cpt) cendd) (caddr cpt))
p2 (list (car cpt) (- (cadr cpt) cendd) (caddr cpt))
p3 (list (+ (car cpt) cendd) (cadr cpt) (caddr cpt))
p4 (list (- (car cpt) cendd) (cadr cpt) (caddr cpt))
)
(setvar "CELTSCALE" censc)
(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
(entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))
(setvar "CELTSCALE" cens)
);progn
(princ "\n->not circle。")
);if
)
((= enm "LWPOLYLINE")
(if (= (car (car (caddr ent))) (cadr (cadr (caddr ent))))
(progn
(setq obj (vlax-ename->vla-object (car ent))
npt (if (> (length ent) 2)
(vlax-curve-getClosestPointTo obj (_TransNested (cadr ent) (last ent) 1 2))
(vlax-curve-getClosestPointTo obj (cadr ent))
)
ep (fix (vlax-curve-getEndParam obj))
)
(if (= ep (setq sp (fix (vlax-curve-getParamAtPoint obj npt))))
(setq sp (1- sp))
(setq ep (1+ sp))
)
(setq spt (vlax-curve-getPointAtParam obj sp)
ept (vlax-curve-getPointAtParam obj ep)
)
(while (and el (not (equal (cdr (assoc 10 el)) (reverse (cdr (reverse spt))) 1e-6)))
(setq el (cdr (member (Assoc 10 el) el)))
)
(setq el (cdr (member (Assoc 10 el) el)))
(if (not (equal (setq bu (cdr (assoc 42 el))) 0.0 1e-6))
(progn
(setq ang (* 2.0 (atan bu))
rad (/ (distance spt ept) (* 2.0 (sin ang)))
cpt (polar spt (+ (- (/ pi 2.0) ang) (angle spt ept)) rad)
cpt (if (> (length ent) 2)(_MCS-to-WCS cpt (caddr ent)) cpt)
)
(if (car (car (caddr ent))) (setq rad (* (abs rad) (car (car (caddr ent))) ))
(setq rad (abs rad)) );if
(setq dc (/ (* rad 2) 20)
cendd (+ rad dc)
cenlt (getvar "LTSCALE")
censc (* (/ 1 cenlt) (/ (* cendd 2) censc_list))
p1 (list (car cpt) (+ (cadr cpt) cendd) (caddr cpt))
p2 (list (car cpt) (- (cadr cpt) cendd) (caddr cpt))
p3 (list (+ (car cpt) cendd) (cadr cpt) (caddr cpt))
p4 (list (- (car cpt) cendd) (cadr cpt) (caddr cpt))
)
(setvar "CELTSCALE" censc)
(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
(entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))
(setvar "CELTSCALE" cens)
);progn
(princ "\n->not circle。")
);if
);progn
(princ "\n->not circle。")
);if
)
(T (princ "\n->not circle。"))
);cond
);while
(mapcar 'setvar vars vals)
(_EndUndo doc)
(princ)
)
or has code can fix XY scacle?