[编程交流] 用于创建多重引线Styl的LISP

; s - Source VLA-OBJECT (graphical/non-graphical)
; d - Destination VLA-OBJECT (graphical/non-graphical)
; ps - predefined properties list to use, if nil the (atoms-family) properties approach will be used
; aps - properties list to include for matching, since (atoms-family) is missing some of them
; rps - properties list to remove from matching
; Returns: assoc list of (<PropertyName> <MatchedValue>) for the error-free assigned properties
; Wanna credits?: Lee Mac, Michael Puckett
(defun _MatchProps ( s d ps aps rps / TrapT )
 (cond 
   ( (or (vl-some '(lambda (x) (not (eq 'VLA-OBJECT (type x)))) (list s d)) (not (vlax-read-enabled-p s)) (not (vlax-write-enabled-p d))) nil)
   (
     (and
       (if ps ; determine predefined properties to use or (atoms-family)
         (setq ps (mapcar '(lambda (p) (cond ((eq 'SYM (type p)) (vl-symbol-name p)) ((eq 'STR (type p)) (strcase p)))) ps))
         (setq ps (apply 'append (mapcar '(lambda (x) (if (wcmatch (setq x (strcase x)) "VLA-PUT-*") (list (vl-string-left-trim "VLA-PUT-" x)))) (atoms-family 1))))
       )
       (setq ps (append (if aps (mapcar '(lambda (p) (cond ((eq 'SYM (type p)) (vl-symbol-name p)) ((eq 'STR (type p)) (strcase p)))) aps)) ps)) ; additional
       (setq ps (apply 'append (mapcar '(lambda (p) (if (vl-every '(lambda (x) (vlax-property-available-p x p t)) (list s d)) (list p))) ps))) ; check valid props
       (cond ; check for removal
         (rps 
           (setq rps (apply 'append (mapcar '(lambda (p) (cond ((eq 'SYM (type p)) (list (vl-symbol-name p))) ((eq 'STR (type p)) (list (strcase p))))) rps)))
           (setq ps (vl-remove-if '(lambda (p) (member p rps)) ps))
         )
         ( ps )
       )
     ); and
     (setq TrapT ; Traps the evaluation only: returns nil only if an error occured, else the value or T
       (lambda (f args / r) (cond ( (vl-catch-all-error-p (setq r (vl-catch-all-apply f args))) (prompt (strcat "\nError: " (vl-catch-all-error-message r))) ) (r) ((not r)) ) )
     ); setq TrapT
     (mapcar '(lambda (p / v) (cond ( (not (setq v (TrapT 'vlax-get-property (list s p)))) v) ( (not (TrapT 'vlax-put-property (list d p v))) nil) ( (list p v) ) ) ) ps)
   )
 ); cond
); defun _MatchProps

(defun MatchMleaderStyleProps ( snm dnm / coll )
 (setq coll (vla-item (vla-get-Dictionaries (vla-get-ActiveDocument (vlax-get-acad-object))) "ACAD_MLEADERSTYLE"))
 (_MatchProps (vl-catch-all-apply 'vla-item (list coll snm)) (vl-catch-all-apply 'vla-item (list coll dnm))
   '(
     alignspace annotative arrowsize arrowsymbol bitflags block blockcolor
     blockconnectiontype blockrotation blockscale breaksize contenttype description
     dogleglength drawleaderordertype drawmleaderordertype  enableblockrotation
     enableblockscale  enabledogleg enableframetext enablelanding firstsegmentangleconstraint
     landinggap leaderlinecolor leaderlinetype leaderlinetypeid leaderlineweight
     maxleadersegmentspoints overwritepropchanged  scalefactor secondsegmentangleconstraint
     textalignmenttype textangletype textattachmentdirection textbottomattachmenttype
     textcolor textheight textleftattachmenttype  textrightattachmenttype
     textstring textstyle texttopattachmenttype
   ); list 
   nil nil
 )
); defun

(MatchMleaderStyleProps "MySourceMleaderStyle" "MyDestinationMleaderStyle")