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

;_ Редакция 06.05.2009 
;_Tip1381.LSP:  QUICKDRAW.LSP   Quickly draw another   ©1997, Rory Love 
;_ posted https://www.caduser.ru/forum/ 
(vl-load-com) 
(defun RESTOREPROPS () 
(mapcar 
'(lambda(x y) 
   (setvar x y) 
) 
'("clayer" "cecolor" "celtype" "celweight") 
*PREVPROPS* 
) 
(setq  *PREVPROPS* nil) 
(princ)         
  ) 
(defun PROPS ( EL / COLOR LTYPE) 
  (setq *PREVPROPS* 
    (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" 
    ) ;_ end of if 
  ) ;_ end of setvar 
  (setvar 
    "celtype" 
    (if (setq LTYPE (FLDVAL 6 EL)) 
      LTYPE 
      "bylayer" 
    ) ;_ end of if 
  ) ;_ end of setvar 
  (setvar 
    "celweight" 
    (if (setq LTYPE (FLDVAL 370 EL)) 
      LTYPE 
     -1 
    ) ;_ end of if 
  ) ;_ end of setvar 
) ;_ end of defun 
(defun XARC ( EL / CMD) 
  (PROPS EL) 
  (setq CMD "_ARC") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (command CMD) 
) ;_ end of defun 
(defun XCIRCLE ( EL / CMD) 
  (PROPS EL) 
  (setq CMD "_circle") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (command CMD) 
) ;_ end of defun 
(defun XELLIPSE ( EL IsFullEllipse / CMD) 
  (PROPS EL) 
  ;;IsFullEllipse - t - ellipse nil -arc 
  (setq CMD "_.ELLIPSE") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (if IsFullEllipse 
  (command CMD) 
  (command CMD "_ARC") 
    ) 
) ;_ end of defun 
(defun XINSERT ( EL / CMD NAME XSIZE YSIZE ANG blk DynPropList) 
  (PROPS EL) 
   
  (setq CMD   "_INSERT" 
   blk (vlax-ename->vla-object(FLDVAL -1 EL)) 
;;;       NAME  (FLDVAL 2 EL)  ;;;Rem VVA 29.04.2009 
   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 
  (CMDWAIGHT RS) 
  (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)) 
                ) 
     ) 
     ) 
   ) 
      ) 
    ) 
) ;_ end of defun 
(defun XLINE ( EL / CMD) 
  (PROPS EL) 
  (setq CMD "_.LINE") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (command CMD) 
) ;_ end of defun 
(defun XPOINT ( EL / CMD) 
  (PROPS EL) 
  (setq CMD "_POINT") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (command CMD) 
) ;_ end of defun 
(defun X3DPLINE ( EL / CMD) 
  (PROPS EL) 
  (setq CMD "_.3DPOLY") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (command CMD) 
) ;_ end of defun 
(defun XPLINE ( EL / CMD WHAT) 
(initget "Pline REctang R3P") 
(setq WHAT (getpoint "\nPick a first point of polyline or [Pline/REctang/R3P] <Pline> :")) 
(PROPS EL) 
(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) 
(PROPS EL) 
(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))   
(command  "_.DIMSTYLE" "_R" (FLDVAL 3 EL)) 
;;(command  "_.DIMSTYLE" "" "" (FLDVAL -1 EL)) 
;;; Valery Brelovsky 
;;; (GRAPHSCR)   
(command CMD) 
) 
(defun XHATCH ( EL / CMD) 
(setq 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 " ")) 
(PROPS EL) 
(vla-sendcommand 
   (vla-get-activedocument (vlax-get-acad-object)) 
   "_.BHATCH\n") 
;;; (command CMD) 
) 
(defun XSHAPE ( EL / CMD NAME SCALE) 
  (PROPS EL) 
  (setq CMD   "_shape" 
        NAME  (FLDVAL 2 EL) 
        SCALE (FLDVAL 40 EL) 
  ) ;_ end of setq 
  (prompt 
    (strcat 
      "\nCommand: " 
      CMD 
      " " 
      NAME 
      " Starting point: " 
    ) ;_ end of strcat 
  ) ;_ end of prompt 
  (command CMD NAME PAUSE SCALE) 
) ;_ end of defun 
(defun XSOLID ( EL / CMD) 
  (PROPS EL) 
  (setq CMD "_solid") 
  (prompt (strcat "\nCommand: " CMD " ")) 
  (command CMD) 
) ;_ end of defun 
(defun XTEXT ( EL / CMD NAME CODE72 CODE73 JUSTIFY) 
  (PROPS EL) 
  (setq 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) 
  (PROPS EL) 
  (setq 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) 
  (PROPS (entget ENT)) 
  (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)(CMDWAIGHT RS)) 
    (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") 
       ) 
     (RESTOREPROPS) 
     ) 
    ) 
) ;_ 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)(RESTOREPROPS) 
  (if (vlr-added-p objCall)(vlr-remove objCall)) 
  (vla-endundomark *QDADOC*) 
  ) 
(defun CMDWAIGHT ( RS ) 
  ;;; RS - restore settings 
  ;;;     t - restore 
  ;;;     nil - not 
(if RS (progn   
(while (> (getvar "CMDACTIVE") 0)(command pause)) 
(RESTOREPROPS)));_ IF RS 
(vla-endundomark *QDADOC*) 
) 
;;; 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. 
(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)) (XARC EL)(CMDWAIGHT RS)) 
            ((= "CIRCLE" (FLDVAL 0 EL)) (XCIRCLE EL)(CMDWAIGHT RS)) 
       ((= "ELLIPSE" (FLDVAL 0 EL)) 
        (XELLIPSE EL (and 
          (zerop (FLDVAL 41 EL)) 
          (equal (FLDVAL 42 EL) (* 2 PI) 1e-9) 
          ) 
             ) 
        (CMDWAIGHT RS) 
        ) 
            ((= "INSERT" (FLDVAL 0 EL)) (XINSERT EL)) 
            ((= "HATCH" (FLDVAL 0 EL))(CMDSTARTREACT RS)(XHATCH EL)) 
            ((= "LINE" (FLDVAL 0 EL)) (XLINE EL)(CMDWAIGHT RS)) 
            ((= "POINT" (FLDVAL 0 EL)) (XPOINT EL)(CMDWAIGHT RS)) 
       ((and (= "POLYLINE" (FLDVAL 0 EL)) 
        (= 8 (FLDVAL 70 EL))) (X3DPLINE EL)(CMDWAIGHT RS)) 
            ((wcmatch  (FLDVAL 0 EL) "*POLYLINE") (XPLINE EL)(CMDWAIGHT RS)) 
       ((wcmatch  (FLDVAL 0 EL) "*DIMENSION") (XDIM EL)(CMDWAIGHT RS)) 
            ((= "SHAPE" (FLDVAL 0 EL)) (XSHAPE EL)(CMDWAIGHT RS)) 
            ((= "SOLID" (FLDVAL 0 EL)) (XSOLID EL)(CMDWAIGHT RS)) 
            ((= "TEXT" (FLDVAL 0 EL))(CMDSTARTREACT RS)(XTEXT EL)) 
            ((= "TRACE" (FLDVAL 0 EL)) (XTRACE EL)(CMDWAIGHT RS)) 
            ((= "VIEWPORT" (FLDVAL 0 EL)) (XVPORT ENT)) 
            (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:QR () (QUICKDRAW t)) 
(princ "\nType in command line:") 
(princ "\nQR - QUICKDRAW with restore setting") 
(princ "\nQ - only QUICKDRAW")