[编程交流] 文本到属性，然后是cre

(defun c:txt2att ( / el i ss st selectionset insertionpoint number Blockname ) (vl-load-com)
 
 (if (setq ss (ssget "_:L" '((0 . "TEXT"))))
   (repeat (setq i (sslength ss))
     (setq el (entget (ssname ss (setq i (1- i))))
           st (vl-string-translate " " "_" (cdr (assoc 1 el)))
     )
     (if
       (entmakex
         (append '((0 . "ATTDEF"))
           (vl-remove-if '(lambda ( pair ) (member (car pair) '(0 100 73))) el)
           (list
             (cons 70  0)
             (cons 74 (cdr (assoc 73 el)))
             (cons  2 st)
             (cons  3 st)
           )
         )
       )
       (entdel (cdr (assoc -1 el)))
     )
   )
 )
 (if (and (setq selectionset (ssget "_:L"))
          (setq insertionpoint (getpoint "n Specify insertion point :"))
     )
   (progn
     (setq number    1
           Blockname (strcat "MyBlock" (itoa number))
     )
     (while (tblsearch "BLOCK" Blockname)
       (setq Blockname
              (strcat "MyBlock" (itoa (setq number (1+ number))))
       )
     )
     (command "_.-Block" Blockname insertionpoint selectionset "")
     (command "_.-insert" Blockname insertionpoint "" "" "")
   )
   (princ)
 )
 (princ)
)

;This is a bit rough but a starting point
(setq ss1 (ssget  (list (cons 0 "TEXT,MTEXT"))))  ;pick text 
(setq len (sslength ss1))
; the len is the number of text

(defun C:axbt  (/ *error* acsp adoc align attobj block_coll block_def bname bref
 en hgt msg name names orig pmt sset style tag txtobj txtval val)
 (vl-load-com)
 (defun *error* (msg)
   (if adoc (vla-endundomark  adoc))
   (if
     (and msg
   (not
     (member
       msg
       '("console break"
  "Function cancelled"
  "quit / exit abort"
  ""
 )
     )
   )
     )
      (princ (strcat "\nError: " msg))
   )
   (setvar "nomutt" 0)
   
   
   (princ)
 )
(or adoc
    (setq adoc (vla-get-activedocument
   (vlax-get-acad-object))))
(or acsp
    (setq acsp (if (= (getvar "CVPORT") 1)
   (vla-get-paperspace
     adoc)
   (vla-get-modelspace
     adoc)
   )
   )
    )
(setq block_coll (vla-get-blocks adoc))
(vla-endundomark adoc)
(vla-startundomark adoc)
(while (tblsearch "BLOCK"
    (setq bname (getstring T "\nEnter block name: ")))
  (progn
    (alert "Block already exist, input another name")
    (setq msg "")
    (vlax-for obj  (setq names (vlax-map-collection block_coll 'vla-get-name))
      (setq name (vla-get-name obj))
      (if (not (wcmatch name "`**"))
 (setq msg (strcat msg (vla-get-name obj) "\n"))))
    (alert (strcat "Check existing blocks:\n" msg))))
(setvar "nomutt" 0)
(prompt
  "\nSelect a single text by single pick to get properies from\n")
(setvar "nomutt" 1)
(while (not
  (setq sset (ssget "_:S:L" (list (cons 0 "text")))))
  (alert (strcat "Select text again")))
(setq txtobj (vlax-ename->vla-object (ssname sset 0)))
(setvar "aflags" 4)
(setvar "attreq" 0)
(setvar "attdia" 1)
(setvar "nomutt" 0)
(prompt "\nCreating block with ActiveX method\n")
(setq orig (vlax-get txtobj 'insertionpoint)
      pmt  "Panel type"     ; prompt
      tag  "PANEL_TYPE"     ;tag
      val  (vlax-get txtobj 'textstring)   ;default value
      )
(setq hgt   (vlax-get txtobj 'height)
      style (vlax-get txtobj 'stylename)
      align (vlax-get txtobj 'alignment))
;; add block definition first
(setq block_def (vla-add block_coll (vlax-3d-point orig) bname))
;; change properties of the block definition
(vla-put-blockscaling block_def 1)
(vla-put-blockscaling block_def 1)
(vla-put-units block_def 1) ; possible enums: acInsertUnitsInches, acInsertUnitsUnitless, acInsertUnitsMillimeters, acInsertUnitsMeters, etc
;; add attribute 
(setq attobj (vlax-invoke
 block_def
 'addattribute
 hgt
 acattributemodepreset
 pmt
 orig
 tag
 val))
;; change properties of the attribute
(vlax-put attobj 'alignment align)
(vlax-put attobj 'stylename style)
(vla-put-layer attobj "0")
(vlax-put attobj 'color 0)
(princ "\n")
(if (not (tblsearch "BLOCK" bname))
  (progn
    (alert "Error on  creating blocks")
    (exit)
    (princ))
  (progn
    (setvar "nomutt" 0)
    (prompt "\n\nSelect all texts to convert to blocks\n")
    (setvar "nomutt" 1)
    (if (setq tset (ssget "_:L" (list (cons 0 "text"))))
      (while (setq en (ssname tset 0))
 (setq txtobj (vlax-ename->vla-object en))
 (setq xlist (cons txtobj xlist))
 (setq orig (vlax-get txtobj 'insertionpoint))
 (setq txtval (vla-get-textstring txtobj))
 (setq orig (vlax-get txtobj 'insertionpoint))
 (setq bref (vlax-invoke acsp 'insertblock orig bname 1 1 1 0))
 (foreach attobj  (vlax-invoke bref 'getattributes)
   (if (eq tag (vla-get-tagstring attobj))
     (vla-put-textstring attobj txtval)
     (vla-update attobj))
   )
 (ssdel en tset)
 (entdel en)
 )
      )
    (setvar "nomutt" 0)
    )
  )
(vl-catch-all-apply
  '(lambda () (vlax-release-object block_def)))
(*error* nil)
(princ)
 )   
(princ "\n\t\t   Start command with: AXBT\n")
(prin1)