[编程交流] 将对象设为块

;;; http://forum.dwg.ru/showthread.php?t=26548&page=3
[color="red"];;; Where to change the value of the interval between lines of paragraph
;;; in the reactor at multilider?
;;; search line (mtext-paragraph "\ \ pxse" 0.86667 (entlast))
;;; it change the number of 0.86667 to the desired[/color]
(defun le-endCommand (CALL CALLBACK)
 (if (= (strcase (car CALLBACK)) "MLEADER")
 (mtext-paragraph "\\pxse" [b][size="4"][color="red"]0.86667[/color][/size][/b] (entlast)) [b][color="red"];;; This changes the value of line spacing section![/color][/b]
)
)
(defun gc:FieldCode (ent / foo elst xdict dict field str)
 ;; credits gile
 (defun foo (field str / pos fldID objID)
   (setq pos 0)
   (if (setq pos (vl-string-search "\\_FldIdx " str pos))
     (while (setq pos (vl-string-search "\\_FldIdx " str pos))
       (setq fldId (entget (cdr (assoc 360 field)))
             field (vl-remove (assoc 360 field) field)
             str   (strcat
                     (substr str 1 pos)
                     (if (setq objID (cdr (assoc 331 fldId)))
                       (vl-string-subst
                         (strcat "ObjId " (itoa (gc:EnameToObjectId objID)))
                         "ObjIdx"
                         (cdr (assoc 2 fldId))
                       )
                       (foo fldId (cdr (assoc 2 fldId)))
                     )
                     (substr str (1+ (vl-string-search ">%" str pos)))
                   )
       )
     )
     str
   )
 )
   ;; gc:EnameToObjectId (gile)
;; Returns the ObjectID from an ename
;;
;; Argument : an ename
(defun gc:EnameToObjectId (ename)
 ;; credits gile
 ((lambda (str)
    (hex2dec
      (substr (vl-string-right-trim ">" str) (+ 3 (vl-string-search ":" str)))
    )
  )
   (vl-princ-to-string ename)
 )
)
   ;;============================================================;;
;; hex2dec (gile)
;; convert an hexadecimal into a decimal (int)
;;
;; Argument : un hexadedimal (string)
(defun hex2dec (s / r l n)
 (setq        r 0 l (vl-string->list (strcase s)))
 (while (setq n (car l))
   (setq l (cdr l)
         r (+ (* r 16) (- n (if (<= n 57) 48 55)))
   )
 )
)
 ;;--------------------------------------------------------;;
 
 (setq elst (entget ent))
 (if (vlax-property-available-p (vlax-ename->vla-object ent) 'Textstring)
   (setq str (vla-get-TextString (vlax-ename->vla-object ent)))
   )
 (if (and
(member (cdr (assoc 0 elst)) '("ATTRIB" "MTEXT" "TEXT" "MULTILEADER"))
(setq xdict (cdr (assoc 360 elst)))
(setq dict (dictsearch xdict "ACAD_FIELD"))
(setq field (dictsearch (cdr (assoc -1 dict)) "TEXT"))
     )
   (setq str (foo field (cdr (assoc 2 field))))
 )
   str
)
(defun isFieldAvailable ( obj  / fc )
 (if (= (type obj) 'ENAME)
     (setq obj (vlax-ename->vla-object obj))
   )
 (and
   (setq fc (vla-GetExtensionDictionary  obj))
   (setq fc (vlax-vla-object->ename fc))
   (dictsearch fc "ACAD_FIELD")
   )
)
(defun mtext-paragraph ( pat value obj / ss i mtext ent)
;;; Изменить межстрочный интервал мтекста и многострочных аттрибутов
;;; Change Line Spacing
;;; http://forum.dwg.ru/showthread.php?t=54857
;;; Измените значение системной переменной ATTIPE на 1 и будет
;;; в редакторе многострочных атрибутов полноценный вариант редактора
;;; pat "\\pxse" or "\\pxsm"
;;; value - koeff like 0.86667
;;; obj - ename or vla object
 (vl-load-com)
 (setq value (rtos value 2 5))
 (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
 (setq ent (vlax-vla-object->ename obj))
 (if (and (vlax-write-enabled-p obj)
       (vlax-property-available-p obj 'Textstring)
                (or (not (vlax-property-available-p obj 'MTextAttribute))
                    (and (vlax-property-available-p obj 'MTextAttribute)
                         (eq (vla-get-MTextAttribute obj) :vlax-true)
                         )
                    )
                )
         (progn
           (setq mtext (gc:FieldCode ent))
           (if (not(setq i (vl-string-search "\\PX" (strcase mtext))))
             (setq i 0)
             )
           (if (wcmatch (strcase (substr mtext (1+ i) 3)) "\\PX")  
             (setq mtext
                 (strcat (if (not (zerop i))(substr mtext 1 i) "")
                 pat value ";"
                 (substr mtext (+ 2 (vl-string-search ";" mtext i))))
                   )
             (setq mtext (strcat pat value ";" mtext))
             )
           (vla-put-TextString obj mtext)
           (if (isFieldAvailable obj)
             (progn
               (vl-cmdf "_.updatefield" ent "")
               (entupd ent)
               )
             )
           )
       )
 )
(defun C:MTLS ( / ss i lst mtext ls *LS*)
;;; MText Line Spacing
;;; Change line spacing mtext and multi-attribute
;;; Change Line Spacing
;;; Http://forum.dwg.ru/showthread.php?t=54857
;;; Change the value of system variable ATTIPE at 1 and will
;;, the editor of multi-attributes high-grade version of the editor  (vl-load-com)
 (if (zerop
     (setq
       *LS* (abs
              (atof (vl-princ-to-string (getcfg "AppData/MTEXTLS/LS")))
            ) ;_ end of abs
     ) ;_ end of setq
   ) ;_ end of zerop
 (setq *LS* 1)
) ;_ end of if
 (if (and
       (progn
         (initget 6)
         (princ "\nEnter line spasing value <")
         (princ *LS*)
         (princ ">: ")
         (if (setq ls (getreal))
           (progn
             (setq *LS* ls)
             (setcfg "AppData/MTEXTLS/LS" (rtos *LS* 2 2))
             )
           (setq ls *LS*)
           )
       )
       (setq lst nil ss (ssget "_:L" '((0 . "MTEXT,ATTDEF,INSERT,MULTILEADER"))))
       (repeat (setq i (sslength ss)) ;_ end setq
        (setq lst (cons (ssname ss (setq i (1- i))) lst))
        ) ;_ en
       )
   (progn
     (setq ss nil)
     (foreach itm lst
       (if (and itm (setq itm (vlax-ename->vla-object itm))
          (vlax-property-available-p itm 'Hasattributes)
   (eq :vlax-true (vla-get-HasAttributes itm))
                )
         (setq ss (append ss
                          (mapcar 'vlax-vla-object->ename
                          (append (vlax-invoke itm 'Getattributes)(vlax-invoke itm 'Getconstantattributes))
                                  )
                          )
               )
          )
       )
     (setq lst (append lst ss))
     (foreach itm lst (mtext-paragraph "\\pxsm" ls itm))
   )
   )
 (princ)
)
(defun C:MTLE ( / ss i lst mtext ls *LE*)
;;; MText Line Equal
;;; Change line spacing mtext and multi-attribute
;;; Change Line Equal
;;; Http://forum.dwg.ru/showthread.php?t=54857
;;; Change the value of system variable ATTIPE at 1 and will
;;, the editor of multi-attributes high-grade version of the editor
 (vl-load-com)
 (if (zerop
     (setq
       *LE* (abs
              (atof (vl-princ-to-string (getcfg "AppData/MTEXTLS/LE")))
            ) ;_ end of abs
     ) ;_ end of setq
   ) ;_ end of zerop
 (setq *LE* 1)
) ;_ end of if
 (if (and
       (progn
         (initget 6)
         (princ "\nEnter line spasing (equal) value <")
         (princ *LE*)
         (princ ">: ")
         (if (setq ls (getreal))
           (progn
             (setq *LE* ls)
             (setcfg "AppData/MTEXTLS/LE" (rtos *LE* 2 2))
             )
           (setq ls *LE*)
           )
       )
       (setq lst nil ss (ssget "_:L" '((0 . "MTEXT,ATTDEF,INSERT,MULTILEADER"))))
       (repeat (setq i (sslength ss)) ;_ end setq
        (setq lst (cons (ssname ss (setq i (1- i))) lst))
        ) ;_ en
       )
   (progn
     (setq ss nil)
     (foreach obj lst
       (if (and obj (setq obj (vlax-ename->vla-object obj))
          (vlax-property-available-p obj 'Hasattributes)
   (eq :vlax-true (vla-get-HasAttributes obj))
                )
         (setq ss (append ss
                          (mapcar 'vlax-vla-object->ename
                          (append (vlax-invoke obj 'Getattributes)(vlax-invoke obj 'Getconstantattributes))
                                  )
                          )
               )
          )
       )
     (setq lst (append lst ss))
     (foreach itm lst (mtext-paragraph "\\pxse" ls itm))
   )
   )
 (princ)
)
 
 
(defun C:VLR_MTLE_ON ()
 (vl-load-com)
 (or *vlr-MTLE
    (setq *vlr-MTLE (vlr-command-reactor nil '((:vlr-commandEnded . le-endCommand)))))
 (princ "\nMtex Line Equal Reactor ON")
 (setvar "MODEMACRO" (strcat "*LE* "(VL-STRING-LEFT-TRIM "*LE* " (getvar "MODEMACRO"))))
 (princ)
)
;;  Turn the reactors off
(defun C:VLR_MTLE_OFF ()
 (and *vlr-MTLE (vlr-added-p *vlr-MTLE) (vlr-remove *vlr-MTLE))
 (setvar "MODEMACRO" (VL-STRING-LEFT-TRIM "*LE* " (getvar "MODEMACRO")))
 (princ "\nMtex Line Equal Reactor OFF")
 (princ)
)
(princ "\nType MTLE, MTLS, VLR_MTLE_ON, VLR_MTLE_OFF in command line")

(command "VLR_MTLE_ON")

(c:VLR_MTLE_ON)