[编程交流] 具有文字替代的标注

;;------------------------------------------------
;; 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 [url="file://xx/"]\\xx[/url]; 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)
 (setq  FDim
    (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)
         )
       )
     )

(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) "*<>*"))

 (sssetfirst nil (ssget "_X" '((0 . "*DIMENSION") (-4 . ""))))

(defun c:OD (/ Fdim) (setq  FDim    (ssget      "_X"      '((0 . "*DIMENSION")        (-4 . "")        )      )   ) (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)         )       )     )