求改块基点源码

weiqi · 发表于 2015-7-23 16:03:58

求像贱人工具求改块基点源码....

fan_zh · 发表于 2015-7-23 16:03:59

;; -- Retains Insertion Point --
(defun c:CBI nil (ChangeBlockInsertion nil))
;; -- Retains Block Position --
(defun c:CBIR nil (ChangeBlockInsertion t))
;;------------------------------------------------------------;;
;; Local Functions ;;
;;------------------------------------------------------------;;
(defun ChangeBlockInsertion
( retainposition / *error* _StartUndo _EndUndo acblk acdoc blk bn cmd lst mat p1 p2 pt vec )
(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(if cmd (setvar 'CMDECHO cmd))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)
(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
acblk (vla-get-blocks acdoc)
cmd (getvar 'CMDECHO)
)
(setvar 'CMDECHO 0)
(if
(and
(setq blk
(car
(LM:Selectif "\nSelect Block: "
'(lambda ( x ) (eq "INSERT" (cdr (assoc 0 (entget (car x)))))) entsel nil
)
)
)
(setq pt (getpoint "\nSpecify New Base Point: "))
)
(progn
(_StartUndo acdoc)
(setq lst (entget blk) mat (LM:Ref->Def blk))
(setq vec
(mxv (car mat)
(mapcar '- (trans pt 1 0) (trans (cdr (assoc 10 lst)) blk 0))
)
)
(setq p1 (vlax-3D-point vec)
p2 (vlax-3D-point '(0. 0. 0.))
)
(vlax-for obj (vla-item acblk (setq bn (cdr (assoc 2 lst)))) (vla-Move obj p1 p2))
(if retainposition
(vlax-for block acblk
(if (eq :vlax-false (vla-get-isXref block))
(vlax-for obj block
(if
(and
(eq "AcDbBlockReference" (vla-get-objectname obj))
(eq bn (vla-get-name obj))
)
(vla-move obj p2 (vlax-3D-point (mxv (car (LM:Def->Ref (vlax-vla-object->ename obj))) vec)))
)
)
)
)
)
(if (= 1 (cdr (assoc 66 lst)))
(vl-cmdf "_.attsync" "_N" (cdr (assoc 2 lst)))
)
(vla-regen acdoc acAllViewports)
(_EndUndo acdoc)
)
)
(setvar 'CMDECHO cmd)
(princ)
)
;;---------------=={ Block Ref -> Block Def }==---------------;;
;; ;;
;; Returns the Transformation Matrix and Translation Vector ;;
;; for transforming Block Reference Geometry to the Block ;;
;; Definiton. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; e - Block Reference Entity ;;
;;------------------------------------------------------------;;
;; Returns: List of 3x3 Transformation Matrix, Vector ;;
;;------------------------------------------------------------;;
(defun LM:Ref->Def ( e / _dxf a l n )
(defun _dxf ( x l ) (cdr (assoc x l)))
(setq l (entget e) a (- (_dxf 50 l)) n (_dxf 210 l))
(
(lambda ( m )
(list m
(mapcar '- (_dxf 10 (tblsearch "BLOCK" (_dxf 2 l)))
(mxv m
(trans (_dxf 10 l) n 0)
)
)
)
)
(mxm
(list
(list (/ 1. (_dxf 41 l)) 0. 0.)
(list 0. (/ 1. (_dxf 42 l)) 0.)
(list 0. 0. (/ 1. (_dxf 43 l)))
)
(mxm
(list
(list (cos a) (sin (- a)) 0.)
(list (sin a) (cos a) 0.)
(list 0. 0. 1.)
)
(mapcar '(lambda ( e ) (trans e n 0 t))
'(
(1. 0. 0.)
(0. 1. 0.)
(0. 0. 1.)
)
)
)
)
)
)
;;---------------=={ Block Def -> Block Ref }==---------------;;
;; ;;
;; Returns the Transformation Matrix and Translation Vector ;;
;; for transforming Block Definition Geometry to a Block ;;
;; Reference. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; e - Block Reference Entity ;;
;;------------------------------------------------------------;;
;; Returns: List of 3x3 Transformation Matrix, Vector ;;
;;------------------------------------------------------------;;
(defun LM:Def->Ref ( e / _dxf a l n )
(defun _dxf ( x l ) (cdr (assoc x l)))
(setq l (entget e) a (_dxf 50 l) n (_dxf 210 l))
(
(lambda ( m )
(list m
(mapcar '- (trans (_dxf 10 l) n 0)
(mxv m
(_dxf 10 (tblsearch "BLOCK" (_dxf 2 l)))
)
)
)
)
(mxm
(mapcar '(lambda ( e ) (trans e 0 n t))
'(
(1. 0. 0.)
(0. 1. 0.)
(0. 0. 1.)
)
)
(mxm
(list
(list (cos a) (sin (- a)) 0.)
(list (sin a) (cos a) 0.)
(list 0. 0. 1.)
)
(list
(list (_dxf 41 l) 0. 0.)
(list 0. (_dxf 42 l) 0.)
(list 0. 0. (_dxf 43 l))
)
)
)
)
)
;;---------------------=={ Select if }==----------------------;;
;; ;;
;; Provides continuous selection prompts until either a ;;
;; predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; msg - prompt string ;;
;; pred - optional predicate function [selection list arg] ;;
;; func - selection function to invoke ;;
;; keyw - optional initget argument list ;;
;;------------------------------------------------------------;;
;; Returns: Entity selection list, keyword, or nil ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'STR (type sel))
nil
)
( (vl-consp sel)
(if (and pred (not (pred sel)))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
sel
)
;; Matrix x Vector ~ Vladimir Nesterovsky
(defun mxv ( mat vec )
(mapcar '(lambda ( row ) (apply '+ (mapcar '* row vec))) mat)
)
;; Matrix x Matrix ~ Vladimir Nesterovsky
(defun mxm ( m q )
(mapcar (function (lambda ( r ) (mxv (trp q) r))) m)
)
;; Matrix Transpose ~ Doug Wilson
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
(vl-load-com) (princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;

;; -- Retains Insertion Point -- 
(defun c:CBI  nil (ChangeBlockInsertion nil)) 
 
;; -- Retains Block Position -- 
(defun c:CBIR nil (ChangeBlockInsertion   t)) 
 
;;------------------------------------------------------------;; 
;;                     Local Functions                        ;; 
;;------------------------------------------------------------;; 
 
(defun ChangeBlockInsertion 
 
  ( retainposition / *error* _StartUndo _EndUndo acblk acdoc blk bn cmd lst mat p1 p2 pt vec ) 
   
  (defun *error* ( msg ) 
    (if acdoc (_EndUndo acdoc)) 
    (if cmd   (setvar 'CMDECHO cmd)) 
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") 
        (princ (strcat "\n** Error: " msg " **"))) 
    (princ) 
  ) 
 
  (defun _StartUndo ( doc ) (_EndUndo doc) 
    (vla-StartUndoMark doc) 
  ) 
 
  (defun _EndUndo ( doc ) 
    (if (= 8 (logand 8 (getvar 'UNDOCTL))) 
      (vla-EndUndoMark doc) 
    ) 
  ) 
 
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        acblk (vla-get-blocks acdoc) 
        cmd   (getvar 'CMDECHO) 
  ) 
  (setvar 'CMDECHO 0) 
 
  (if 
    (and 
      (setq blk 
        (car 
          (LM:Selectif "\nSelect Block: " 
           '(lambda ( x ) (eq "INSERT" (cdr (assoc 0 (entget (car x)))))) entsel nil 
          ) 
        ) 
      ) 
      (setq pt (getpoint "\nSpecify New Base Point: ")) 
    ) 
    (progn 
      (_StartUndo acdoc) 
 
      (setq lst (entget blk) mat (LM:Ref->Def blk)) 
      (setq vec 
        (mxv (car mat) 
          (mapcar '- (trans pt 1 0) (trans (cdr (assoc 10 lst)) blk 0)) 
        ) 
      ) 
      (setq p1 (vlax-3D-point vec) 
            p2 (vlax-3D-point '(0. 0. 0.)) 
      ) 
      (vlax-for obj (vla-item acblk (setq bn (cdr (assoc 2 lst)))) (vla-Move obj p1 p2)) 
 
      (if retainposition 
        (vlax-for block acblk 
          (if (eq :vlax-false (vla-get-isXref block)) 
            (vlax-for obj block 
              (if 
                (and 
                  (eq "AcDbBlockReference" (vla-get-objectname obj)) 
                  (eq bn (vla-get-name obj)) 
                ) 
                (vla-move obj p2 (vlax-3D-point (mxv (car (LM:Def->Ref (vlax-vla-object->ename obj))) vec))) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (if (= 1 (cdr (assoc 66 lst))) 
        (vl-cmdf "_.attsync" "_N" (cdr (assoc 2 lst))) 
      ) 
      (vla-regen acdoc acAllViewports) 
      (_EndUndo acdoc) 
    ) 
  ) 
  (setvar 'CMDECHO cmd) 
  (princ) 
) 
 
;;---------------=={ Block Ref -> Block Def }==---------------;; 
;;                                                            ;; 
;;  Returns the Transformation Matrix and Translation Vector  ;; 
;;  for transforming Block Reference Geometry to the Block    ;; 
;;  Definiton.                                                ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright  2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  e - Block Reference Entity                                ;; 
;;------------------------------------------------------------;; 
;;  Returns:  List of 3x3 Transformation Matrix, Vector       ;; 
;;------------------------------------------------------------;; 
 
(defun LM:Ref->Def ( e / _dxf a l n ) 
 
  (defun _dxf ( x l ) (cdr (assoc x l))) 
 
  (setq l (entget e) a (- (_dxf 50 l)) n (_dxf 210 l)) 
  ( 
    (lambda ( m ) 
      (list m 
        (mapcar '- (_dxf 10 (tblsearch "BLOCK" (_dxf 2 l))) 
          (mxv m 
            (trans (_dxf 10 l) n 0) 
          ) 
        ) 
      ) 
    ) 
    (mxm 
      (list 
        (list (/ 1. (_dxf 41 l)) 0. 0.) 
        (list 0. (/ 1. (_dxf 42 l)) 0.) 
        (list 0. 0. (/ 1. (_dxf 43 l))) 
      ) 
      (mxm 
        (list 
          (list (cos a) (sin (- a)) 0.) 
          (list (sin a) (cos a)     0.) 
          (list    0.        0.     1.) 
        ) 
        (mapcar '(lambda ( e ) (trans e n 0 t)) 
         '( 
            (1. 0. 0.) 
            (0. 1. 0.) 
            (0. 0. 1.) 
          ) 
        ) 
      ) 
    ) 
  ) 
) 
 
;;---------------=={ Block Def -> Block Ref }==---------------;; 
;;                                                            ;; 
;;  Returns the Transformation Matrix and Translation Vector  ;; 
;;  for transforming Block Definition Geometry to a Block     ;; 
;;  Reference.                                                ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright  2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  e - Block Reference Entity                                ;; 
;;------------------------------------------------------------;; 
;;  Returns:  List of 3x3 Transformation Matrix, Vector       ;; 
;;------------------------------------------------------------;; 
 
(defun LM:Def->Ref ( e / _dxf a l n ) 
 
  (defun _dxf ( x l ) (cdr (assoc x l))) 
 
  (setq l (entget e) a (_dxf 50 l) n (_dxf 210 l)) 
  ( 
    (lambda ( m ) 
      (list m 
        (mapcar '- (trans (_dxf 10 l) n 0) 
          (mxv m 
            (_dxf 10 (tblsearch "BLOCK" (_dxf 2 l))) 
          ) 
        ) 
      ) 
    ) 
    (mxm 
      (mapcar '(lambda ( e ) (trans e 0 n t)) 
       '( 
          (1. 0. 0.) 
          (0. 1. 0.) 
          (0. 0. 1.) 
        ) 
      ) 
      (mxm 
        (list 
          (list (cos a) (sin (- a)) 0.) 
          (list (sin a) (cos a)     0.) 
          (list    0.        0.     1.) 
        ) 
        (list 
          (list (_dxf 41 l) 0. 0.) 
          (list 0. (_dxf 42 l) 0.) 
          (list 0. 0. (_dxf 43 l)) 
        ) 
      ) 
    ) 
  ) 
) 
 
;;---------------------=={ Select if }==----------------------;; 
;;                                                            ;; 
;;  Provides continuous selection prompts until either a      ;; 
;;  predicate function is validated or a keyword is supplied. ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright  2011 - www.lee-mac.com       ;; 
;;------------------------------------------------------------;; 
;;  Arguments:                                                ;; 
;;  msg  - prompt string                                      ;; 
;;  pred - optional predicate function [selection list arg]   ;; 
;;  func - selection function to invoke                       ;; 
;;  keyw - optional initget argument list                     ;; 
;;------------------------------------------------------------;; 
;;  Returns:  Entity selection list, keyword, or nil          ;; 
;;------------------------------------------------------------;; 
 
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))   
  (while 
    (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg)) 
      (cond 
        ( (= 7 (getvar 'ERRNO)) 
          (princ "\nMissed, Try again.") 
        ) 
        ( (eq 'STR (type sel)) 
          nil 
        ) 
        ( (vl-consp sel) 
          (if (and pred (not (pred sel))) 
            (princ "\nInvalid Object Selected.") 
          ) 
        ) 
      ) 
    ) 
  ) 
  sel 
) 
 
;; Matrix x Vector  ~  Vladimir Nesterovsky 
(defun mxv ( mat vec ) 
  (mapcar '(lambda ( row ) (apply '+ (mapcar '* row vec))) mat) 
) 
 
;; Matrix x Matrix  ~  Vladimir Nesterovsky 
(defun mxm ( m q ) 
  (mapcar (function (lambda ( r ) (mxv (trp q) r))) m) 
) 
 
;; Matrix Transpose  ~  Doug Wilson 
(defun trp ( m ) 
  (apply 'mapcar (cons 'list m)) 
) 
 
(vl-load-com) (princ) 
 
;;------------------------------------------------------------;; 
;;                         End of File                        ;; 
;;------------------------------------------------------------;;

lucas_3333 · 发表于 2015-7-23 16:48:39

都钻石会员了,还不会用搜索.

http://bbs.mjtd.com/thread-168587-1-1.html
http://bbs.mjtd.com/forum.php?mo ... gest%3D1&page=3

lijiao · 发表于 2015-7-23 17:04:59

(setq ref (ssget ":E:S" '((0 . "INSERT"))))
(setq ent (ssname ref 0))
(setq edata (entget ent))
(setq name (cdr (assoc 2 edata)))
(setq inpt (vlax-3d-point (cdr (assoc 10 edata))))
(setq newpt (vlax-3d-point (getpoint)))
(setq blk (vla-item (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument)
      'Blocks
      )
      name
   )
)
(vlax-for item blk
  (vla-move item newpt inpt)
)
(vla-move (vlax-ename->vla-object ent) inpt newpt)
(entupd ent)

weiqi · 发表于 2015-7-23 23:32:08

fan_zh 发表于 2015-7-23 16:03

可以用谢谢了.

weiqi · 发表于 2015-7-23 23:32:40

lucas_3333 发表于 2015-7-23 16:48
都钻石会员了,还不会用搜索.
http://bbs.mjtd.com/thread-168587-1-1.html
http://bbs.mjtd.com/fo ...

太久没来...搜了一个小时没搜到好用的....

账号		自动登录	找回密码
密码			注册

[源码] 求改块基点源码

最佳答案