cad尺寸标注时自动添加文字替代

xtzw988

我想在标注尺寸的时候让文字替代里自动添加所标尺寸的内容，让尺寸值固定，拉伸尺寸的时候值不会变。有人能帮忙吗？

xtzw988

;;COPY TEXT FROM ONE ENTITIES TO MANY
;;BY ERIC WONG
;;Modified at 05-07-2005 At Table support on Ctext
;;;------------------------------------------------------------------------
(defun C:CTEXT (/      CTEXT1 ENTP   ESEL   ESEL2  ENT          ENTX         SS
                SSM    SSN    SS1    EG1    EG2           CT_HL  ATTLIST
                EP1    EP2    ROWNO  COLNO
               )
  (setq CT_HL (getvar "HIGHLIGHT"))
  (setvar "HIGHLIGHT" 1)
  (while (= NIL ENTP)
    (setq ENTP (entsel "\nSelect Text or Attribute to be copied:"))
  )
  (redraw (setq ENT (car ENTP)) 3)
  (setq ENTX (vlax-ename->vla-object ENT))
  ;;SOURCE TEXT
  (cond
    ((= (cdr (assoc 0 (entget ENT))) "INSERT")
     (vl-load-com)
     (setq ESEL          (car (nentselp (cadr ENTP)))
           CTEXT1 (vla-get-textstring (vlax-ename->vla-object ESEL))
     )
    )
    ((wcmatch (cdr (assoc 0 (entget ENT))) "*TEXT")
     (setq CTEXT1 (cdr (assoc 1 (entget ENT))))
    )
    ((= (cdr (assoc 0 (entget ENT))) "DIMENSION")
     (if (= "" (setq CTEXT1 (vla-get-textoverride ENTX)))
       (cond ((vlax-property-available-p ENTX 'ROUNDDISTANCE)
              (setq CTEXT1 (rtos (ACET-CALC-ROUND
                                   (vla-get-measurement ENTX)
                                   (vla-get-rounddistance ENTX)
                                 )
                                 2
                                 (vla-get-primaryunitsprecision ENTX)
                           )
              )
             )
             ((vlax-property-available-p ENTX 'ANGLEFORMAT)
              (setq CTEXT1 (strcat (rtos (RTD (vla-get-measurement ENTX))
                                         2
                                         (vla-get-textprecision ENTX)
                                   )
                                   "%%d"
                           )
              )
             )
       )
     )
    )
    ((= (cdr (assoc 0 (entget ENT))) "ACAD_TABLE")
     (= EG1 "ACAD_TABLE")
     (setq EG2 (car (nentselp (cadr ENTP))))
     (if (wcmatch (cdr (assoc 0 (entget EG2))) "*TEXT")
       (progn (vla-hittest
                (vlax-ename->vla-object (car ENTP))
                (vlax-3d-point (cadr ENTP))
                (vla-get-direction
                  (vla-get-activeviewport
                    (vla-get-activedocument (vlax-get-acad-object))
                  )
                )
                'ROWNO
                'COLNO
              )
              (setq CTEXT1 (vla-gettext
                             (vlax-ename->vla-object (car ENTP))
                             ROWNO
                             COLNO
                           )
              )
       )
       (progn (princ "\nNo Text Selected in Table.") (exit))
     )
    )
  )
  (if (= NIL CTEXT1)
    (progn (princ "\nNo Text can be copy!") (exit))
  )
  (princ "\nText are copied to :")
  (setq EP1 (entsel))
  ;;DESTINATION TEXT
  (if (/= NIL EP1)
    (while (/= NIL EP1)
      (redraw ENT 4)
      (setq EG1 (cdr (assoc 0 (entget (car EP1)))))
      (cond
        ((wcmatch EG1 "*TEXT")
         (if (= "ARCALIGNEDTEXT" EG1)
           (vlax-put-property
             (vlax-ename->vla-object (car EP1))
             'CONTENTS
             CTEXT1
           )
           (vla-put-textstring
             (vlax-ename->vla-object (car EP1))
             CTEXT1
           )
         )
        )
        ((= EG1 "DIMENSION")
         (entmod (subst        (cons 1 CTEXT1)
                        (assoc 1 (entget (car EP1)))
                        (entget (car EP1))
                 )
         )
        )
        ((= EG1 "INSERT")
         (setq EG2 (car (nentselp (cadr EP1))))
         (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
           (vla-put-textstring (vlax-ename->vla-object EG2) CTEXT1)
           (progn (princ "\nNot match Attribute.") (exit))
         )
        )
        ((= EG1 "ACAD_TABLE")
         (setq EG2 (car (nentselp (cadr EP1))))
         (if (wcmatch (cdr (assoc 0 (entget EG2))) "*TEXT")
           (progn (vla-hittest
                    (vlax-ename->vla-object (car EP1))
                    (vlax-3d-point (cadr EP1))
                    (vla-get-direction
                      (vla-get-activeviewport
                        (vla-get-activedocument (vlax-get-acad-object))
                      )
                    )
                    'ROWNO
                    'COLNO
                  )
                  (vla-settext
                    (vlax-ename->vla-object (car EP1))
                    ROWNO
                    COLNO
                    CTEXT1
                  )
                  (vla-recomputetableblock
                    (vlax-ename->vla-object (car EP1))
                    :vlax-true
                  )
           )
           (progn (princ "\nNo Text Selected in Table.") (exit))
         )
        )
      )
      (setq EP1 (entsel))
    )
    (progn
      (setq SS        (ssget '((0 . "TEXT,MTEXT,DIMENSION,INSERT,ARCALIGNEDTEXT"))
                )
            SSM        (sslength SS)
            SSN        0
      )                                        ;SETQ
      (redraw ENT 4)
      (repeat SSM
        (setq SS1      (ssname SS SSN)
              EG1      (cdr (assoc 0 (entget SS1)))
              ATTLIST  NIL
              ATTLIST2 NIL
              SSN      (1+ SSN)
        )
        (cond
          ((wcmatch EG1 "*TEXT")
           (if (= "ARCALIGNEDTEXT" EG1)
             (vlax-put-property
               (vlax-ename->vla-object SS1)
               'CONTENTS
               CTEXT1
             )
             (vla-put-textstring (vlax-ename->vla-object SS1) CTEXT1)
           )
          )
          ((= EG1 "DIMENSION")
           (vla-put-textoverride (vlax-ename->vla-object SS1) CTEXT1)
          )
          ((= EG1 "INSERT")
           (if (/= :vlax-false
                   (vla-get-hasattributes (vlax-ename->vla-object SS1))
               )
             (progn
               (setq ATTLIST (vlax-safearray->list
                               (vlax-variant-value
                                 (vla-getattributes
                                   (vlax-ename->vla-object SS1)
                                 )
                               )
                             )
               )
               (if (= 1 (length ATTLIST))
                 (vla-put-textstring (car ATTLIST) CTEXT1)
                 (progn
                   (if (= NIL ESEL2)
                     (progn (princ "\nPlease Specify Attribute Tag :")
                            (setq ESEL2        (vla-get-tagstring
                                          (vlax-ename->vla-object
                                            (car (nentselp))
                                          )
                                        )
                            )
                     )
                   )
                   (setq ATTLIST2 (vl-remove-if-not
                                    '(lambda (X)
                                       (= ESEL2 (vla-get-tagstring X))
                                     )
                                    ATTLIST
                                  )
                   )
                   (if (= NIL ATTLIST2)
                     (princ "\nNot match Attribute.")
                     (vla-put-textstring (car ATTLIST2) CTEXT1)
                   )
                 )
               )
             )
             (princ "\nBlock has no attributes")
           )
          )
        )
      )                                        ;repeat
    )
  )                                        ;if
  (setvar "HIGHLIGHT" CT_HL)
  (defun ROUND (N) (* (SIGNOF N) (fix (+ (abs N) 0.5))))
  ;; Signof - returns -1 or 1 for sign of number
  (defun SIGNOF        (N)
    (if        (minusp N)
      -1
      1
    )
  )
  (princ)
) ;_ end of DEFUN
;;;------------------------------------------------------------------------
(defun C:CTEXTM        (/            TSS               TSSL          TSSN             SORTD
                 TXTENT            TXTELIST   PTLIST          COMBOLIST  COMBOLISTS
                 TXTLISTS   TSS2       TSS2L          TSS2N             TXTENT2
                 TXTELIST2  PTLIST2    COMBOLIST2 COMBOLIST2S
                 TXTELIST2S
                )
  (princ "\nSelects a column of Text(s) to copy from :")
  (setq        TSS  (ssget '((-4 . "<OR") (0 . "*TEXT") (0 . "DIMENSION") (-4 . "OR>")))
        TSSL (sslength TSS)
        TSSN 0
  )
  (repeat TSSL
    (setq TXTENT   (ssname TSS TSSN)
          TSSN           (1+ TSSN)
          TXTELIST (cons TXTENT TXTELIST)
    )
  )
  (setq PTLIST (mapcar '(lambda (X) (cdr (assoc 10 (entget X)))) TXTELIST))
  (setq COMBOLIST (mapcar 'cons PTLIST TXTELIST))
  (setq        COMBOLISTS
         (vl-sort COMBOLIST '(lambda (1% 2%) (> (cadar 1%) (cadar 2%))))
  )
  ;;sort by Y
  (setq        TXTLISTS
         (mapcar '(lambda (X) (cdr (assoc 1 (entget (cdr X))))) COMBOLISTS)
  )
  (princ "\nNow pls select a column of Text(s) to copy:")
  (setq        TSS2  (ssget '((-4 . "<OR") (0 . "*TEXT") (0 . "DIMENSION") (-4 . "OR>")))
        TSS2L (sslength TSS2)
        TSS2N 0
  )
  (repeat TSS2L
    (setq TXTENT2   (ssname TSS2 TSS2N)
          TSS2N            (1+ TSS2N)
          TXTELIST2 (cons TXTENT2 TXTELIST2)
    )
  )
  (setq PTLIST2 (mapcar '(lambda (X) (cdr (assoc 10 (entget X)))) TXTELIST2))
  (setq COMBOLIST2 (mapcar 'cons PTLIST2 TXTELIST2))
  (setq        COMBOLIST2S
         (vl-sort COMBOLIST2 '(lambda (1% 2%) (> (cadar 1%) (cadar 2%))))
  )
  ;;sort by Y
  (setq TXTELIST2S (mapcar 'cdr COMBOLIST2S))
;;;COPY NOW
  (mapcar '(lambda (1% 2%)
             (entmod (subst (cons 1 1%) (assoc 1 (entget 2%)) (entget 2%)))
           )
          TXTLISTS
          TXTELIST2S
  )
  (princ "\nColumn copy complete.")
  (princ)
)
;;;CTEXTM
;;;----------------------------------------------------------------------
(defun C:CTEXTR        (/            TSS               TSSL          TSSN             SORTD
                 TXTENT            TXTELIST   PTLIST          COMBOLIST  COMBOLISTS
                 TXTLISTS   TSS2       TSS2L          TSS2N             TXTENT2
                 TXTELIST2  PTLIST2    COMBOLIST2 COMBOLIST2S
                 TXTELIST2S
                )
  (princ "\nSelects a rows of Text(s) to copy from :")
  (setq        TSS  (ssget '((-4 . "<OR") (0 . "*TEXT") (0 . "DIMENSION") (-4 . "OR>")))
        TSSL (sslength TSS)
        TSSN 0
  )
  (repeat TSSL
    (setq TXTENT   (ssname TSS TSSN)
          TSSN           (1+ TSSN)
          TXTELIST (cons TXTENT TXTELIST)
    )
  )
  (setq PTLIST (mapcar '(lambda (X) (cdr (assoc 10 (entget X)))) TXTELIST))
  (setq COMBOLIST (mapcar 'cons PTLIST TXTELIST))
  (setq        COMBOLISTS
         (vl-sort COMBOLIST '(lambda (1% 2%) (> (caar 1%) (caar 2%))))
  )
  ;;sort by Y
  (setq        TXTLISTS
         (mapcar '(lambda (X) (cdr (assoc 1 (entget (cdr X))))) COMBOLISTS)
  )
  (princ "\nNow pls select a row of Text(s) to copy:")
  (setq        TSS2  (ssget '((-4 . "<OR") (0 . "*TEXT") (0 . "DIMENSION") (-4 . "OR>")))
        TSS2L (sslength TSS2)
        TSS2N 0
  )
  (repeat TSS2L
    (setq TXTENT2   (ssname TSS2 TSS2N)
          TSS2N            (1+ TSS2N)
          TXTELIST2 (cons TXTENT2 TXTELIST2)
    )
  )
  (setq PTLIST2 (mapcar '(lambda (X) (cdr (assoc 10 (entget X)))) TXTELIST2))
  (setq COMBOLIST2 (mapcar 'cons PTLIST2 TXTELIST2))
  (setq        COMBOLIST2S
         (vl-sort COMBOLIST2 '(lambda (1% 2%) (> (caar 1%) (caar 2%))))
  )
  ;;sort by Y
  (setq TXTELIST2S (mapcar 'cdr COMBOLIST2S))
;;;COPY NOW
  (mapcar '(lambda (1% 2%)
             (entmod (subst (cons 1 1%) (assoc 1 (entget 2%)) (entget 2%)))
           )
          TXTLISTS
          TXTELIST2S
  )
  (princ "\nRow copy complete.")
  (princ)
)
;;;------------------------------------------------------------------------
;;APPEND TEXT FROM ONE ENTITIES TO MANY
;;BY ERIC WONG
(defun C:APTEXT        (/ ATEXT1 ATEXT2 S SS SSM SSN SS1 EG1 EG2 AT_HL)
  (setq AT_HL (getvar "HIGHLIGHT"))
  (setvar "HIGHLIGHT" 1)
  (redraw (setq ENT (car (entsel "\nSelect Text to be copied for Append:")))
          3
  ) ;_ end of REDRAW
  (if (= (cdr (assoc 0 (entget ENT))) "INSERT")
    (setq ATEXT1 (cdr (assoc 2 (entget ENT))))
    (setq ATEXT1 (cdr (assoc 1 (entget ENT))))
  ) ;_ end of IF
  (princ "\nText are Appended to :")
  (setq        SS  (ssget)
        SSM (sslength SS)
        SSN 0
  ) ;SETQ
  (redraw ENT 4)
  (repeat SSM
    (setq SS1         (ssname SS SSN)
          EG1         (entget SS1)
          ATEXT2 (strcat (cdr (assoc 1 EG1)) " \\P" ATEXT1)
          EG2         (subst (cons 1 ATEXT2) (assoc 1 EG1) EG1)
          SSN         (1+ SSN)
    ) ;SETQ
    (entmod EG2)
  ) ;REPEAT
  (setvar "HIGHLIGHT" AT_HL)
  (princ)
) ;_ end of DEFUN

;;;------------------------------------------------------------------------
;;SORT Text
;;By Eric Wong
(defun C:TSORT (/           TSS              TSSL         TSSN            SORTD
                TXTENT           TXTELIST   PTLIST         TXTLIST    COMBOLIST
                COMBOLISTS TXTELISTS
               )
  (setq        TSS  (ssget '((0 . "*TEXT")))
        TSSL (sslength TSS)
        TSSN 0
  )
  (initget 1 "X Y")
  (setq SORTD (getkword "\nSort Direction <X/Y> :"))
  (repeat TSSL
    (setq TXTENT   (ssname TSS TSSN)
          TSSN           (1+ TSSN)
          TXTELIST (cons TXTENT TXTELIST)
    )
  )
  (setq PTLIST (mapcar '(lambda (X) (cdr (assoc 10 (entget X)))) TXTELIST))
  (setq        TXTLIST        (acad_strlsort
                  (mapcar '(lambda (X) (cdr (assoc 1 (entget X)))) TXTELIST)
                )
  )
  (setq COMBOLIST (mapcar 'cons PTLIST TXTELIST))
  (if (= SORTD "X")
    (setq COMBOLISTS
           (vl-sort COMBOLIST '(lambda (1% 2%) (> (caar 1%) (caar 2%))))
    )
    (setq COMBOLISTS
           (vl-sort COMBOLIST '(lambda (1% 2%) (> (cadar 1%) (cadar 2%))))
    )
  )
  (setq TXTELISTS (mapcar 'cdr COMBOLISTS))
  (mapcar '(lambda (1% 2%)
             (entmod (subst (cons 1 1%) (assoc 1 (entget 2%)) (entget 2%)))
           )
          TXTLIST
          TXTELISTS
  )
  (princ "\nSort Txt complete")
  (princ)
)
;;;------------------------------------------------------------------------
;;ATTRIB COUNT
;;FUNCTION LIKE TCOUNT IN EXPRESS
;;BY Eric Wong
(defun C:ATCOUNT (/            TSS              TSSL        TSSN          STIN            SORTD
                  STINN            TXTENT    TXTXENT        ATTXENT          ATTXELIST TXTELIST
                  PTLIST    COMBOLIST COMBOLISTS          ATTXELISTS
                  STLIST    MISS      REV
                 )
  (setq        TSS  (ssget '((0 . "INSERT")))
        TSSL (sslength TSS)
        TSSN 0
  )
  (if (= STIN2 NIL)
    (setq STIN2 "1,1")
  )
  (initget 1 "X Y")
  (setq        SORTD (getkword "Sort selected objects by [X/Y]:")
        STIN  (getstring
                (strcat        "\nSpecify starting number and increment (Start,increment) <"
                        STIN2
                        ">:"
                )
              )
  )
  (initget 1 "Overwrite Prefix Suffix")
  (setq        PLACE (getkword
                "\nPlacement of numbers in text [Overwrite/Prefix/Suffix..] :"
              )
  )
  (if (= STIN "")
    (setq STIN STIN2)
    (setq STIN2 STIN)
  )
  (setq        STINN (vl-string-position (ascii ",") STIN)
        STNO  (substr STIN 1 STINN)
        INNO  (substr STIN (+ STINN 2) (strlen STIN))
        STNO2 (rtos (atoi STNO) 2 0)
  )
  (repeat TSSL
    (setq TXTENT (ssname TSS TSSN)
          TSSN         (1+ TSSN)
    )
    (if
      (= (vla-get-hasattributes (setq TXTXENT (vlax-ename->vla-object TXTENT)))
         :vlax-true
      )
       (if (= "ITEMNO"
              (vla-get-tagstring
                (setq
                  ATTXENT (car (vlax-safearray->list
                                 (vlax-variant-value (vla-getattributes TXTXENT))
                               )
                          )
                )
              )
           )
         (progn        (setq TXTELIST (cons TXTENT TXTELIST))
                (setq ATTXELIST (cons ATTXENT ATTXELIST))
         )
       )
    )
  )
  (repeat (length TXTELIST)
    (if        (> (setq MISS (- (strlen STNO) (strlen STNO2))) 0)
      (repeat MISS (setq STNO2 (strcat "0" STNO2)))
    )
    (setq STLIST (cons STNO2 STLIST))
    (setq STNO2 (rtos (+ (atoi STNO2) (atoi INNO)) 2 0))
  )
  (setq PTLIST (mapcar '(lambda (X) (cdr (assoc 10 (entget X)))) TXTELIST))
  (setq COMBOLIST (mapcar 'cons PTLIST ATTXELIST))
  (if (= SORTD "X")
    (setq COMBOLISTS
           (vl-sort COMBOLIST '(lambda (1% 2%) (> (caar 1%) (caar 2%))))
    )
    (setq COMBOLISTS
           (vl-sort COMBOLIST '(lambda (1% 2%) (< (cadar 1%) (cadar 2%))))
    )
  )
  (setq ATTXELISTS (mapcar 'cdr COMBOLISTS))
  (cond        ((= PLACE "Overwrite")
         (mapcar '(lambda (1% 2%) (vla-put-textstring 2% 1%))
                 STLIST
                 ATTXELISTS
         )
         (initget 0 "Yes No")
         (setq REV (getkword "Need to reverse? [Yes/No] <No> :"))
        )
        ((= PLACE "Prefix")
         (mapcar '(lambda (1% 2%)
                    (vla-put-textstring 2% (strcat 1% (vla-get-textstring 2%)))
                  )
                 STLIST
                 ATTXELISTS
         )
        )
        ((= PLACE "Suffix")
         (mapcar '(lambda (1% 2%)
                    (vla-put-textstring 2% (strcat (vla-get-textstring 2%) 1%))
                  )
                 STLIST
                 ATTXELISTS
         )
        )
  )
  (if (= "Yes" REV)
    (progn (setq ATTXELISTS (reverse ATTXELISTS))
           (mapcar '(lambda (1% 2%) (vla-put-textstring 2% 1%))
                   STLIST
                   ATTXELISTS
           )
    )
  )
  (princ "\nATCOUNT complete.")
  (princ)
)
;;;------------------------------------------------------------------------
;;;Add value to Dimension & keep it's prefix (use for tag drawing)
(defun C:DVAT (/ DOC DMVALA DMSS DMSSM DM DM2 XDM DMVAL DMVALA DMVALNEW DMLIST)
  (vl-load-com)
  (setq DOC (vla-get-activedocument (vlax-get-acad-object)))
  (setq DMVALA (dos_getreal "Dimension Add" "Add Value :" 1))
  (setq        DMSS  (ssget)
        DMSSM 0
  )
  (repeat (sslength DMSS)
    (setq DMLIST (cons (ssname DMSS DMSSM) DMLIST)
          DMSSM         (1+ DMSSM)
    )
  )
  (foreach DM2 DMLIST
    (if        (= "DIMENSION" (cdr (assoc 0 (entget DM2))))
      (setq DM DM2)
    )
    (setq XDM        (vlax-ename->vla-object DM)
          DMVAL        (vla-get-textoverride XDM)
          DMVP        (substr DMVAL 1 3)
          DMVS        (substr DMVAL 4 (strlen DMVAL))
          DMVSL        (strlen DMVS)
          DMVSN        (rtos (+ (atof DMVS) DMVALA) 2 0)
    )
    (if        (> DMVSL (strlen DMVSN))
      (repeat (- DMVSL (strlen DMVSN)) (setq DMVSN (strcat "0" DMVSN)))
    )
    (if        (/= (setq DMVALNEW (strcat DMVP DMVSN)) DMVAL)
      (progn (vla-put-textoverride XDM DMVALNEW) (redraw DM 4))
    )
  )
  (vlax-release-object DOC)
)
;;;------------------------------------------------------------------------
;;;Text Multify by Eric Wong
(defun C:DVMF (/ SS SSM SSN SS1 DDEC2 EG1 DVAL DVAL2 DVALA)
  (setq DVALA (dos_getreal "Multify Value" "Enter Value want to multify"))
  (princ "Select DIMENSION change to process :")
  (if (= DDEC NIL)
    (setq DDEC (getvar "DIMDEC"))
  )
  (setq        SS  (ssget '((-4 . "<OR")
                     (0 . "DIMENSION")
                     (0 . "*TEXT")
                     (0 . "INSERT")
                     (-4 . "OR>")
                    )
            )
        SSM (sslength SS)
        SSN 0
  ) ;SETQ
  (initget)
  ;(setq DDEC2 (getint (strcat "\nDecimal Place: <" (rtos DDEC 2 0) "> ")))
  (setq DDEC 0)
  (command ".UNDO" "BE")
  (repeat SSM
    (setq SS1        (ssname SS SSN)
          EG1        (entget SS1)
          ETYPE        (cdr (assoc 0 EG1))
          SSN        (1+ SSN)
    ) ;SETQ
  ;(IF (> DDEC 1)
    (cond ((= ETYPE "DIMENSION")
           (setq DVAL (atof (cdr (assoc 1 EG1))))
           (if (= DVAL 0.0)
             (setq DVAL2 (ai_rtos (* (cdr (assoc 42 EG1)) DVALA)))
             (setq DVAL2 (ai_rtos (* DVAL DVALA)))
           )
           (if (= (strlen DVAL2) 1)
             (setq DVAL2 (strcat "0" DVAL2))
           )
           (command ".DIM1" "NEW" DVAL2 SS1 "")
          )
          ((or (= ETYPE "TEXT") (= ETYPE "MTEXT"))
           (setq SV_DIMZIN (getvar "DIMZIN"))
           (setvar "DIMZIN" 5)
           (if (= (substr (cdr (assoc 1 EG1)) 1 2) "\\A")
             (setq DVAL
                    (atof (substr (cdr (assoc 1 EG1)) 5 (strlen (cdr (assoc 1 EG1))))
                    )
             )
             (setq DVAL (atof (cdr (assoc 1 EG1))))
           )
           (setq DVAL2 (ai_rtos (* DVAL DVALA)))
           (if (= (strlen DVAL2) 1)
             (setq DVAL2 (strcat "0" DVAL2))
           )
           (if (/= SV_DIMZIN NIL)
             (setvar "DIMZIN" SV_DIMZIN)
           )
           (setq EG2 (subst (cons 1 DVAL2) (assoc 1 EG1) EG1))
           (entmod EG2)
          )
          ((= ETYPE "INSERT")
           (setq XX 1)
           (while XX
             (setq EG1 (entget (entnext (cdr (assoc -1 EG1)))))
             (if (= (cdr (assoc 0 EG1)) "SEQEND")
               (setq XX NIL)
               (progn (setq DVAL  (atof (cdr (assoc 1 EG1)))
                            DVAL2 (ai_rtos (* DVAL DVALA))
                      )
                      (setq EG2 (subst (cons 1 DVAL2) (assoc 1 EG1) EG1))
                      (entmod EG2)
               ) ;progn
             ) ;if
           ) ;while
           (entupd SS1)
          )
    ) ;COND
  ) ;REPEAT
  (command ".UNDO" "END")
  (princ)
)
;;;------------------------------------------------------------------------
;;;Text New by Eric Wong
(defun C:TEXTNEW (/ CTEXT1 SS SSM SSN SS1 EG1 EG2 CT_HL ATTLIST EP1 EP2)
  (setq CT_HL (getvar "HIGHLIGHT"))
  (setvar "HIGHLIGHT" 1)
  (if (= NIL CTEXT)
    (setq CTEXT1 (dos_getstring "Text New" "Enter the new Text :"))
    (setq CTEXT1 (dos_getstring "Text New" "Enter the new Text :" CTEXT))
  )
  (if (/= CTEXT1 NIL)
    (setq CTEXT CTEXT1)
    (setq CTEXT1 CTEXT)
  )
  (princ "\nText is copied to :")
  (setq EP1 (entsel))
  (if (/= NIL EP1)
    (while (/= NIL EP1)
      (setq EG1 (entget (car EP1)))
      (cond ((or (wcmatch (cdr (assoc 0 EG1)) "*TEXT")
                 (= (cdr (assoc 0 EG1)) "DIMENSION")
             )
             (setq EG2 (subst (cons 1 CTEXT1) (assoc 1 EG1) EG1))
             (entmod EG2)
            )
            ((= (cdr (assoc 0 EG1)) "INSERT")
             (setq EG2 (car (nentselp (cadr EP1))))
             (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
               (vla-put-textstring (vlax-ename->vla-object EG2) CTEXT1)
               (progn (princ "\nNot match Attribute.") (exit))
             )
            )
      )
      (setq EP1 (entsel))
    )
    (progn
      (setq SS        (ssget)
            SSM        (sslength SS)
            SSN        0
      ) ;SETQ
      (repeat SSM
        (setq SS1      (ssname SS SSN)
              EG1      (entget SS1)
              ATTLIST  NIL
              ATTLIST2 NIL
              SSN      (1+ SSN)
        )
        (cond
          ((or (wcmatch (cdr (assoc 0 EG1)) "*TEXT")
               (= (cdr (assoc 0 EG1)) "DIMENSION")
           )
           (setq EG2 (subst (cons 1 CTEXT1) (assoc 1 EG1) EG1))
           (entmod EG2)
          )
          ((= (cdr (assoc 0 EG1)) "INSERT")
           (setq ATTLIST (vlax-safearray->list
                           (vlax-variant-value
                             (vla-getattributes (vlax-ename->vla-object SS1))
                           )
                         )
           )
           (if (= 1 (length ATTLIST))
             (vla-put-textstring (car ATTLIST) CTEXT1)
             (progn (if        (= NIL ESEL2)
                      (progn (princ "\nPlease Specify Attribute Tag :")
                             (setq ESEL2 (vla-get-tagstring
                                           (vlax-ename->vla-object (car (nentselp)))
                                         )
                             )
                      )
                    )
                    (setq ATTLIST2 (vl-remove-if-not
                                     '(lambda (X) (= ESEL2 (vla-get-tagstring X)))
                                     ATTLIST
                                   )
                    )
                    (if        (= NIL ATTLIST2)
                      (princ "\nNot match Attribute.")
                      (vla-put-textstring (car ATTLIST2) CTEXT1)
                    )
             )
           )
          )
        )
      ) ;repeat
    )
  ) ;if
  (setvar "HIGHLIGHT" CT_HL)
  (princ)
)
(defun c:ct() (c:ctext))
(defun c:ctm() (c:ctextm))
(defun c:ctr() (c:ctextr))
(defun c:tn() (c:textnew))

xtzw988

上面是一个插件代码，但是刷尺寸的时候只能刷文字代替里的内容，能变一下直接刷测量单位吗？

ccc230

2楼房写的好

尘缘一生

xtzw988 发表于 2015-9-24 11:34
;;COPY TEXT FROM ONE ENTITIES TO MANY
;;BY ERIC WONG
;;Modified at 05-07-2005 At Table support on  ...

有函数不全， DOS_GETREAL

guankuiwu

就替换个尺寸，码太长了吧

ly8zx2109

(vl-load-com)
(defun C:Cd (/ ed i ss val)                ;将尺寸值改为固定数值
  (setvar "cmdecho" 0)
  (setq
    ss
       (ssget "X"
              '(
                (0 . "DIMENSION")
                (1 . "")
               )
       )
    i  0
  )
  (if ss
    (progn
      (repeat (sslength ss)
        (setq
          ed  (vlax-ename->vla-object (ssname ss i))
          val (rtos (vla-get-Measurement ed) 2 0)
          i   (1+ i)
        )
        (vla-put-TextOverride ed val)
      )

    )
  )
  (if (= i 0)
    (princ "\n 未发现需要修改的标注！")
    (princ (strcat "\n 共修改了 " (rtos i 2 0) " 个标注！"))
  )
  (setvar "cmdecho" 1)
  (princ)
)