[编程交流] 单Att旋转

(defun c:atrot(/ blSet attLst errCount oldAng)
 (if(not atrot:rAng)(setq atrot:rAng 0))
 (setq oldAng atrot:rAng
       atrot:rAng
    (getangle
      (strcat "\nSpecify rotation angle <"(angtos atrot:rAng)">: ")))
 (if(not atrot:rAng)(setq atrot:rAng oldAng))
 (princ "<<< Select blocks to rotate attributes >>>")
 (setq errCount 0)
 (if
   (setq blSet(ssget '((0 . "INSERT")(66 . 1))))
   (progn
     (setq blSet(mapcar 'vlax-ename->vla-object 
                   (vl-remove-if 'listp 
                    (mapcar 'cadr(ssnamex blSet)))))
     (foreach itm blSet
   (setq attLst
          (vlax-safearray->list
        (vlax-variant-value
          (vla-GetAttributes itm))))
   (foreach att attLst
     (if(vl-catch-all-error-p
          (vl-catch-all-apply
            'vla-put-Rotation(list att atrot:rAng)))
       (setq errCount(1+ ErrCount))
         ); end if
     ); end foreach
   ); end foreach
     ); end progn
   (princ ">>> Nothing selected! <<<")
   ); end if
 (if(/= 0 errCount)
   (princ
     (strcat "\n>>> "
   (itoa errCount)
         " attributes or blocks were on locked layer! <<< "))
         ); end if
 (princ)
 ); end of c:atrot

;*  Variables ans   = given answer to what to change                     *;*            tmp   = temporary storage                                  *;*            alist = storage of separate selections (check list)        *;*            pt    = storage for point selections                       *;*            sset  = selection set storage ( check for entity )         *;*            cnt   = storage for counter vs. string length              *;*************************************************************************; (defun c:chatt    ( / cnt ans tmp alist pt sset value angle style layer color hgt pos)       (setq ans "")       (setq tmp " ")       (setq alist (list ""))       (While (/= tmp "")                           ; Continue if user                                                    ; gives us an answer.         (prompt "\nChange what?\nValue, Angle,")         (prompt " Style, Layer, Color, Height, Position:"); Long eh?         (if (> (strlen ans) 0)           (progn            (prompt "\nCurrent[")                   ; Display the current            (prompt ans)                            ; list if available.            (prompt "]:")           )         )         (setq tmp (strcase (substr (getstring) 1 1)))         (if (AND (or (= tmp "V")(= tmp "A")(= tmp "S")(= tmp "L")                      (= tmp "C")(= tmp "H")(= tmp "P"))                  (= nil (member tmp alist))              )                                     ; If the answer is in the           (progn                                   ; group and not in the             (setq ans(strcat ans tmp))              ; check list add it!            (setq alist (append alist (list tmp)))           )         )       )       (if (= ans "")(setq ans "VASLCHP"))          ; If the user doesn't       (setq cnt 1)                                 ; us an option force       (setq value nil)                             ; all of them!       (setq angle nil)       (setq style nil)                             ; Set all the variables       (setq layer nil)                             ; to nil!       (setq color nil)                             ; I'm not very trusting!       (setq hgt nil)       (setq pos nil)       (While (/= "" (setq tmp (substr ans cnt 1))) ; Check for options and                                                    ; get the values.         (if (= tmp "V")          (setq value (getstring "\nNew Value for attributes: "))         )         (if (= tmp "A")          (setq angle (* 180 (/ (getangle "\nNew angle for attributes: ")                        pi)))         )         (if (= tmp "S")          (setq style (getstring "\nNew style for attributes: "))         )         (if (= tmp "L")          (setq layer (getstring "\nNew layer for attributes: "))         )         (if (= tmp "C")          (setq color (getstring "\nNew color for attributes: "))         )         (if (= tmp "H")             (setq hgt (getdist "\nNew height for attributes: "))         )         (if (= tmp "P")(setq pos 1))         (setq cnt (+ cnt 1))       )       (setvar "cmdecho" 0)       (setq pt (getpoint "\nSelect Attribute: "))  ; As long as we get a       (while pt                                    ; point value!         (if  (setq sset (ssget pt))                ; Check for an entity!            (progn               (if (= nil (assoc 66 (entget (ssname sset 0))))                 (progn                             ; If it does not have                                                    ; Attributes worry!                   (prompt "\nNot An Attributed Block")                   (setq sset nil)                 )               )            )            (progn                                  ; If you dont find              (prompt "\nNo Entity Found")          ; an entity at the              (setq sset nil)                       ; given location            )                                       ; worry!         )        (if (and pt sset)         (progn                                     ; If all is well,         (command ".attedit" "" "" "" "" pt "" )    ; Start the ATTEDIT         (if value (command "v" "r" value))         ; function and do         (if angle (command "a" angle))             ; each one that was         (if style (command "s" style))             ; requested and         (if layer (command "l" layer))             ; that has a value.         (if color (command "c" color ))         (if hgt (command "h" hgt ))                ; If the position         (if pos                                    ; was requested,           (progn                                   ; give an additional             (Prompt "\n New Position: ")           ; prompt since we             (command "p" pause )                   ; turned off the           )                                        ; command echo!         )         (command "")                               ; Terminate the         )                                          ; command.        )        (setq pt (getpoint "\nSelect Attribute: ")) ; Get a new point!       ));/* End of File */