[编程交流] VPLocker修改

(vl-load-com)
;;;--------------------------------------------------------------------;
;;; Viewport lock
(defun c:VPL () (c:ViewportLock))
(defun c:ViewportLock (/ option ss)
 (princ "\rVIEWPORTLOCK ")
 (_PutPViewportLockAndColor :vlax-true 4)
)
;;;--------------------------------------------------------------------;
;;; Viewport unlock
(defun c:VPU () (c:ViewportUnlock))
(defun c:ViewportUnlock (/ option ss)
 (princ "\rVIEWPORTUNLOCK ")
 (_PutPViewportLockAndColor :vlax-false 256)
)
;;;--------------------------------------------------------------------;
;;; Put PViewport Lock and Color
(defun _PutPViewportLockAndColor (lock color / *error* option ss acDoc)
 (defun *error* (msg)
   (if (and ss (= 'VLA-OBJECT (type ss)))
     (vla-delete ss)
   )      
   (if acDoc
     (vla-endundomark acDoc)
   )
   (cond ((not msg))                                                   ; Normal exit
         ((member msg '("Function cancelled" "quit / exit abort")))    ; <esc> or (quit)
         ((princ (strcat "\n** " msg " ** ")))
   )                                                                   ; Fatal error, display it
   (princ)
 )
 (if (and (not (initget "All Current"))
          (or (setq option
                     (getkword
                       "\nEnter layout(s) to modify [All/Current]<Current>: "
                     )
              )
              (setq option "Current")
          )
          (setq ss
                 (cond ((= "Current" option) (_GetPViewports nil))
                       ((_GetPViewports T))
                 )
          )
     )
   (progn
     (vla-startundomark
       (setq acDoc
              (vla-get-activedocument
                (vlax-get-acad-object)
              )
       )
     )
     (vlax-for x (setq ss (vla-get-activeselectionset acDoc))
       (vla-put-color x color)
       (if (vlax-property-available-p x 'displaylocked)
         (vla-put-displaylocked x lock)
       )
     )
     (if (= (vla-get-mspace acDoc) :vlax-true)
       (vla-regen acDoc acactiveviewport)
     )
     (setq ss (vla-delete ss))
     (*error* nil)
   )
   (if option
     (*error* "Command not allowed in Model Tab")
   )
 )
 (princ)
)
;;;--------------------------------------------------------------------;
;;; Get PViewports
(defun _GetPViewports (allTabs)
 (ssget
   "_x"
   (list
     '(-4 . "<OR")
     '(0 . "VIEWPORT")
     '(-4 . "<AND")
     '(0 . "LWPOLYLINE")
     '(102 . "{ACAD_REACTORS")
     '(-4 . "AND>")
     '(-4 . "OR>")
     (cons
       410
       (cond
         (allTabs
          (vl-string-right-trim
            ","
            (apply 'strcat
                   (mapcar '(lambda (x) (strcat x ",")) (layoutlist))
            )
          )
         )
         ((getvar 'ctab))
       )
     )
   )
 )
)