[编程交流] SSGET-带Promp的块分解

(defun c:test (/ _getattvalue s)
 ;; RJP - Simple get attribute value sub .. no error checking
 (defun _getattvalue (block tag)
   (vl-some
     '(lambda (att)
 (cond ((eq (strcase tag) (strcase (vla-get-tagstring att))) (vla-get-textstring att)))
      )
     (vlax-invoke block 'getattributes)
   )
 )
 ;; RJP - added (66 . 1) to filter ( attributed blocks )
 (cond        ((setq s (ssget "_C" '(7.244 2.071) '(16.665 10.003) '((0 . "INSERT") (66 . 1))))
 (foreach en (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
   (if (and ;; If we have a value, and it does not match the filter then remove item from selection
            (setq v (_getattvalue (vlax-ename->vla-object en) "Description"))
            ;; vl-string-search example ( more legible IMO )
            (vl-some '(lambda (x) (wcmatch (strcase v) (strcat "*" x "*")))
                     '("VV" "VB" "VY" "VD" "VG" "VT" "VN" "VP" "V3" "V4")
            )
       )
     (progn (foreach i (vlax-invoke (vlax-ename->vla-object en) 'explode)
              (if (= "AcDbAttributeDefinition" (vla-get-objectname i))
                (vl-catch-all-apply 'vla-delete (list i))
                (entmod (append (entget (vlax-vla-object->ename i)) '((8 . "NewLayer"))))
              )
            )
            (entdel en)
     )
   )
 )
 ;; Highlight selection
 ;; (sssetfirst nil s)
)
 )
 (princ)
)
(vl-load-com)

(defun c:test (/ _getattvalue o s ll ur)
 ;; RJP - Simple get attribute value sub .. no error checking
 (defun _getattvalue (block tag)
   (vl-some
     '(lambda (att)
 (cond ((eq (strcase tag) (strcase (vla-get-tagstring att))) (vla-get-textstring att)))
      )
     (vlax-invoke block 'getattributes)
   )
 )
 ;; RJP - added (66 . 1) to filter ( attributed blocks )
 (cond
   ((setq s (ssget "_C" '(7.244 2.071) '(16.665 10.003) '((0 . "INSERT") (66 . 1))))
    (foreach en (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
      (if (and        ;; If we have a value, and it does not match the filter then remove item from selection
        (setq v (_getattvalue (setq o (vlax-ename->vla-object en)) "Description"))
        ;; vl-string-search example ( more legible IMO )
        (vl-some '(lambda (x) (wcmatch (strcase v) (strcat "*" x "*")))
                 '("VV" "VB" "VY" "VD" "VG" "VT" "VN" "VP" "V3" "V4")
        )
   )
 (progn
   (vlax-invoke (vlax-get-acad-object) 'zoomcenter (vlax-get o 'insertionpoint) 1)
   (foreach i (vlax-invoke o 'explode)
     (if (= "AcDbAttributeDefinition" (vla-get-objectname i))
       (vl-catch-all-apply 'vla-delete (list i))
       (progn
         (vla-put-color i 1)
         (vla-update i)
         (if
           (getpoint "\nPick a point to change red object layer or enter for no change: ")
            (entmod (append (entget (vlax-vla-object->ename i)) '((8 . "NewLayer"))))
         )
       )
     )
   )
   (entdel en)
 )
      )
    )
    ;; Highlight selection
    ;; (sssetfirst nil s)
   )
 )
 (princ)
)

3