cad尺寸标注时自动添加文字替代
我想在标注尺寸的时候让文字替代里自动添加所标尺寸的内容，让尺寸值固定，拉伸尺寸的时候值不会变。有人能帮忙吗？;;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 ESEL2ENT ENTX SS
SSM SSN SS1 EG1 EG2 CT_HLATTLIST
EP1 EP2 ROWNOCOLNO
)
(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)))
ATTLISTNIL
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 COMBOLISTCOMBOLISTS
TXTLISTS TSS2 TSS2L TSS2N TXTENT2
TXTELIST2PTLIST2 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 COMBOLISTCOMBOLISTS
TXTLISTS TSS2 TSS2L TSS2N TXTENT2
TXTELIST2PTLIST2 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 :")
STIN(getstring
(strcat "\nSpecify starting number and increment (Start,increment) <"
STIN2
">:"
)
)
)
(initget 1 "Overwrite Prefix Suffix")
(setq PLACE (getkword
"\nPlacement of numbers in text :"
)
)
(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? <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)
ATTLISTNIL
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)) 上面是一个插件代码，但是刷尺寸的时候只能刷文字代替里的内容，能变一下直接刷测量单位吗？ 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 就替换个尺寸，码太长了吧 (vl-load-com)
(defun C:Cd (/ ed i ss val) ;将尺寸值改为固定数值
(setvar "cmdecho" 0)
(setq
ss
(ssget "X"
'(
(0 . "DIMENSION")
(1 . "")
)
)
i0
)
(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)
)
页:
[1]