Приёмы ускорения работы в AutoCAD (Страница 8 из 9)

;_ Редакция 11.05.2009 
;;; By Vladimir Azarko (VVA)
;;; Comments and bug reports may be sent to azarko@yandex.ru
;;; Idea get from Tip1381.LSP:  QUICKDRAW.LSP   Quickly draw another   ©1997, Rory Love
;;; Published https://www.caduser.ru/forum/topic9651.html
;;; The command, "QUIKDRAW", will begin the AutoCAD 
;;; command to draw a similar entity that the user is 
;;; prompted to select. 
;;; Before the command begins, the layer, color, & 
;;; linetype properties will be set current, and if applicable,
;;; other options (e.g. style, scale, width, etc.)
;;; will  be preset before the AutoCAD command is executed.
;;; Short name command - Q and QR (Quickdraw restore)
;;; If you type QR, after the command the layer, color, 
;;; linetype and lineweight properties restore back
(vl-load-com) 
(defun QMAKE_CMD ( ENT RS FUN )
  (setq *QDRAWITEM* ENT)
  (eval (read
    (strcat
      "(defun C:QDR ( / EL RS FUN)"
      (if RS "(setq RS t)" "(setq RS nil)")
      "(if (and *QDRAWITEM* (entget *QDRAWITEM*))"
      "(progn(PROPS *QDRAWITEM*)(CMDSTARTREACT RS)("
      FUN "))))")))
  (vla-sendcommand *QDADOC* (strcat "QDR" "\n"))
  )
(defun RESTOREPROPS () 
(mapcar '(lambda(x y)(setvar x y)) 
'("clayer" "cecolor" "celtype" "celweight") 
*QDPREVPROPS*)(setq  *QDPREVPROPS* nil)(princ)) 
(defun PROPS ( EL / COLOR LTYPE)
  (setq EL (entget EL))
  (setq *QDPREVPROPS* 
    (list (getvar "clayer")(getvar "cecolor") 
          (getvar "celtype")(getvar "celweight") 
          ) 
   ) 
  (setvar "clayer" (FLDVAL 8 EL)) 
  (setvar "cecolor" 
    (if (setq COLOR (FLDVAL 62 EL)) 
      (itoa COLOR) "bylayer"))
  (setvar  "celtype" 
    (if (setq LTYPE (FLDVAL 6 EL)) 
      LTYPE "bylayer" ))
  (setvar "celweight" 
    (if (setq LTYPE (FLDVAL 370 EL)) 
      LTYPE  -1 ))
) ;_ end of defun
;;; Universal command
(defun XCOMMAND ( CMD )
  (setq CMD (VL-PRINC-TO-STRING CMD))
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD))
(defun XELLIPSE ( / EL IsFullEllipse CMD)
 (setq EL (entget *QDRAWITEM*)
       IsFullEllipse
    (and (zerop (FLDVAL 41 EL)) 
          (equal (FLDVAL 42 EL) (* 2 PI) 1e-9) 
          )
       )
    ;;IsFullEllipse - t - ellipse nil -arc 
  (setq CMD "_.ELLIPSE") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (if IsFullEllipse (command CMD)
    (command CMD "_ARC") 
    ) 
) ;_ end of defun
(defun XINSERT (/ CMD NAME XSIZE YSIZE ANG blk DynPropList)
  (setq EL (entget *QDRAWITEM*))
  (setq    CMD   "_INSERT"
    blk   (vlax-ename->vla-object *QDRAWITEM*)
    NAME  (cond
        ((and (vlax-property-available-p blk 'isdynamicblock)
              (= (vla-get-isdynamicblock blk) :vlax-true)
         ) ;_ end of and
         (setq DynPropList (GetDynamicBlockPropertyList blk))
         (vla-get-effectivename blk)
        )
        (t (vla-get-name blk))
          ) ;_ end of cond 
    XSIZE (FLDVAL 41 EL)
    YSIZE (FLDVAL 42 EL)
    ANG   (FLDVAL 50 EL)
  ) ;_ end of setq 
  (prompt (strcat "\nCommand: " CMD " " NAME))
  (command CMD NAME "_X" XSIZE
    "_Y" YSIZE "_R" (angtos ANG)) ;_ end of command
  (while (> (getvar "CMDACTIVE") 0) (command pause))
  (if (and (setq blk (vlax-ename->vla-object (entlast)))
       (vlax-property-available-p blk 'isdynamicblock)
       (= (vla-get-isdynamicblock blk) :vlax-true)
      ) ;_ end of and 
    (progn
      (setq NAME (GetDynamicBlockPropertyList blk))
      (foreach item NAME
    (if (setq ANG (assoc (car item) DynPropList))
      (vl-catch-all-apply
        '(lambda ()
           (vla-Put-Value (nth 2 item) (nth 1 Ang))
         )
      )
    )
      )
    )
  )
  (princ)
) ;_ end of defun 
(defun XPLINE (  / EL CMD WHAT)
 (setq EL (entget *QDRAWITEM*))
(initget "Pline REctang R3P") 
(setq WHAT (getpoint "\nPick a first point of polyline or [Pline/REctang/R3P] <Pline> :")) 
(cond ((= WHAT "REctang") 
       (setq CMD "_.RECTANG") 
       (prompt (strcat "\nCommand: " CMD " ")) 
       (command CMD "_W"  (FLDVAL 40 EL))) 
      ((= WHAT "R3P") 
       (prompt (strcat "\nCommand: R3P")) 
       (C:R3P)) 
      ((and WHAT (listp WHAT)) 
       (setq CMD "_.PLINE") 
       (setvar "PLINEWID" (FLDVAL 40 EL)) 
       (command CMD WHAT)) 
      (t (setq CMD "_.PLINE") 
       (setvar "PLINEWID" (FLDVAL 40 EL)) 
       (command CMD))) 
) ;_ end of defun 
(defun XDIM ( / EL CMD WHAT)
(setq EL (entget *QDRAWITEM*))
(cond ((member '(100 . "AcDbRotatedDimension") EL) 
       (setq CMD "_.DIMLINEAR")) 
      ((member '(100 . "AcDbAlignedDimension") EL) 
       (setq CMD "_.DIMALIGNED")) 
      ((member '(100 . "AcDbArcDimension") EL) 
       (setq CMD "_.DIMARC")) 
      ((or
     (member '(100 . "AcDb3PointAngularDimension") EL)
     (member '(100 . "AcDb2LineAngularDimension") EL)) 
       (setq CMD "_.DIMANGULAR")) 
      ((member '(100 . "AcDbDiametricDimension") EL) 
       (setq CMD "_.DIMDIAMETER")) 
      ((member '(100 . "AcDbRadialDimension") EL) 
       (setq CMD "_.DIMRADIUS")) 
      ((member '(100 . "AcDbOrdinateDimension")  EL) 
       (setq CMD "_.DIMORDINATE")) 
      (t (setq CMD "_.DIMLINEAR")) 
  )
(prompt (strcat "\nCommand: " CMD " ")) 
(sssetfirst nil nil) 
(while (> (getvar "CMDACTIVE") 0)(command))
(setq *QDDIMNAME* (VL-STRING-TRIM "_. \t\n" CMD))
(command  "_.DIMSTYLE" "_R" (FLDVAL 3 EL)) 
;;; Valery Brelovsky 
;;; (GRAPHSCR)   
(command CMD) 
) 
(defun XHATCH ( / EL CMD)
(setq EL (entget *QDRAWITEM*) CMD "_.BHATCH")
(if (FLDVAL 52 EL)(setvar "HPANG" (FLDVAL 52 EL))) 
(if (FLDVAL 41 EL)(setvar "HPSCALE" (FLDVAL 41 EL))) 
(setvar "HPNAME" (FLDVAL 2 EL)) 
(prompt (strcat "\nCommand: " CMD " "))
(vla-sendcommand *QDADOC* "_.BHATCH\n") 
;;(command CMD) 
) 
(defun XSHAPE ( / EL CMD NAME SCALE) 
  (setq EL (entget *QDRAWITEM*)
        CMD   "_shape" 
        NAME  (FLDVAL 2 EL) 
        SCALE (FLDVAL 40 EL) 
  ) ;_ end of setq 
  (prompt 
    (strcat "\nCommand: " CMD 
      " " NAME  " Starting point: ")
  ) ;_ end of prompt 
  (command CMD NAME PAUSE SCALE) 
) ;_ end of defun 
(defun XTEXT ( / EL CMD NAME CODE72 CODE73 JUSTIFY) 
  (setq EL (entget *QDRAWITEM*)
        CMD    "_dtext" 
        NAME   (FLDVAL 7 EL) 
        CODE72 (FLDVAL 72 EL) 
        CODE73 (FLDVAL 73 EL) 
  ) ;_ end of setq 
  (setq JUSTIFY 
         (cond ((= 0 CODE72) "_L") 
               ((= 1 CODE72) "_C") 
               ((= 2 CODE72) "_R") 
               ((= 3 CODE72) "_A") 
               ((= 4 CODE72) "_M") 
               ((= 5 CODE72) "_F") 
         ) ;_ end of cond 
  ) ;_ end of setq 
  (setq JUSTIFY 
         (strcat 
           (cond ((= 1 CODE73) "_B") 
                 ((= 2 CODE73) "_M") 
                 ((= 3 CODE73) "_T") 
                 (t "") 
           ) ;_ end of cond 
           JUSTIFY 
         ) ;_ end of strcat 
  ) ;_ end of setq 
  (setvar "TEXTSIZE" (FLDVAL 40 EL)) 
  (prompt 
    (strcat "\nCommand: " CMD " Style " NAME " ") 
  ) ;_ end of prompt 
  (if (and (zerop CODE72) (zerop CODE73)) 
    (command CMD "_S" NAME) 
    (command CMD "_S" NAME JUSTIFY) 
  ) ;_ end of if 
) ;_ end of defun 
(defun XTRACE ( / EL CMD WID) 
  (setq EL (entget *QDRAWITEM*)
        CMD "_trace" 
        WID (distance (FLDVAL 10 EL) (FLDVAL 11 EL)) 
  ) ;_ end of setq 
  (prompt (strcat "\nCommand: " CMD "")) 
  (command CMD WID) 
) ;_ end of defun 
(defun XVPORT ( / ENT CMD PT PT1 PT2 VP1)
  (setq ENT *QDRAWITEM*)
  (initget "Clip") 
  (setq CMD "_.mview" 
        PT  (getpoint 
              (strcat "\nCommand: " CMD " Pick first point or [Clip select viewport] <Clip>: ") 
            ) ;_ end of getpoint 
  ) ;_ end of setq 
  (cond 
    ((and PT (listp PT))(command CMD PT)) 
    (t 
     (vl-load-com) 
     (if (vlax-write-enabled-p (vlax-ename->vla-object ENT)) 
       (progn 
    (setvar "CMDECHO" 0) 
    (and 
      (setq PT1 (getpoint "\nFirst point clipped rectangle <exit>: ")) 
      (setq PT2 (getcorner PT1 "\nSecond point clipped rectangle <exit>: ")) 
      (vl-cmdf "_.COPY" ENT "" "_non" "@" "_non"  "@" "") 
      (setq VP1 (entlast)) 
      (vl-cmdf "_.Rectang" "_non" PT1 "_non" PT2) 
      (setq PT nil PT (entlast)) 
      (or (command)(command) t) 
      (or (vl-cmdf "_.VPCLIP" VP1 "_D") t) 
      (or (command)(command) t) 
      (vl-cmdf "_.VPCLIP"  VP1  PT) 
      (or (command)(command) t) 
      (vl-cmdf "_.VPCLIP" VP1 "_D") 
      (or (command)(command) t) 
      (setvar "CMDECHO" 1) 
      (vl-cmdf "_.MOVE" VP1 "" (polar PT1 (angle PT1 PT2)(* 0.5 (distance PT1 PT2)))) 
      ) 
    ) 
       (alert "VIEWPORT on locket layer") 
       ) 
     ) 
    ) 
) ;_ end of defun 
(defun C:R3P ( / *error* pt1 pt2 pt1W pt2W ucs ucf isRus) 
  (vl-load-com) 
  (defun *error* (msg)(princ msg) 
    (if ucs 
    (progn 
      (command "_.UCS" "_R" "TmpUcs") 
      (command "_.UCS" "_D" "TmpUcs") 
      ) 
    ) 
    (setvar "UCSFOLLOW" ucf)(vla-endundomark *QDADOC*) 
    (princ)) ;_ end of defun 
(vl-load-com) 
(or *QDADOC* (setq *QDADOC* (vla-get-activedocument (vlax-get-acad-object)))) 
(setvar "CMDECHO" 0)(setvar "EXPERT" 5) 
(vla-endundomark *QDADOC*)   
(vla-startundomark *QDADOC*) 
(command "_.UCS" "_Save" "TmpUcs") 
  (setq isRus (= (getvar "DWGCODEPAGE") "ANSI_1251") 
          ucf (getvar "UCSFOLLOW")) 
  (setvar "UCSFOLLOW" 0) 
  (initget 1) 
  (setq pt1 (getpoint 
              (if isRus 
                "\nПервая точка прямоугольника:" 
                "\nThe first point of a rectangular:" 
              ) ;_ end of if 
            ) ;_ end of getpoint 
  ) ;_ end of setq 
  (setq pt1W (trans pt1 1 0)) 
  (initget 1 "Angle Угол _Angle Angle") 
  (setq pt2 (getpoint pt1 
                      (if isRus 
                        "\nВторая точка прямоугольника [Угол]:" 
                        "\nThe second point of a rectangular [Angle]:" 
                      ) ;_ end of if 
            ) ;_ end of getpoint 
  ) ;_ end of setq 
  (if (= pt2 "Angle") 
    (progn 
      (if (null (setq pt2 (getangle 
                            (if isRus 
                              "\nУкажите угол <0>: " 
                              "\nEnter new angle <0>: " 
                              ) ;_ end of if 
                            ) 
                      ) 
                ) 
        (setq pt2 0) 
        ) 
      (setq ucs (vl-cmdf "_.UCS" 
                     "_N" 
                     "_3" 
                     "_non" pt1 
                     "_non" (setq pt2 (polar pt1 pt2 10)) 
                     "_non" (polar pt2 (+ (angle pt1 pt2) (* 0.5 PI)) 10) 
            ) ;_ end of vl-cmdf 
  ) ;_ end of setq 
        (setvar "orthomode" 1) 
        (initget 1) 
        (setq pt2 (getpoint (setq pt1 (trans pt1W 0 1)) 
                      (if isRus 
                        "\nВторая точка прямоугольника:" 
                        "\nThe second point of a rectangular:" 
                      ) ;_ end of if 
            ) ;_ end of getpoint 
  ) ;_ end of setq 
      );_progn 
      ) 
  (setq pt1W (trans pt1 1 0) 
        pt2W (trans pt2 1 0)) 
  (setq ucs (vl-cmdf "_.UCS" 
                     "_N" 
                     "_3" 
                     "_non" pt1 
                     "_non" pt2 
                     "_non" (polar pt2 (+ (angle pt1 pt2) (* 0.5 PI)) 10) 
            ) ;_ end of vl-cmdf 
  ) ;_ end of setq 
    (setvar "CMDECHO" 1) 
  (command "_.RECTANGLE" 
           "_non" (trans pt1W 0 1) 
           ".X" 
           "_non"  (trans pt2W 0 1) 
  ) ;_ end of command 
  (while (> (getvar "CMDACTIVE") 0)(command pause)) 
  (if ucs 
    (progn 
      (command "_.UCS" "_R" "TmpUcs") 
      (command "_.UCS" "_D" "TmpUcs") 
      ) 
    ) ;_ end of if 
(setvar "UCSFOLLOW" ucf) 
(vla-endundomark *QDADOC*) 
 (princ) 
) 
;;Возвращает список всех свойст динамического блока в виде списка 
;((Имя_свойства Текущее_значение Vla_объект_свойства)...) 
;; obj - Vla-указатель дин блока (vla-object) 
;;Пример 
;;(GetDynamicBlockPropertyList (vlax-ename->vla-object(car(entsel "\nВыбeри дин блок:")))) 
;;(("Видимость" "Канализация" #<VLA-OBJECT IAcadDynamicBlockReferenceProperty 15246fe4>) 
;;   ("Угол" 0.115395 #<VLA-OBJECT IAcadDynamicBlockReferenceProperty 15240fe4>) ...) 
(defun GetDynamicBlockPropertyList (obj / lstProperties) 
(if (and (vlax-property-available-p obj "IsDynamicBlock") 
          (= (vla-get-IsDynamicBlock obj) :vlax-true) 
          (setq lstProperties (vlax-safearray->list 
                                           (variant-value 
                                            (vla-GetDynamicBlockProperties obj))))) 
  (progn 
   (mapcar '(lambda (x)(list (vla-get-propertyname X) 
                             (variant-value (vla-get-value X)) 
                             x 
                             )) 
           lstProperties)))) 

;;; ------------- [FLDVAL] 
;;; This sub-routine is called by other 
;;; functions/commands and requires an integer 
;;; argument,(code), and an entity 
;;; list 
;;; argument, (elst).  The function will return the 
;;; value associated with "CODE" in 
;;; "ELST". 
(defun FLDVAL (CODE ELST) (cdr (assoc CODE ELST))) 
(defun CMDSTARTREACT ( RS ) 
  (if RS (progn 
  (if (not *QUICKDRAWCMDREACT*) 
     (setq *QUICKDRAWCMDREACT* (vlr-editor-reactor nil 
             '( 
               (:vlr-commandEnded . CMDWAIGHTREACT) 
               (:vlr-commandCancelled . CMDWAIGHTREACT) 
               (:vlr-commandFailed . CMDWAIGHTREACT) 
               ) 
             ) 
      ) 
  ) 
  (if (and (= (type *QUICKDRAWCMDREACT*) 'VLR-Editor-Reactor ) 
      (not (vlr-added-p *QUICKDRAWCMDREACT*)) 
      ) 
    (vlr-add *QUICKDRAWCMDREACT*) 
    ) 
    ));_ IF RS 
  ) 
(defun CMDWAIGHTREACT (objCall lstCallback)
  (if (or (null *QDDIMNAME*)
      (member *QDDIMNAME* lstCallback))
    (progn
      (RESTOREPROPS)
      (if (vlr-added-p objCall)(vlr-remove objCall))
      (vla-endundomark *QDADOC*)
      (setq *QDDIMNAME* nil)
      )
    )
  ) 
(defun 
     QUICKDRAW ( RS / ENT EL *ERROR*) 
  ;;; RS - restore settings 
  ;;;     t - restore 
  ;;;     nil - not 
  (defun *ERROR* (MSG) 
  (princ MSG) 
  (if RS (RESTOREPROPS)) 
  (vla-endundomark *QDADOC*) 
  (princ) 
) ;_ end of defun 
(vl-load-com) 
(or *QDADOC* 
    (setq *QDADOC* (vla-get-activedocument (vlax-get-acad-object))) 
    ) 
(vla-endundomark *QDADOC*) 
(vla-startundomark *QDADOC*) 
(setvar "CMDECHO" 1) 
(setq ent (cadr(ssgetfirst))) 
(if ent 
    (setq ent (ssname ent 0)) 
    (setq ENT (car (entsel "\nSelect object: "))))   
(if ENT 
    (progn 
      (setq EL (entget ENT)) 
      (cond ((= "ARC" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XCOMMAND \"_.ARC\""))
            ((= "CIRCLE" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XCOMMAND \"_.CIRCLE\""))
            ((= "LINE" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XCOMMAND \"_.LINE\""))
            ((= "POINT" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XCOMMAND \"_.POINT\""))
        ((and (= "POLYLINE" (FLDVAL 0 EL))(= 8 (FLDVAL 70 EL)))
         (QMAKE_CMD ENT RS "XCOMMAND \"_.3DPOLY\""))
        ((wcmatch  (FLDVAL 0 EL) "*POLYLINE")(QMAKE_CMD ENT RS "XPLINE"))
        ((= "ELLIPSE" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XELLIPSE"))
            ((= "INSERT" (FLDVAL 0 EL)) (QMAKE_CMD ENT RS "XINSERT"))
            ((= "HATCH" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XHATCH"))
       ((wcmatch  (FLDVAL 0 EL) "*DIMENSION")(QMAKE_CMD ENT RS "XDIM"))
            ((= "SHAPE" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XSHAPE"))
            ((= "SOLID" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XCOMMAND \"_.SOLID\""))
            ((= "TEXT" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XTEXT"))
            ((= "TRACE" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XTRACE"))
            ((= "VIEWPORT" (FLDVAL 0 EL))(QMAKE_CMD ENT RS "XVPORT"))
            (t 
             (alert 
               (strcat 
                 (FLDVAL 0 EL) 
                 " cannot be used with QUICKDRAW" 
               ) ;_ end of strcat 
             ) ;_ end of alert 
            ) 
      ) ;_ end of cond 
    ) ;_ end of progn 
    (prompt "\nNothing selected.") 
  ) ;_ end of if 
  (princ) 
) ;_ end of defun 
;;;(defun C:QUICKDRAW () (QUICKDRAW)) 
(defun C:Q () (QUICKDRAW nil))
(defun C:QUICKDRAW () (QUICKDRAW nil)) 
(defun C:QR () (QUICKDRAW t)) 
(princ "\nType in command line:") 
(princ "\nQR - QUICKDRAW with restore setting") 
(princ "\nQ - only QUICKDRAW")