[编程交流] 获取插入名称以获取乐趣

(defun LM:al-effectivename ( ent / blk rep )
   (if (wcmatch (setq blk (cdr (assoc 2 (entget ent)))) "`**")
       (if
           (and
               (setq rep
                   (cdadr
                       (assoc -3
                           (entget
                               (cdr
                                   (assoc 330
                                       (entget
                                           (tblobjname "block" blk)
                                       )
                                   )
                               )
                              '("AcDbBlockRepBTag")
                           )
                       )
                   )
               )
               (setq rep (handent (cdr (assoc 1005 rep))))
           )
           (setq blk (cdr (assoc 2 (entget rep))))
       )
   )
   blk
)
; =========================================================================================== ;
; Lista nazw blokow (*U) zaleznych od bloku dynamicznego /                                    ;
; List of the blocks name (*U) which depends on a dynamic block                               ;
;  Name [sTR] - nazwa bloku / block name                                                      ;
; ------------------------------------------------------------------------------------------- ;
; (cd:BLK_GetDynBlockNames "NazwaBloku")                                                      ;
; =========================================================================================== ;
(defun cd:BLK_GetDynBlockNames (Name / res n xd)
 (setq res (list Name))
 (vlax-for % (cd:ACX_Blocks)
   (if (wcmatch (setq n (vla-get-name %)) "`*U*")
     (if
       (setq xd
         (cd:XDT_GetXData
           (vlax-vla-object->ename %)
           "AcDbBlockRepBTag"
         )
       )
       (if
         (=
           (strcase Name)
           (strcase
             (cdr
               (assoc 2
                 (entget
                   (handent
                     (cdr (assoc 1005 (cdr xd)))
                   )
                 )
               )
             )
           )
         )
         (setq res (cons n res))
       )
     )
   )
 )
 (reverse res)
)
; =========================================================================================== ;
; Lista odnosnikow zewnetrznych / List of external references                                 ;
; =========================================================================================== ;
(defun cd:BLK_GetXrefs (/ res)
 (vlax-for % (cd:ACX_Blocks)
   (if (= (vla-get-IsXref %) :vlax-true)
     (setq res (cons (vla-get-name %) res))
   )
 )
 res
)
; =========================================================================================== ;
; Czyta dane dodatkowe XDATA / Reads additional data XDATA                                    ;
;  Ename [ENAME]   - nazwa entycji / entity name                                              ;
;  App   [sTR/nil] - nil = dla wszystkich aplikacji / for all applications                    ;
;                    STR = dla aplikacji App / for App application                            ;
; ------------------------------------------------------------------------------------------- ;
; (cd:XDT_GetXData (car (entsel)) "CADPL")                                                    ;
; =========================================================================================== ;
(defun cd:XDT_GetXData (Ename App)
 (if App
   (cadr (assoc -3 (entget Ename (list App))))
   (cdr (assoc -3 (entget Ename (list "*"))))
 )
)
;;---------------------=={ List Union }==---------------------;;
;;                                                            ;;
;;  Returns a list expressing the union of two lists          ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  l1,l2 - Lists for which to return the union               ;;
;;------------------------------------------------------------;;
;;  Returns:  A list of all distinct items in the two lists   ;;
;;------------------------------------------------------------;;
;_$ (LM:ListUnion '(1 2 3 4 5) '(2 4 6 )
;(1 2 3 4 5 6 
(defun LM:ListUnion ( l1 l2 / x l )
 (setq l1 (append l1 l2))
 (while (setq x (car l1)) (setq l (cons x l) l1 (vl-remove x l1)))
 (reverse l)
)
; =========================================================================================== ;
; Zmienia PICKSET na liste obiektow / Convert PICKSET to list of objects                      ;
;  Ss   [PICKSET] - zbior wskazan / selection sets                                            ;
;  Mode [iNT]     - typ zwracanych obiektow / type of returned objects                        ;
;                   0 = ENAME, 1 = VLA-OBJECT, 2 = SAFEARRAY                                  ;
; ------------------------------------------------------------------------------------------- ;
; (cd:SSX_Convert (ssget) 1)                                                                  ;
; =========================================================================================== ;
(defun cd:SSX_Convert (Ss Mode / n res)
 (if
   (and
     (member Mode (list 0 1 2))
     (not
       (minusp
         (setq n
           (if Ss (1- (sslength Ss)) -1)
         )
       )
     )
   )
   (progn
     (while (>= n 0)
       (setq res
         (cons
           (if (zerop Mode)
             (ssname Ss n)
             (vlax-ename->vla-object (ssname Ss n))
           )
           res
         )
             n (1- n)
       )
     )
     (if (= Mode 2)
       (vlax-safearray-fill
         (vlax-make-safearray 9
           (cons 0 (1- (length res)))
         ) res
       )
       res
     )
   )
 )
)
; =========================================================================================== ;
; Laczy liste lancuchow w lancuch z separatorem /                                             ;
; Combines a list of strings in the string with the separator                                 ;
;  Lst [list] - lista lancuchow / list of strings                                             ;
;  Sep [sTR]  - separator / separator                                                         ;
; ------------------------------------------------------------------------------------------- ;
; (cd:STR_ReParse '("OLE2FRAME" "IMAGE" "HATCH") ",")                                         ;
; =========================================================================================== ;
(defun cd:STR_ReParse (Lst Sep / res)
 (setq res (car Lst))
 (foreach % (cdr Lst)
   (setq res (strcat res Sep %))
 )
 res
)
;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.
;; (LM:Unique '("A" "B" "B" "B" "C" "C" "D" "E" "E" "E" "E"))
;;  =>  ("A" "B" "C" "D" "E")
(defun LM:Unique ( l / x r )
   (while l
       (setq x (car l)
             l (vl-remove x (cdr l))
             r (cons x r)
       )
   )
   (reverse r)
)