[编程交流] 选择嵌套属性tex

 
(defun Fixhatch (/ Hatchfix objct)
(while
     (setq Hatchfix (entsel "\nSelect Hatch to fix (or Enter to close):"))
            (redraw (car Hatchfix) 3)
            (Alert "\n***Select object(s) to clear/skip hatch:***")
     (setq objct (ssget))
        
     (if (eq (cdr (assoc 0 (entget (setq Hatchfix (car Hatchfix))))) "HATCH")
    
     (command "_.-hatchedit" Hatchfix "Ad" "s" objct "" "")
  (princ "\nSelected entity is not a hatch.")
      );end if
);end while
     
);end defun

(defun c:Test (/ s)
 ;; Tharwat 21.10.2013    ;;
 (or Doc
     (setq Doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
 (while
   (and (setq s (car (nentsel "\n Select Hatch in Block to delete :")))
        (eq (cdr (assoc 0 (entget s))) "HATCH")
   )
    (vl-catch-all-apply
      'vla-delete
      (list (vlax-ename->vla-object s))
    )
    (vla-regen Doc AcAllViewports)
 )
 (princ)
)
(vl-load-com)

(defun c:HIH (/ _tempE hat ob a2t atb prop atb hat holes ); Hole in Hatch
(defun _tempE (ne / tmp)
 (setq tmp (entmakex (entget (car ne))))
 (vla-transformby
   (vlax-ename->vla-object tmp)
   (vlax-tmatrix (caddr ne))
 )
 tmp
)
;;;        Borrowed from LM        ;;;
;;;   mod from /= to wcmatch          ;;;
(defun _selectobject ( msg obj fun / sel )
       (while
           (progn (setvar 'errno 0) (setq sel (car (setq itm ((eval fun) msg))))
               (cond
                   (   (= 7 (getvar 'errno))
                       (princ "\nMissed, try again.")
                   )
                   (   (= 'ename (type sel))
                       (if (not (wcmatch  (cdr (assoc 0 (entget sel))) obj))
                           (princ "\nInvalid object selected.")
                       )
                   )
               )
           )
       )
       itm
   )
;;;                                ;;;
(if  (setq holes (ssadd) hat (_selectobject "\nSelect Hatch: "     "HATCH"  'entsel))
 (progn
   [color="blue"](redraw (car hat) 3)[/color]
(while
  (Setq ob (_selectobject "\nSelect objects to exclude hatch: " "ATTRIB,*LINE,*TEXT,CIRCLE" 'nentselp))
  (ssadd 
  (if (eq (cdr (assoc 0 (entget (car ob)))) "ATTRIB")
                (progn
                  (setq a2t (vlax-ename->vla-object (car ob)))
                  (Setq        prop (mapcar '(lambda (p)
                                        (vlax-get a2t p)
                                      )
                                     '("Insertionpoint" "Textstring" "Height")))
                  (setq  atb        (vlax-invoke
                          (vlax-get (vla-get-ActiveLayout
                                      (vla-get-activedocument (vlax-get-acad-object))
                                    ) 'Block ) 'AddText
                          (cadr prop)
                          (car prop)
                          (caddr prop)
                        )
                  )(vlax-vla-object->ename atb)
                )
    (_tempE ob)
    ) Holes)
 [color="blue"] (redraw (ssname holes (1- (sslength holes))) 3)[/color]
  )
(command "_.-hatchedit" (setq hat (Car hat)) "Ad" "s" holes "" "")
(vla-put-AssociativeHatch (vlax-ename->vla-object hat) :vlax-false)
           (command "_.erase" holes "")
)
 )(princ)
 )

([color=BLUE]defun[/color] c:fixhatch ( [color=BLUE]/[/color] _selectobject att hat obj txt )
   ([color=BLUE]defun[/color] _selectobject ( msg obj fun [color=BLUE]/[/color] sel )
       ([color=BLUE]while[/color]
           ([color=BLUE]progn[/color] ([color=BLUE]setvar[/color] 'errno 0) ([color=BLUE]setq[/color] sel ([color=BLUE]car[/color] (([color=BLUE]eval[/color] fun) msg)))
               ([color=BLUE]cond[/color]
                   (   ([color=BLUE]=[/color] 7 ([color=BLUE]getvar[/color] 'errno))
                       ([color=BLUE]princ[/color] [color=MAROON]"\nMissed, try again."[/color])
                   )
                   (   ([color=BLUE]=[/color] 'ename ([color=BLUE]type[/color] sel))
                       ([color=BLUE]if[/color] ([color=BLUE]/=[/color] obj ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 0 ([color=BLUE]entget[/color] sel))))
                           ([color=BLUE]princ[/color] [color=MAROON]"\nInvalid object selected."[/color])
                       )
                   )
               )
           )
       )
       sel
   )
   ([color=BLUE]if[/color]
       ([color=BLUE]and[/color]
           ([color=BLUE]setq[/color] hat (_selectobject [color=MAROON]"\nSelect Hatch: "[/color]     [color=MAROON]"HATCH"[/color]  '[color=BLUE]entsel[/color]))
           ([color=BLUE]setq[/color] att (_selectobject [color=MAROON]"\nSelect Attribute: "[/color] [color=MAROON]"ATTRIB"[/color] '[color=BLUE]nentsel[/color]))
           ([color=BLUE]setq[/color] obj ([color=BLUE]vlax-ename->vla-object[/color] att))
       )
       ([color=BLUE]if[/color] ([color=BLUE]setq[/color] txt
               ([color=BLUE]if[/color] ([color=BLUE]and[/color] ([color=BLUE]vlax-property-available-p[/color] obj 'mtextattribute) ([color=BLUE]=[/color] [color=BLUE]:vlax-true[/color] ([color=BLUE]vla-get-mtextattribute[/color] obj)))
                   (iburst:matt2mtext ([color=BLUE]entget[/color] att))
                   (iburst:att2text   ([color=BLUE]entget[/color] att))
               )
           )
           ([color=BLUE]progn[/color]
               ([color=BLUE]command[/color] [color=MAROON]"_.-hatchedit"[/color] hat [color=MAROON]"_DI"[/color] [color=MAROON]"_.-hatchedit"[/color] hat [color=MAROON]"_AD"[/color] [color=MAROON]"_S"[/color] txt [color=MAROON]""[/color] [color=MAROON]""[/color])
               ([color=BLUE]entdel[/color] txt)
           )
           ([color=BLUE]princ[/color] [color=MAROON]"\nUnable to convert attribute to text."[/color])
       )
   )
   ([color=BLUE]princ[/color])
)
[color=GREEN];; The following functions are taken from Burst Upgraded:[/color]
[color=GREEN];; http://lee-mac.com/upgradedburst.html[/color]
([color=BLUE]defun[/color] iburst:removepairs ( itm lst )
   ([color=BLUE]vl-remove-if[/color] '([color=BLUE]lambda[/color] ( x ) ([color=BLUE]member[/color] ([color=BLUE]car[/color] x) itm)) lst)
)
([color=BLUE]defun[/color] iburst:remove1stpairs ( itm lst )
   ([color=BLUE]vl-remove-if[/color] '([color=BLUE]lambda[/color] ( x ) ([color=BLUE]if[/color] ([color=BLUE]member[/color] ([color=BLUE]car[/color] x) itm) ([color=BLUE]progn[/color] ([color=BLUE]setq[/color] itm ([color=BLUE]vl-remove[/color] ([color=BLUE]car[/color] x) itm)) [color=BLUE]t[/color]))) lst)
)
 
([color=BLUE]defun[/color] iburst:att2text ( enx )
   ([color=BLUE]entmakex[/color]
       ([color=BLUE]append[/color] '((0 . [color=MAROON]"TEXT"[/color]))
           (iburst:removepairs '(000 002 070 074 100 280)
               ([color=BLUE]subst[/color] ([color=BLUE]cons[/color] 73 ([color=BLUE]cdr[/color] ([color=BLUE]assoc[/color] 74 enx))) ([color=BLUE]assoc[/color] 74 enx) enx)
           )
       )
   )
)
([color=BLUE]defun[/color] iburst:matt2mtext ( enx )
   ([color=BLUE]entmakex[/color]
       ([color=BLUE]append[/color] '((0 . [color=MAROON]"MTEXT"[/color]) (100 . [color=MAROON]"AcDbEntity"[/color]) (100 . [color=MAROON]"AcDbMText"[/color]))
           (iburst:remove1stpairs  '(001 007 010 011 040 041 050 071 072 073 210)
               (iburst:removepairs '(000 002 042 043 051 070 074 100 101 102 280 330 360) enx)
           )
       )
   )
)
([color=BLUE]vl-load-com[/color]) ([color=BLUE]princ[/color])