获得INSERT实体的变换矩阵
 - ;; gc:EnameMatrix (gile)
- ;; Returns the transformation matrix of a block reference,
- ;; the same as the one returnd by (caddr (nentselp)).
- ;;
- ;; Argument
- ;; ename : entity name of the block reference
- (defun gc:EnameMatrix (ename / trp mxv mxm elst ang norm mat)
- ;; 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 (function (lambda (r) (apply '+ (mapcar '* r v))))
- m
- )
- )
- ;; MXM
- ;; Multiply two matrices -Vladimir Nesterovsky-
- (defun mxm (m q)
- (mapcar (function (lambda (r) (mxv (trp q) r))) m)
- )
- ;; Main
- (setq elst (entget ename)
- ang (cdr (assoc 50 elst))
- norm (cdr (assoc 210 elst))
- )
- (append
- (mapcar
- (function (lambda (v1 v2) (append v1 (list v2))))
- (setq
- mat (mxm (mapcar (function (lambda (v) (trans v 0 norm T)))
- '((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
- )
- (mxm (list (list (cos ang) (- (sin ang)) 0.)
- (list (sin ang) (cos ang) 0.)
- '(0. 0. 1.)
- )
- (list (list (cdr (assoc 41 elst)) 0. 0.)
- (list 0. (cdr (assoc 42 elst)) 0.)
- (list 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)))))
- )
- )
- )
- '((0. 0. 0. 1.))
- )
- )
测试代码:
 - (defun c:tt (/ butlast uniformp ms sel num ent mat ent lst)
- (vl-load-com)
- (or *acad* (setq *acad* (vlax-get-acad-object)))
- (or *acdoc* (setq *acdoc* (vla-get-ActiveDocument *acad*)))
- (or *blocks* (setq *blocks* (vla-get-Blocks *acdoc*)))
- ;; butlast
- ;; Return the list but last item
- (defun butlast (l) (reverse (cdr (reverse l))))
- ;; uniformp
- ;; Evaluate if a 4x4 transformation matrix is uniformly scaled
- (defun uniformp (m)
- (setq m (butlast (mapcar 'butlast m)))
- (vl-every
- (function
- (lambda (v)
- (equal (distance '(0. 0. 0.) (car m))
- (distance '(0. 0. 0.) v)
- 1e-12
- )
- )
- )
- m
- )
- )
- ;; Main
- (setq ms (vla-get-ModelSpace *acdoc*))
- (if (setq sel (ssget "_:L" '((0 . "INSERT"))))
- (repeat (setq num (sslength sel))
- (setq mat (gc:EnameMatrix (setq ent (ssname sel (setq num (1- num))))))
- (if (uniformp mat)
- (progn
- (setq lst nil)
- (vlax-for o (vla-Item *blocks* (cdr (assoc 2 (entget ent))))
- (if (wcmatch (vla-get-ObjectName o) "AcDbCircle,AcDbPolyline")
- (setq lst (cons o lst))
- )
- )
- (foreach o (vlax-invoke *acdoc* 'CopyObjects lst ms)
- (vla-transformby o (vlax-tmatrix mat))
- )
- )
- )
- )
- )
- (princ)
- )
|