Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
hugo75

[Yêu cầu]Lisp chuyển tâm block ATT?

Các bài được khuyến nghị

hugo75    4

Mình có 1 Block ATT có tâm là tâm đường tròn.Nhờ các bác viết giùm đoạn lisp dời tâm của block này xuống phía dưới giống như file đính kèm.Dời tâm 1 lúc nhiều block ATT luôn các bác ah.Thanks.

http://www.cadviet.com/upfiles/3/46507_drawing1.dwg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
hiepttr    523

Lần sau bạn nên chịu khó search trướcs khi hỏi !

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=66690&pid=213540&st=0&&do=findComment&comment=213540
 
;;---------------=={ Change Block Insertion }==---------------;;
;;                                                            ;;
;;  Modifies the Block Definition Base Point of a selected    ;;
;;  block to a user specified point.                          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  With Thanks to Gilles Chanteau for his excellent advice.  ;;
;;------------------------------------------------------------;;
;;  Version:  1.3    -    23rd June 2011                      ;;
;;------------------------------------------------------------;;
 
;; -- Retains Insertion Point -- §æi ®iÓm chÌn, vÞ trÝ block thay ®æi theo.
(defun c:CBI  nil (ChangeBlockInsertion nil))
 
;; -- Retains Block Position -- §æi ®iÓm chÌn, gi÷ nguyªn vÞ trÝ block.
(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                        ;;
;;------------------------------------------------------------;;
 

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Doan Van Ha    2.676

Lisp này là hàng ngoại, tôi post lên cho mọi người dùng, ở topic nào thì giờ không nhớ rõ.

Nó có chức năng thay đổi điểm insert của các block, nhưng có 2 cách:

1). Thay đổi vị trí các block nhưng không thay đổi điểm chuẩn của từng block.

2). Thay đổi điểm chuẩn của block.

Lệnh là CBI hoặc CBIR

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×