具有文字替代的标注
有没有办法通过LISP或直接在ACAD中的选项，强制所有具有替代值的维度显示为不同的颜色？我们解雇的一个人有一个坏习惯，就是只更改尺寸文本，而不是实际修复图形。如果能够点击一个按钮，看看它是否找到任何被覆盖的维度，那就太好了。 我以前有一个lisp，检查所有关联的DIM是否正确。。。。几年没用了。。。。可能仍然有效。看看我能不能找到。找到了。不能保证它仍然有效，但你可能会盗取代码;;------------------------------------------------
;; Programmer's Tool Box Feb 1996
;; CADENCE MAGAZING: Bill Kramer
;; Dimension Edits and Checking
;;
;;------------------------------------------------
;; LISTING 1:MAIN FUNCTION C:DIMCHK
;;------------------------------------------------
(defun C:DIMCHK ( / DIML ;dimension layer name
TOL ;tolerance value
SS1 ;selection set
II ;index into pick set
JJ ;index to distances
D1 ;distances list
D2 ;found flag
P1 P2 ;points of dim entity
TY TX ;type / text
XB ;text block of dim
XT ;text in text block
VAL ;value of dim text
EL EN);entity list and name
(prompt
"\nDIMCHK: Check associative dimension values")
(while (null DIML)
(setq DIML
(getstring
"\nLayer name for dimensions: "))
(if (or (= DIML "")
(null (tblsearch "LAYER" DIML)))
(setq DIML ;;nil
(prompt "\nLayer does not exist!"))
)
)
(setq TOL
(getdist "\nEnter tolerance <0.001>: "))
(if (null TOL) (setq TOL 0.001))
(setvar "CMDECHO" 0)
(if (null (tblsearch "LAYER" "DIM_BAD"))
(command "_LAYER"
"_N" "DIM_BAD,DIM_OUTTOL"
"_C" "YELLOW" "DIM_OUTTOL"
"_C" "RED" "DIM_BAD"
"")
)
(setq SS1 (ssget "X" (list (cons 8 DIML))))
(if SS1
(progn
(setq II 0)
(repeat (sslength SS1)
(if (GET_DIM_DATA) (progn
(setq JJ 1
D2 nil)
(if (DIM_VALUES) (DIM_VALUE_CHECK))
(redraw EN)
) (prompt " unable to translate text."))
);;end REPEAT
)
(prompt "\nNothing found!")
)
(princ)
)
;;------------------------------------------------
;; Listing 2: Retrieve entity information into
;; global variables used by remainder of function
;; set.
;;
(defun GET_DIM_DATA ()
(setq EN (ssname SS1 II)
II (1+ II)
EL (entget EN)
)
(redraw EN -3)
(cond
((= (cdr (assoc 0 EL)) "DIMENSION")
(setq P10 (cdr (assoc 10 EL))
P13 (cdr (assoc 13 EL))
P14 (cdr (assoc 14 EL))
P15 (cdr (assoc 15 EL))
TY (cdr (assoc 70 EL));;type
TX (cdr (assoc 1 EL)) ;;text
XB (cdr (assoc 2 EL)) ;;block name
XT (BLOCK_TEXT XB) ;;text in block
)
;;check to see if dimension location flag
;;is set. Remove if found.
(if (> TY 70) (setq TY (- TY 128)))
;;
(if (or
(= TX "") ;;nothing in text or
(wcmatch TX "*<>*")) ;;variable
(progn;;then look in block
(prompt "\nAssociative dim,")
(setq VAL XT)
)
(progn ;;else look in text
(prompt "\nAssoc w/ text override,")
(setq VAL TX)
)
)
;;Convert VAL to distance value
(setq VAL
(distof
(Convert_Mtext_Dim VAL)))
)
(t
(prompt
"\nNon-associative dimension object: ")
(prompt (cdr (assoc 0 EL)))
)
)
)
;;------------------------------------------------
;; Listing 3:Calculate dim distances
;;
(defun DIM_VALUES ( / TYP)
(setq TYP (logand TY 7))
(cond
((zerop TYP) ;;vert/hor
(prompt " VER|HOR")
(setq D1
(list
(abs (- (car P13) (car P14)))
(abs (- (cadr P13) (cadr P14)))
(distance P13 P14)
)
)
)
((= 4 TYP) ;;radius
(prompt " RAD")
(setq D1
(list
(distance P10 P15)
)
)
)
((= 3 TYP) ;;diameter
(prompt " DIA")
(setq D1
(list
(distance P10 P15)
)
)
)
((= 1 TYP) ;;aligned
(prompt " ALI")
(setq D1
(list
(distance P13 P14)
)
)
)
((= 2 TYP) ;;angular
(prompt " ANG, not checked.")
(setq D1 nil)
)
(t
(prompt " dim check not available.")
(setq D1 nil) ;;ignored
)
);;end COND
)
;;------------------------------------------------
;; Listing 4:test dimension against tolerance
;;
(defun DIM_VALUE_CHECK ()
(foreach DD D1
(cond
((equal DD VAL (/ TOL 10.0))
(setq D2 JJ))
((and (null D2) (equal DD VAL TOL))
(setq D2 (* -1 JJ)))
)
(setq JJ (1+ JJ))
)
(if D2 ;;found something
(if (minusp D2)
(progn
(prompt
", YELLOW: not exact, within tol.")
(entmod
(subst
(cons 8 "DIM_OUTTOL")
(assoc 8 EL)
EL))
);end PROGN
(prompt ", exact or <= 10% tol. accepted.")
)
(progn ;;nothing close
(prompt ", RED: outside tolerance.")
(entmod
(subst
(cons 8 "DIM_BAD")
(assoc 8 EL)
EL))
)
)
)
;;------------------------------------------------
;; Listing 5:return text value from block
;; definition entities.
;;
(defun BLOCK_TEXT (NM / EL EN)
(setq EL (tblsearch "BLOCK" NM))
(if EL (progn
(setq EN (cdr (assoc -2 EL))
EL (entget EN)
)
(while
(and EN
(not (or
(= "MTEXT" (cdr (assoc 0 EL)))
(= "TEXT" (cdr (assoc 0 EL))))))
(setq EN (entnext EN))
(if EN (setq EL (entget EN)))
)
(if EN
(cdr (assoc 1 EL))
)
))
)
;;------------------------------------------------
;; Listing 6: Convert MTEXT dimension value
;; number, seek out the real number information
;; bypassing all \\xx; type stuff and looking
;; inside { } brackets
;;
(defun CONVERT_MTEXT_DIM (TX / RES CH Skip)
(setq RES "")
(while (> (strlen TX) 0)
(setq CH (substr TX 1 1)
TX (substr TX 2)
)
(cond
((= CH "\\") ;;start of control sequence
(setq CH (substr TX 1 1))
(cond
((= CH "U") ;;unicode skip over
(setq TX (substr TX 7)
CH "")
)
((member CH;;control character?
'("e" "n" "r" "t"))
(setq TX (substr TX 2)
CH "")
)
((member CH;;octal number?
'("0" "1" "2" "3" "4" "5" "6" "7"))
(setq TX (substr TX 4)
CH "")
)
(t
(setq Skip 'T) ;;other command
)
)
)
((= CH "}");;end of paragraph
(setq Skip 'T)
(if (distof RES)
(setq TX "")
(setq RES "")
)
)
((= CH "%") ;;control character?
(if (= (substr TX 1 1) "%")
(setq TX (substr TX 2)
CH "")
)
)
((= CH "R") ;;radius marker?
(setq CH "") ;;gamble it is
)
)
;;
(if (and (null Skip) (< (ascii CH) 128))
(setq RES (strcat RES CH)))
;;
(cond
((= CH ";");;end of control sequence
(setq Skip nil)
)
((= CH "{");;start of paragraph
(setq Skip nil)
)
)
)
RES
)
;;-----------------------------------------------EOF
(sssetfirst nil (ssget "_X" '((0 . "*DIMENSION") (-4 . "<OR") (1 . "*?*") (-3 ("ACAD")) (-4 . "OR>"))))
对于这两种类型：
(defun c:OD (/ Fdim)
(setqFDim
(ssget
"_X"
'((0 . "*DIMENSION")
(-4 . "<OR")
(1 . "*?*")
(-3 ("ACAD"))
(-4 . "OR>")
)
)
)
(repeat (sslength FDim)
(vla-put-TextColor
(vlax-ename->vla-object (ssname Fdim 0))
5
)
(ssdel (ssname Fdim 0) Fdim)
)
) 只需突出显示具有覆盖的内容：
(defun c:OD (/ Fdim)
(vl-load-com)
(setq aDoc
(vla-get-ActiveDocument (vlax-get-acad-object)) clr 5)
(if (ssget "_X" '((0 . "*DIMENSION")))
(progn
(vlax-for
itm (setq
fdim
(vla-get-ActiveSelectionSet
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(if (not (eq (vla-get-TextOverride itm) ""))
(vla-put-TextColor itm clr)
)
)
(vla-delete fdim)
)
)
)
M、 R。
(defun c:chkdims ( / ss ssn ent entA )
(vl-load-com)
(setq ss (ssget "_X" '((0 . "*DIMENSION")) ))
(repeat (setq ssn (sslength ss))
(setq ent (ssname ss (setq ssn (1- ssn))))
(setq entA (vlax-ename->vla-object ent))
(if (or (= "" (vla-get-textoverride entA)) (wcmatch (vla-get-textoverride entA) "*<>*"))
(redraw ent 1)
(redraw ent 3)
)
)
(princ)
)
接得好，先生。
(wcmatch (vla-get-textoverride entA) "*<>*"))
你明白了
you? or the culprit Here is one that does what you are looking for
http://autocadtips.wordpress.com/2011/10/27/autolisp-find-dodgy-dimensions/
Here is another that might be a little too much but is still usefull
http://autocadtips.wordpress.com/2011/10/27/autolisp-dodgy-dimension-detector/ Non Annotative dimensions:
(sssetfirst nil (ssget "_X" '((0 . "*DIMENSION") (-4 . ""))))
(defun c:OD (/ Fdim) (setqFDim (ssget "_X" '((0 . "*DIMENSION") (-4 . "") ) ) ) (repeat (sslength FDim) (vla-put-TextColor (vlax-ename->vla-object (ssname Fdim 0)) 5 ) (ssdel (ssname Fdim 0) Fdim) ) )
For Both types:
(defun c:OD (/ Fdim) (vl-load-com) (setq aDoc (vla-get-ActiveDocument (vlax-get-acad-object)) clr 5) (if (ssget "_X" '((0 . "*DIMENSION"))) (progn (vlax-for itm (setq fdim (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)) ) ) (if (not (eq (vla-get-TextOverride itm) "")) (vla-put-TextColor itm clr) ) ) (vla-delete fdim) ) ) )
页:
[1]
2