[编程交流] 用于标记图案填充对象的Lisp

(setvar "attdia" 0)
(while (setq obj (vlax-ename->vla-object (car (entsel "\nPick hatch"))))
(setq lay (vla-get-layer obj))
(command "-Insert" "lname" (getpoint) 1000 0.0 lay)
)

(defun C:test ( / spc SS attr i o p ll ur )
 (vl-every 'eval
   '( 
     (setq spc (vla-get-Block (vla-get-ActiveLayout (vla-get-ActiveDocument (vlax-get-acad-object)))))
     (princ "\nSelect hatches to insert "LNAME" block on their centroids.")
     (setq SS (ssget '((0 . "HATCH")(2 . "SOLID")(8 . "L1,L2,L3,L4,L5"))))
     (setq attr (getvar 'attreq)) (setvar 'attreq 0)
     (progn 
       (repeat (setq i (sslength SS))
         (vla-GetBoundingBox (setq o (vlax-ename->vla-object (ssname SS (setq i (1- i))))) 'll 'ur)
         (setq p (apply 'mapcar (cons '(lambda (a b) (/ (+ a b) 2.)) (mapcar 'vlax-safearray->list (list ll ur))))) ; LM
         (vla-put-Layer (vlax-invoke spc 'InsertBlock p "LNAME" 1.0 1.0 1.0 0.0) (vla-get-Layer o))
       )
       (setvar 'attreq attr)
     )
   )
 )
 (princ)
) (vl-load-com) (princ)

(defun C:test ( / spc SS attr i o p ll ur b lyr )
 (vl-every 'eval
   '( 
     (setq spc (vla-get-Block (vla-get-ActiveLayout (vla-get-ActiveDocument (vlax-get-acad-object)))))
     (princ "\nSelect hatches to insert "LNAME" block on their centroids.")
     (setq SS (ssget '((0 . "HATCH"))))
     (setq attr (getvar 'attreq)) (setvar 'attreq 0)
     (progn 
       (repeat (setq i (sslength SS))
         (vla-GetBoundingBox (setq o (vlax-ename->vla-object (ssname SS (setq i (1- i))))) 'll 'ur)
         (setq p (apply 'mapcar (cons '(lambda (a b) (/ (+ a b) 2.)) (mapcar 'vlax-safearray->list (list ll ur))))) ; LM
         (vla-put-Layer (setq b (vlax-invoke spc 'InsertBlock p "LNAME" 1.0 1.0 1.0 0.0)) (setq lyr (vla-get-Layer o)))
         (vl-some 
           '(lambda (x) 
             (cond
               ( (not (vlax-write-enabled-p x)) nil)
               ( (= "LNAME" (strcase (vla-get-TagString x))) (vla-put-TextString x (vla-get-Layer o)) T)
             )
           )
           (vlax-invoke b 'GetAttributes)
         )  
       )
       (setvar 'attreq attr)
     )
   )
 )
 (princ)
) (vl-load-com) (princ) 

(defun c:taghatches (/ getid doc lst blk int hat sel ent q p)
 ;;------------------------------------;;
 ;;        Tharwat - Date: 26.07.2017        ;;
 ;; Tag hatches with Attributed Block        ;;
 ;; that entitled: LNAME then add the        ;;
 ;; Hatch layer into the previous said        ;;
 ;; Att.Block as a field object in Att.;;
 ;;------------------------------------;;
 (if (and (or (and (setq blk (tblsearch "BLOCK" "LNAME"))
                   (= (cdr (assoc 70 blk)) 2)
                   )
              (alert  "Block Name <LNAME> is either not found in drawing or it's not attributed block <!>")
              )
          (princ "\nSelect hatches :")
          (setq int -1
                doc (vla-get-activedocument (vlax-get-acad-object))
                sel (ssget "_:L" '((0 . "HATCH")))
                )
          
   )
   (progn
      (defun getid (obj doc / u)
        (if (vlax-method-applicable-p (setq u (vla-get-utility doc)) 'getobjectidstring)
          (vla-getobjectidstring u obj :vlax-false)
          (itoa (vla-get-objectid obj))
        )
      )
      (while (setq ent (ssname sel (setq int (1+ int))))
        (vla-getboundingbox (setq hat (vlax-ename->vla-object ent)) 'q 'p)
        (and
          (setq lst (mapcar 'vlax-safearray->list (list q p))
                blk (vlax-invoke
                      (vla-get-block (vla-get-activelayout doc))
                      'insertblock
                      (mapcar '(lambda (j k) (* (+ j k) 0.5)) (car lst) (cadr lst))
                      "LNAME"
                      1.0
                      1.0
                      1.0
                      0.0
                    )
          )
          (vl-some '(lambda (att)
                      (and (= (strcase (vla-get-tagstring att)) "LNAME")
                           (progn
                             (vla-put-textstring att (strcat "%<\\AcObjProp Object(%<\\_ObjId " (getid hat doc) ">%).Layer>%")) t)
                      )
                    )
                   (vlax-invoke blk 'getattributes)
          )
        )
      )
      (and doc (vla-regen doc acactiveviewport))
    )
 )
 (princ)
) (vl-load-com)