[LISP函数]：Make the attributes fit

aidraft

[php]
;;; Attributes_fit.lsp
;;; Author : Alvin Lin 16/7/04
;;;
;;; This routine will insert a block with a single attribute in current drawing.
;;; Xdata is attached to the attribute so the text string should has ;;; a maximum length
;;; A simple command reactor is set up to trace the "EATTEDIT" ;;;command ended.
;;; When "EATTEDIT" command ends, it triggers the CAll_BACK function (WHATNEXT),
;;; which will finally call (CHECKFIT) to check the attributes fitness throughout
;;; the modelspace of current drawing.
;;---------------------------------------------------------------------------------------
(defun c:test  (/ ss ts ts0 old_osMode old_cmdEcho en InsPt value blkobj txthgt)
  (setq ts (if (= (setq txthgt (vla-get-height
                                 (vla-get-activeTextStyle
                                   (vla-get-ActiveDocument
                                     (vlax-get-acad-object)
                                     )
                                   )
                                 )
                        )
                  0
                  )
             (getvar "TEXTSIZE")
             txthgt
             )
        )
  (setq ts0         (/ ts 5.0)
        old_osMode  (getvar "OSMODE")
        old_cmdEcho (getvar "CMDECHO")
        ss          (ssadd)
        )
  (setvar "OSMODE" 0)
  (setvar "CMDECHO" 0)
  (if (not (tblsearch "BLOCK" "testblk"))
    (progn
      (if
        (vl-cmdf
          "rectangle"
          '(0 0)
          (strcat "@"
                  (rtos (* ts0 60) 2 2)
                  ","
                  (rtos (* ts0 7) 2 2)
                  )
          )
         (setq ss (ssadd (entlast) ss))
         )

      (vl-cmdf "text"
               (strcat (rtos ts0 2 2) "," (rtos ts0 2 2))
               )

      (if (= txthgt 0)
        (vl-cmdf ts)
        )
      (if (vl-cmdf 0
                   "NAME:"
                   )
        (setq ss (ssadd (entlast) ss))
        )
      (vl-cmdf "-attdef"
               ""
               "NAME"
               "Input name"
               ""
               (strcat (rtos (* ts0 24) 2 2)
                       ","
                       (rtos ts0 2 2)
                       )
               )
      (if (= txthgt 0)
        (vl-cmdf ts)
        )
      (if (vl-cmdf "" 0)
        (progn
          (setq en (entlast))
          (x_data_add
            en
            "TEXTLENGTH"
            (list (cons 1040 (* ts0 35)))
            )
          (setq ss (ssadd en ss))
          )
        )
      (vl-cmdf "-block" "testblk" '(0 0 0) ss "")
      )
    (vl-cmdf "erase" ss "")
    )
  (setq IntPt (getpoint "\nInsertion point: ")
        value (getstring "\nInput name: " t)
        )
  (if (vl-cmdf "-insert" "testblk" IntPt 1 1 0 value)
    (progn
      (setq blkobj (vlax-ename->vla-object (entlast)))
      (Check_Textfit blkobj)
      )
    )
  (VLR-REMOVE-ALL)
  (VLR-COMMAND-REACTOR NIL '((:VLR-COMMANDENDED . WHATNEXT)))
  (setvar "OSMODE" old_osmode)
  (setvar "CMDECHO" old_cmdEcho)
  (princ)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFUN WHATNEXT  (REFOBJ CMDLIST)
  (IF (APPLY 'OR
             (MAPCAR '(LAMBDA (X) (WCMATCH X "*EATTEDIT")) CMDLIST)
             )
    (CHECKFIT)
    )
  (PRINC)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Checkfit  (/ MSPACE)
  (SETQ MSPACE (VLA-GET-MODELSPACE
                 (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))
                 )
        )
  (VLAX-FOR OBJ  MSPACE
    (IF
      (and (= (VLA-GET-OBJECTNAME OBJ) "AcDbBlockReference")
           (= (VLA-GET-HASATTRIBUTES OBJ)
              :VLAX-TRUE
              )
           )
       (Check_Textfit OBJ)
       )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Check_Textfit  (blkobj / atts LL UR len len0)
  (setq atts (vlax-safearray->list
               (vlax-variant-value (vla-GetAttributes blkobj))
               )
        )
  (foreach att  atts
    (vla-put-Scalefactor att 1.0)
    (vla-GetBoundingBox att 'LL 'UR)
    (setq LL (vlax-safearray->list LL)
          UR (vlax-safearray->list UR)
          )
    (setq len (abs (- (car LL) (car UR))))

    (IF (SETQ TMP
               (x_data_get (vlax-vla-object->ename att) "TEXTLENGTH")
              )
      (PROGN
        (setq len0 (cdar TMP))
        (if (> len len0)
          (vla-put-Scalefactor att (/ len0 len))
          )
        )
      )
    )
  )
;;;;Written by Bill Kramer
(DEFUN X_DATA_ADD  (EN APID DLST / EL TMP1)
  (REGAPP APID)
  (SETQ EL   (ENTGET EN)
        TMP1 (LIST -3 (CONS APID DLST))
        )
  (IF (< (XDSIZE TMP1) (XDROOM EN))
    (ENTMOD (APPEND EL (LIST TMP1)))
    )
  )
;;;
(DEFUN X_DATA_GET  (EN APID / EL)
  (SETQ EL (ENTGET EN (LIST APID)))
  (IF (ASSOC -3 EL)
    (CDADR (ASSOC -3 EL))
    )
  )
[/php]