[编程交流] 搜索块实体

(defun c:Test (/ doc ss in)
 ;;    Tharwat 11.May. 2014        ;;
 (if (and (/= (setq in (getstring t "\n Type a text to replace in block :")) "")
          (princ "\n *** Select blocks ***")
          (setq ss (ssget "_:L" '((0 . "INSERT"))))
     )
   (progn (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
          ((lambda (x / sn en lst nm e el)
             (while (setq sn (ssname ss (setq x (1+ x))))
               (if (not (member (setq nm (cdr (assoc 2 (setq en (entget sn))))) lst))
                 (progn (setq lst (cons nm lst))
                        (setq e (tblobjname "BLOCK" nm))
                        (while (setq e (entnext e))
                          (if (wcmatch (cdr (assoc 0 (setq el (entget e)))) "*TEXT")
                            (entmod (subst (cons 1 in) (assoc 1 el) el))
                          )
                        )
                 )
               )
             )
           )
            -1
          )
          (vla-endundomark doc)
          (vla-regen doc Acallviewports)
   )
 )
 (princ)
)(vl-load-com)

(vl-load-com)
(defun C:GZ ()
 (command "undo" "be")
 (setq        olderr        *error*                        ; Initialize variables
*error*        chgterr
 )
    (setvar "CMDECHO" 0)
   (command "ucs" "w")
  (setq *App (vlax-get-acad-object))
  (setq *Doc (vla-get-ActiveDocument *APP))
   (setq SS (nentsel "\nPlease pick the text: "))
   (setq ENT (entget (car SS)) 
         PT  (cadr SS)
         PT11  PT
     )
 
    (setq ens1 (last SS))
  (if  (not (equal PT ens1 0.1)  )              
  (setq  ens (last (last SS)) 
      mat (RevRefGeom ens)                      
      PT11 (MCS2WCS mat PT11 )                   
      obj (vlax-ename->vla-object ens)
      name (vla-get-name obj)            
   )
   )
  
   (if (= (cdr (assoc 0 ENT)) "TEXT")
       (progn
       (entmake ENT)
(setq ent1 (entlast))
(setq el1  (entget ent1))
     (setq  STR (cdr (assoc 1 ENT)))
   
  
  (setq dq1 (setq dqb1 (assoc 72 el1)))
  (setq dq2 (setq dqb2 (assoc 73 el1)))
  (if (/= dq1 0)
    (progn
      (setq p11 (assoc 11 el1))        
      (setq p11b '(0.0 0.0 0.0))
      (setq el1 (subst (cons 11 p11b) p11 el1)) 
      (setq dq 0)                
      (setq el1 (subst (cons 72 dq) dqb1 el1)) 
      (if (/= dq2 0)
        (setq el1 (subst (cons 73 dq) dqb2 el1))
      )                                
      (entmod el1)                
    )
  )
      
      
      
       (setq LST '()) 
       (setq LTT '()) 
       (setq lls "")
       (setq ijk nil)
       (while (/= STR "")
       (setq step 0)
       (if (> (ascii (substr STR 1 1)) 159)
         (progn
           (setq STRI (substr STR 1 2))
           (setq  LST  (cons STRI LST))
           (setq  LST  (cons STRI LST))
           
           (setq  STR  (substr STR 3))
          
         (if (not ijk)
          (progn
          (setq lls (strcat lls STRI))
          (entmod (setq el1 (subst (cons 1 lls)
                             (assoc 1 el1)
                             el1
                      )
            )
    )  
         
        (if         (setq xx (CheckWidth ent1 PT11) )
         (progn
           (entdel ent1)  
           (setq   strr  (getstring (strcat "\nPlease enter a new text:[" STRI "]"))
                   LTT    (cons strr LTT)
                   ijk      T
           )
        )
        (setq  LTT  (cons STRI LTT))
        )
        ) ; progn
       (setq  LTT  (cons STRI LTT))
       )
     
     
         )  ;(progn
       (progn
          (if (and (< (asj 2) 159)  (< (asj 3) 159)  (< (asj 4) 159)  (< (asj 5) 159)  (wcmatch (substr STR 1 5) "%%**") )
     ;     (if        (wcmatch (substr STR 1 5) "%%**")
     (if (wcmatch (substr STR 1 5) "%%[0-9][0-9][0-9]")
             
                 (setq STRI (substr STR 1 5)  
                       STR  (substr STR 6)  
                       step  5)
                 (setq STRI (substr STR 1 3) 
                       STR  (substr STR 4)  )
      )        
                                    ;endif 
      (setq STRI (substr STR 1 1)  STR  (substr STR 2) )
    )
                             
           (setq  LST  (cons STRI LST))
           
         (if (not ijk)
          (progn
          (setq lls (strcat lls STRI))
          (entmod (setq el1 (subst (cons 1 lls)
                             (assoc 1 el1)
                             el1
                      )
            )
    )  
          
        (if        (setq xx (CheckWidth ent1 PT11) )
        (progn
          (entdel ent1)
          (setq   strr  (getstring (strcat "\nPlease enter a new text:[" STRI "]")))
          (if (= step 5) 
            (progn
            (if (= strr "1") (setq strr "%%129"))
            (if (= strr "2") (setq strr "%%130"))
            (if (= strr "3") (setq strr "%%160"))
            (setq step 0)
            )
          )
             (setq step 0)
              (setq    LTT    (cons strr LTT)
                       ijk     T
          )
         
         )
        (setq  LTT  (cons STRI LTT))
        )
        )
       (setq  LTT  (cons STRI LTT))
       )
         )  ;progn
        )   ; (if (> (ascii (substr STR 1 1)) 159)
     (setq STRI "")
       ) ; while
     ;(entdel ent1)
       (setq LTT (reverse LTT))
       (setq LST (reverse LST))
      
       (setq ttx "")
       (setq kkk 0)
       (while (< kkk (length LTT))
         (setq ttx (strcat ttx (nth kkk LTT)))       
         (setq kkk (1+ kkk))
       )
       (entmod (subst (cons 1 ttx) (assoc 1 ENT) ENT))
       (if  (not (equal PT ens1 0.1)  )          
        (progn
        (setq bbs (ssget "X" '((0 . "insert")) ))
          (setq i 0)
          (while (<  i (sslength bbs) )  
            (setq nai (ssname bbs i)) 
            (setq enn (entget nai))
            (setq nam (cdr (assoc 2 enn)))
            (if (= nam name)
               (progn  (entdel nai) (entdel nai) )
            )
            (setq i ( 1+ i ) )
          )
           
        ; (entdel ens)
         ;(entdel ens)  
       )
       )
       )     
   )
 (setq *error* olderr)                        ; Restore old *error* handler
 (command "undo" "e")
(command "ucs" "p")
  
   (princ)
     
) ;
(defun ASj (jj0 / asjj)
(setq asjj (ascii (substr STR jj0 1)))  
)
(defun CheckWidth (textent selpt / );ll ur hbox)
 (command "ucs" "Object" textent)
 (setq selpt (trans selpt 0 1))
 (setq        ll   (car (textbox (entget textent)))
ur   (cadr (textbox (entget textent)))
wid  (abs (- (car ur) (car ll)))
wid1 (abs (- (car selpt) (car ll)))
hbox (/ (PickBoxSize) 2.0)
 )
 (command "ucs" "p")
 (if (> wid (- wid1 hbox))
   T
   nil
 )
)
;;---------------------------------------- 
(defun PickBoxSize (/ SS VS PB SWP SHP AR WSD PPDU BOX)
 (setq        SSc   (getvar "SCREENSIZE")        ; screen size in pixels 
VS   (getvar "VIEWSIZE")        ; screen height in drawing units 
PB   (getvar "pickbox")                ; get current pickbox size 
SWP  (car SSc)                        ; width of screen in pixels 
SHP  (cadr SSc)                        ; height of screen in pixels 
AR   (/ SWP SHP)                ; aspect ratio width/height 
WSD  (* VS AR)                        ; width of screen dwg units = ratio timesheight 
PPDU (/ WSD SWP)                ; pixels per drawing unit 
BOX  (/ (* VS (* 2 PB)) SHP)        ; drawing units per pixel 
 )
)
;;; This routine is from gile,I revised some places for a better algorithm.  
;;; Thanks a lot.                                   -highflybird 2009/2/22   
;;; =========================================================================
;;; 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 / Lst ang Nor mat Org Ins Ax Ay Sx Sy Sz)
 (setq        Lst (entget ename)                                                ; the name of entity
Nor (cdr (assoc 210 Lst))                                       ; normal
Sx  (cdr (assoc 41  Lst))                                       ; X scale factor 
Sy  (cdr (assoc 42  Lst))                                         ; Y scale factor 
Sz  (cdr (assoc 43  Lst))                                        ; Z scale factor 
Ang (cdr (assoc 50  Lst))                                       ; rotation angle
Ax  (cos Ang)                                                   ; the value of cosine
Ay  (sin Ang)                                                   ; the value of sine
mat (mxm
      (list
        (trans '(1.0 0.0 0.0) 0 Nor T)                                ; transform X axis
        (trans '(0.0 1.0 0.0) 0 Nor T)                                ; transform Y axis
        (trans '(0.0 0.0 1.0) 0 Nor T)                                ; transform Z axis
      )
      (list
        (list (* Ax Sx) (- (* Ay Sy)) 0.)                        ; multiple Scale Matrix and rotation Matrix
        (list (* Ay Sx) (* Ax Sy)     0.)
        (list 0.0       0.0           Sz)
      )
    )
Org (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 Lst)))))        ; get the origin of the block
Ins (trans (cdr (assoc 10 Lst)) Nor 0)                                ; transformate insertpoint
 )                                                
 (if (/= Org '(0.0 0.0 0.0))                                                ; if the origin isn't '(0 0 0)
   (setq Ins (mapcar '- Ins (mxv mat Org)))                                ; then insertpoint needs a displacement
 )
 (setq mat (mapcar 'App2Last mat Ins)                                  ; to make a standard transformation matrix
       mat (App2Last mat '(0.0 0.0 0.0 1.0))
 )
)
;; RevRefGeom (gile)
;; RefGeom inverse function
(defun RevRefGeom (ename / Data ang norm mat ins)
 (setq        Data (entget ename)
ang  (- (cdr (assoc 50 Data)))
norm (cdr (assoc 210 Data))
mat  (mxm
       (list (list (/ 1 (cdr (assoc 41 Data))) 0.0 0.0)
             (list 0.0 (/ 1 (cdr (assoc 42 Data))) 0.0)
             (list 0.0 0.0 (/ 1 (cdr (assoc 43 Data))))
       )
       (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))
         )
       )
     )
ins  (mapcar
       '-
       (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 Data)))))
       (mxv mat (trans (cdr (assoc 10 Data)) norm 0))
     )
mat  (mapcar 'App2Last mat ins)
mat  (App2Last mat '(0.0 0.0 0.0 1.0))
 )
)
;;; Append a element to the last
(defun App2Last (m v)
 (list (car m) (cadr m) (caddr m) v)
)  
;;; 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)
)
;;; MCS to WCS -- revised by highflybird
(defun MCS2WCS (mat P / p1)
 (setq p1 (App2Last p 1))
 (list
   (vxv (car mat) p1) 
   (vxv (cadr mat) p1)
   (vxv (caddr mat) p1)
 )
)