[编程交流] 引线到多重引线编辑。UCS mo

;;;        CADALYST 08/08 www.cadalyst.com/code
;                Tip 2305: Leader_To_Multileader.lsp LEADER to Multileader (c) 2008 Lyle Hardin
;                Pick an old style LEADER and text to create a new MLEADER entity and erase the old LEADER and text.
;                March/2008
;;;        EDITED ON 15/04/2017 BY 3DWANNAB
;                Reason for creating this, was to learn and create a LISP that I use on a regular basis.
;                Commandline Syntax: Type "Leader_To_Multileader" OR "LTM" to run Program.
;
;                ADDED        -        Case Conversion.
;                                                OPTIONS:
;                                                Titlecase Lowercase Uppercase Sentencecase toGglecase Keepcase.
;
;                ADDED        -        Annotation support. Program simply matches the (entget) object to that of the (entlast) object. With the help of AT:isAnnotative written by Alan J. Thompson.
;                ADDED        -        Custom LM:ssget fn written by LeeMac.
;                ADDED        -        Multiple Selection. User can now select the LEADER and MTEXT together and no longer individually resulting in a much faster conversion.
;                ADDED        -        Round off points - To nearest round number. That been 1. round fn written by Doug Broad. Additional credits to Joe Burke, Peter Toby.
;                ADDED        -        Strip MTEXT - Of formatting option - LM:UnFormat fn written by LeeMac.
;                ADDED        -        Text Rotation - MTEXT rotation is now preserved.
;                ADDED        -        Undo levels - As opposed to one command at a time.
;                ADDED        -        Picking of existing MLEADER to use as new style.
;                                                RMB-SPACEBAR-ENTER to skip this step and use the current MLEADER style
;                                                SETTINGS TRANSLATED IF PICKED:
;                                                (vla-put-Layer newmleader existingMlLayer)
;                                                (vla-put-ScaleFactor newmleader existingMlScale)
;                                                (vla-put-StyleName newmleader existingMlStyle)
;                                                (vla-put-TextWidth newmleader existingMlWidth)
;
;                                                SETTINGS TRANSLATED IF NOT:
;                                                (vla-put-Layer newmleader existingTxtLayer)
;                                                (vla-put-TextRotation newmleader existingTxtRot)
;                                                (vla-put-TextWidth newmleader existingTxtWidth)
;
;                CHG                -        Changed to 'vla-get-TextString' as more robust.
;                CHG                -        Moved new MLEADER to TEXT Layer as opposed to existing LEADER.
;                CHG                -        Picking never fails, prompts user to keep picking until successful. LM:SelectIf fn written by LeeMac.
;                FIX                -        ACADs built in functions to convert ill-formatted MTEXT creates a bug in the string result. LM:StringSubst by LeeMac.
;                FIX                -        End position of MLEADER.
;                FIX                -        Z coordinate to 0, resulting in no fuzzy text.
;                FIX                -        Forces the MLEADER to be created from the 'LEADER arrowHead first' resulting in correct results all the time.
;                FIX                -        Vertices, Leader_To_Multileader now supports 2 or 3 points.
;                                                If 2 (Straight) it straightens the MLEADER up to the Y axis of the LEADER point for those LEADERS at an angle.
;                                                If 3 (Dog Legged) it recreates those as they originally were.
;                                                If <3 (Multiple) it recreates the 1st, 2nd & end point point of the original LEADER. The 4th vert or more, will get removed.
;                                                NOTE: Not really any need for more than 3 points on an MLEADER, I don't think.
;
;;; KNOWN QUIRKS, BUGS
;                Works in different UCSs, if you are fixing MTEXT & LEADERS which are upside down then the new MLEADER might be a little wacky.
;
;;; FUTURE ADDITIONS
;                Convert based on how close the LEADER and MTEXT are away from each other. To enable multiple selection.
;
;;; COMMENT OUT
;                First off, Big THANKS to Lyle Hardin for the original code.
;                Big THANKS to LeeMac for the functions he has put up on his website.
;                        Finally getting the basics of this LISP'ing lark thanks to guys like him.
;                Lots of other places on forums and Users too. To many users to mention.
;                Let me know your thoughts on this Program or if you want to drop a Thank you.
;                        e. stephensherry147@yahoo.co.uk
(defun c:LTM nil (c:Leader_To_Multileader))
(defun c:Leader_To_Multileader ( /
*error*
cmde
entLeader
entLeaderName
entTxt
entTxtName
entTxtVlaObj
existingMlScale
existingMlStyle
existingMlvlaObj
existingMlWidth
existingTxtLayer
existingTxtRot
existingTxtString
existingTxtWidth
ldxf10_1
ldxf10_2
ldxf10_last
lstleaderlen
lstleaderpts
os
ss1
ss2
)
(defun *error* (errmsg)
(and acDoc (vla-EndUndoMark acDoc))
(and errmsg
        (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
        (princ (strcat "\n<< Error: " errmsg " >>"))
        )
(setvar 'cmdecho cmde)
(setvar 'osmode os)
)
(setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))
(setq cmde (getvar "cmdecho"))
(setq os (getvar "osmode"))
(setvar 'cmdecho 0)
(setvar 'osmode 0)
(if
(setq ss1
        (car
                (LM:SelectIf
                        (strcat
                                "\nSelect an existing MULTILEADER to use as the new style\nor RMB-SPACEBAR-ENTER to use current: '"
                                (getvar "cmleaderstyle") "'."
                                )
                        (lambda ( x ) (eq "MULTILEADER" (cdr (assoc 0 (entget (car x)))))) entsel nil
                        )
                )
        )
(progn
        (setq existingMlvlaObj (vlax-ename->vla-object ss1)
                existingMlLayer (vla-get-Layer existingMlvlaObj)
                existingMlStyle (vla-get-StyleName existingMlvlaObj)
                existingMlWidth (vla-get-TextWidth existingMlvlaObj)
                )
        (if        (/= T (AT:isAnnotative ss1))
                (setq existingMlScale (vla-get-ScaleFactor existingMlvlaObj))
                )
        (princ (strcat "\nStyle to use: ' " existingMlStyle " '"))
        )
)
(initget "Titlecase Lowercase Uppercase Sentencecase toGglecase Keepcase")
(setq ansCase
(cond
        (
                (getkword
                        (strcat "\nChoose Text Case : [Title case/Lower case/Upper case/Sentence case/toGgle case/Keep case] <"
                                (setq ansCase
                                        (cond ( ansCase ) ( "Keepcase" ))
                                        )
                                ">: "
                                )
                        )
                )
        ( ansCase )
        )
)
(initget "Keepformatting Removeformatting")
(setq ansFromatting
(cond
        (
                (getkword
                        (strcat "\nChoose Formatting : [Keep formatting/Remove formatting] <"
                                (setq ansFromatting
                                        (cond ( ansFromatting ) ( "Keepformatting" ))
                                        )
                                ">: "
                                )
                        )
                )
        ( ansFromatting )
        )
)
(while
(setq ss2
        (LM:ssget "\nSelect 1 LEADER & 1 MTEXT: "
                (list "_:L"
                        (append '(
                                (-4 . "<OR")
                                (0 . "MTEXT")
                                (0 . "LEADER")
                                (-4 . "OR>")
                                )
                        )
                        )
                )
        )
(if (/= (sslength ss2) 2)
        (progn
                (alert "Select only 1 MTEXT and 1 LEADER.")
                (princ "        >>> 'LTM' failed selection, try again ...")(princ)
                )
        (progn
                (if (= (cdr (assoc 0 (entget (ssname ss2 0)))) "LEADER")
                        (setq
                                entLeader (entget (ssname ss2 0))
                                entTxt (entget (ssname ss2 1))
                                )
                        (setq
                                entLeader (entget (ssname ss2 1))
                                entTxt (entget (ssname ss2 0))
                                )
                        )
                (if
                        (or (and (eq (dxf 0 entLeader) "LEADER") (eq (dxf 0 entTxt) "LEADER"))
                                (and (eq (dxf 0 entLeader) "MTEXT") (eq (dxf 0 entTxt) "MTEXT")))
                        (progn
                                (alert "Please, check your Selection !\n\nSelect only 1 MTEXT and 1 LEADER.")
                                (princ "        >>> 'LTM' failed selection, try again ...")(princ)
                                )
                        (progn
                                (setq
                                        entLeaderName (dxf -1 entLeader)
                                        entTxtName (dxf -1 entTxt)
                                        existingTxtLayer (dxf 8 entTxt)
                                        entTxtVlaObj (vlax-ename->vla-object entTxtName)
                                        existingTxtString (vla-get-TextString entTxtVlaObj)
                                        existingTxtWidth (dxf 41 entTxt)
                                        existingTxtRot (dxf 50 entTxt)
                                        lstleaderpts (vl-remove-if-not
                                                '(lambda (p) (eq (car p) 10))
                                                entLeader
                                                )
                                        lstleaderlen (length lstleaderpts)
                                        ldxf10_1 (cdr (car lstleaderpts))
                                        ldxf10_1 (mapcar '(lambda (x)
                                                (round x 1)
                                                )
                                        ldxf10_1
                                        )
                                        ldxf10_2 (if (>= lstleaderlen 3)
                                                (cdr (nth (- lstleaderlen 2) lstleaderpts))
                                                )
                                        ldxf10_2 (mapcar '(lambda (x)
                                                (round x 1)
                                                )
                                        ldxf10_2
                                        )
                                        ldxf10_last (if (< lstleaderlen 3)
                                                (list (car (dxf 10 entTxt)) (cadr ldxf10_1) (caDDr (dxf 10 entTxt)))
                                                (list (car (dxf 10 entTxt)) (cadr ldxf10_2) (caDDr (dxf 10 entTxt)))
                                                ; (list (car (dxf 10 entTxt)) (cadr ldxf10_1) 0)
                                                ; (list (car (dxf 10 entTxt)) (cadr ldxf10_2) 0)
                                                )
                                        ldxf10_last (mapcar '(lambda (x)
                                                (round x 1)
                                                )
                                        ldxf10_last
                                        )
                                        )
                                (cond
                                        ((=  "Keepformatting" ansFromatting)
                                                )
                                        ((= "Removeformatting" ansFromatting)
                                                (setq existingTxtString (LM:UnFormat existingTxtString nil))
                                                )
                                        )
                                (progn
                                        (if (>= lstleaderlen 3)
                                                (progn
                                                        (command "._MLEADER" "_L" "_H" "_O" "_M" 3 "_A" "_N" "_X" "_non" (trans ldxf10_1 0 1) "_non" (trans ldxf10_2 0 1) "_non" (trans ldxf10_last 0 1) "")
                                                        )
                                                (progn
                                                        (command "._MLEADER" "_L" "_H" "_O" "_M" 2 "_A" "_N" "_X" "_non" (trans ldxf10_1 0 1) "_non" (trans ldxf10_last 0 1) "")
                                                        )
                                                )
                                        (setq newmleader (vlax-ename->vla-object (entlast)))
                                        (cond
                                                ((=  "Titlecase" ansCase)
                                                        (setq existingTxtString (acet-tcase-change-string existingTxtString "TITLE"))
                                                        )
                                                ((= "Lowercase" ansCase)
                                                        (setq existingTxtString (acet-tcase-change-string existingTxtString "LOWER"))
                                                        )
                                                ((= "Uppercase" ansCase)
                                                        (setq existingTxtString (acet-tcase-change-string existingTxtString "UPPER"))
                                                        )
                                                ((= "Sentencecase" ansCase)
                                                        (setq existingTxtString (acet-tcase-change-string existingTxtString "SENTENCE"))
                                                        )
                                                ((= "toGglecase" ansCase)
                                                        (setq existingTxtString (acet-tcase-change-string existingTxtString "TOGGLE"))
                                                        )
                                                ((= "Keepcase" ansCase)
                                                        (setq existingTxtString existingTxtString)
                                                        )
                                                )
                                        (setq existingTxtString (LM:StringSubst "\\\H" "\\\h" existingTxtString))
                                        (vla-put-TextString newmleader existingTxtString)
                                        (vla-put-TextRotation newmleader existingTxtRot)
                                        (if ss1
                                                (progn
                                                        (command "._MATCHPROP" ss1 (entlast) "")
                                                        (vla-put-TextWidth newmleader existingMlWidth)
                                                        ; (vla-put-StyleName newmleader existingMlStyle)
                                                        ; (vla-put-Layer newmleader existingMlLayer)
                                                        (if        (/= T (AT:isAnnotative ss1))
                                                                (vla-put-ScaleFactor newmleader existingMlScale)
                                                                )
                                                        )
                                                (progn
                                                        (vla-put-Layer newmleader existingTxtLayer)
                                                        (if (/= existingTxtWidth 0)
                                                                (vla-put-TextWidth newmleader existingTxtWidth)
                                                                )
                                                        )
                                                )
                                        (command "_.erase" entTxtName "")
                                        (command "_.erase" entLeaderName "")
                                        (command "_.move" (entlast) "" '(0 0 1e99) ""
                                                "_.move" "_p" "" '(0 0 -1e99) "")
                                        (princ "        >>> 'LTM' has done the business ...")(princ)
                                        )
                                )
                        )
                )
)
)
(*error* nil)
(princ)
)
;; Unknown Autor
(defun dxf (code elist)
(cdr (assoc code elist))
)
;; Doug Broad
;; additional credits Joe Burke, Peter Toby
(defun round (value to)
(setq to (abs to))
(* to (fix (/ ((if (minusp value) - +) value (* to 0.5)) to)))
)
;;--------------------=={ String Subst }==--------------------;;
;;                                                            ;;
;;  Substitutes a string for all occurrences of another       ;;
;;  string within a string.                                   ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  new - string to be substituted for 'old'                  ;;
;;  old - string to be replaced                               ;;
;;  str - the string to be searched                           ;;
;;------------------------------------------------------------;;
;;  Returns:  String with 'old' replaced with 'new'           ;;
;;------------------------------------------------------------;;
(defun LM:StringSubst ( new old str / inc len )
(setq len (strlen new)
        inc 0
        )
(while (setq inc (vl-string-search old str inc))
        (setq str (vl-string-subst new old str inc)
                inc (+ inc len)
                )
        )
str
)
;; ssget        -        Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;;
;; Arguments:
;; msg                -        selection prompt
;; params        -        list of ssget arguments
(defun LM:ssget ( msg params / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget params))
(setvar 'nomutt 0)
(if (and sel (not (vl-catch-all-error-p sel)))
        sel
        )
)
;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Provides continuous selection prompts until either a      ;;
;;  predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  msg  - prompt string                                      ;;
;;  pred - optional predicate function [selection list arg]   ;;
;;  func - selection function to invoke                       ;;
;;  keyw - optional initget argument list                     ;;
;;------------------------------------------------------------;;
;;  Returns:  Entity selection list, keyword, or nil          ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
        (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
                (cond
                        ( (= 7 (getvar 'ERRNO))
                                (princ "\nMissed, Try again.")
                                )
                        ( (eq 'STR (type sel))
                                nil
                                )
                        ( (vl-consp sel)
                                (if (and pred (not (pred sel)))
                                        (princ "\nInvalid Object Selected.")
                                        )
                                )
                        )
                )
        )
sel
)
;;-------------------=={ UnFormat String }==------------------;;
;;                                                            ;;
;;  Returns a string with all MTEXT formatting codes removed. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  str - String to Process                                   ;;
;;  mtx - MTEXT Flag (T if string is for use in MTEXT)        ;;
;;------------------------------------------------------------;;
;;  Returns:  String with formatting codes removed            ;;
;;------------------------------------------------------------;;
(defun LM:UnFormat ( str mtx / _replace rx )
(defun _replace ( new old str )
        (vlax-put-property rx 'pattern old)
        (vlax-invoke rx 'replace str new)
        )
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
        (progn
                (setq str
                        (vl-catch-all-apply
                                (function
                                        (lambda ( )
                                                (vlax-put-property rx 'global     actrue)
                                                (vlax-put-property rx 'multiline  actrue)
                                                (vlax-put-property rx 'ignorecase acfalse)
                                                (foreach pair
                                                        '(
                                                                ("\032"    . "\\\\\\\")
                                                                (" "       . "\\\\P|\\n|\\t")
                                                                ("$1"      . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
                                                                ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
                                                                ("$1$2"    . "\\\\(\\\\S)|[\\\\](})|}")
                                                                ("$1"      . "[\\\\]({)|{")
                                                                )
                                                        (setq str (_replace (car pair) (cdr pair) str))
                                                        )
                                                (if mtx
                                                        (_replace "\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
                                                        (_replace "\"   "\032" str)
                                                        )
                                                )
                                        )
                                )
                        )
                (vlax-release-object rx)
                (if (null (vl-catch-all-error-p str))
                        str
                        )
                )
        )
)
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/set-annotative-using-lisp-or-vlisp/m-p/3266716#M301077
;; Check if entity is annotative and which accounts for objects that were once annotative but are no longer.
;; ename - ename to check (returns T if annotative)
;; Alan J. Thompson
(defun AT:isAnnotative (ename / check)
(and (setq check (cdr (assoc 360 (entget ename))))
        (setq check (dictsearch check "AcDbContextDataManager"))
        (setq check (dictsearch (cdr (assoc -1 check)) "AcDb_AnnotationScales"))
        (assoc 350 check)
        )
)
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/set-annotative-using-lisp-or-vlisp/m-p/3266684#M301075
;; By User pbejse
;; (IsAnno-p
;;   (setq itm (vlax-ename->vla-object (Car (entsel))))
;;   )
(defun IsAnno-p (ent / exd ano)
(vl-load-com)
(and (eq (vla-get-HasExtensionDictionary ent) :vlax-true)
        (setq exd (vla-GetExtensionDictionary ent)
                exd (vla-item exd "AcDbContextDataManager")
                ano (vla-item exd "ACDB_ANNOTATIONSCALES")
                )
        (not (zerop (vla-get-Count ano)))
        )
)
(load "TcaseSup.lsp")
(vl-load-com)
;; End
(princ
(strcat
        "\n:: Leader_To_Multileader.lsp edited on "
        (menucmd "m=$(edtime,0,DD-MO-yyyy)")
        " by 3dwannab (stephensherry147@yahoo.co.uk) loaded ::"
        "\n:: Type "Leader_To_Multileader" OR "LTM" to run Program ::"
        )
)
(princ)