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

;_Tip1381.LSP:  QUICKDRAW.LSP   Quickly draw another   ©1997, Rory Love
;_ Modify 16.04.2009 by VVA (Vladimir Azarko) :
;_ - Commands for the localised versions are adapted
;_ - Processing of primitive things is added (LWPOLYLINE, ELLIPSE, ELLIPSE ARC)
;_ - Add CLIP selected VIEWPORT
;_ posted https://www.caduser.ru/forum/topic9651.html
(vl-load-com)
(defun
     *MERRMSG* (MSG)
  (princ MSG)
  (setvar "cecolor" "BYLAYER")
;;;  (setvar "blipmode" 1)
  (setvar "cmdecho" 0)
  (setvar "menuecho" 2)
  (setq *ERROR* M:ERR
        M:ERR NIL
  ) ;_ end of setq
  (princ)
) ;_ end of defun
(defun
     PROPS (/ COLOR LTYPE)
  (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
) ;_ end of defun
(defun
     XARC (/ CMD)
  (PROPS)
  (setq CMD "_ARC")
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD)
) ;_ end of defun
(defun
     XCIRCLE ( / CMD)
  (PROPS)
  (setq CMD "_circle")
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD)
) ;_ end of defun
(defun
     XELLIPSE ( IsFullEllipse / CMD)
  (PROPS)
  ;;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)
  (PROPS)
  (setq CMD   "_INSERT"
        NAME  (FLDVAL 2 EL)
        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
) ;_ end of defun
(defun
     XLINE (/ CMD)
  (PROPS)
  (setq CMD "_.LINE")
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD)
) ;_ end of defun
(defun
     XPOINT (/ CMD)
  (PROPS)
  (setq CMD "_POINT")
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD)
) ;_ end of defun
(defun X3DPLINE ( / CMD)
  (PROPS)
  (setq CMD "_.3DPOLY")
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD)
) ;_ end of defun
(defun
     XPLINE ( EL / CMD WHAT)
(initget "Pline REctang R3P")
(setq WHAT (getkword "\nAs we will draw a polyline? [Pline/REctang/R3P] <Pline> :"))
(PROPS)
(cond ((= WHAT "REctang")
       (setq CMD "_.RECTANG")
       (prompt (strcat "\nCommand: " CMD " "))
       (command CMD "_W"  (FLDVAL 40 EL))
       )
      ((= WHAT "R3P")
       (prompt (strcat "\nCommand: R3P"))
       (C:R3P)
       )
      (t (setq CMD "_.PLINE")
       (setvar "PLINEWID" (FLDVAL 40 EL))
       (command CMD)
       )
      )
) ;_ end of defun
(defun
     XDIM ( EL / CMD WHAT)
(PROPS)
(cond ((member '(100 . "AcDbRotatedDimension") EL)
       (setq CMD "_.DIMLINEAR")
       )
      ((member '(100 . "AcDbAlignedDimension") EL)
       (setq CMD "_.DIMALIGNED")
       )
      ((member '(100 . "AcDbArcDimension") EL)
       (setq CMD "_.DIMARC")
       )
      ((member '(100 . "AcDb3PointAngularDimension") 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 " "))
(command CMD)
)
(defun
     XHATCH ( EL / CMD WHAT)
 (setq CMD "_.BHATCH")
 (setvar "HPANG" (FLDVAL 52 EL))
 (setvar "HPSCALE" (FLDVAL 41 EL))
 (setvar "HPNAME" (FLDVAL 2 EL))
 (prompt (strcat "\nCommand: " CMD " ")) 
 (PROPS)
 (vla-sendcommand
   (vla-get-activedocument (vlax-get-acad-object))
   "_.BHATCH\n")
 ;;; (command CMD)
)
(defun
     XSHAPE (/ CMD NAME SCALE)
  (PROPS)
  (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 (/ CMD)
  (PROPS)
  (setq CMD "_solid")
  (prompt (strcat "\nCommand: " CMD " "))
  (command CMD)
) ;_ end of defun
(defun
     XTEXT (/ CMD NAME CODE72 CODE73 JUSTIFY)
  (PROPS)
  (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
  (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 (/ CMD WID)
  (PROPS)
  (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)
  (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))(PROPS)(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)
       (vl-cmdf "_.VPCLIP" VP1 "_D")
       (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 *adoc*)
    (princ)) ;_ end of defun
  (vl-load-com)
(or *adoc* (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
(setvar "CMDECHO" 0)(setvar "EXPERT" 5)
(vla-startundomark *adoc*)
 (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 *adoc*)
  (princ)
)

;;; ------------- [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)))
;;; 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 (/ ENT EL)
  (setq M:ERR   *ERROR*
        *ERROR* *MERRMSG*
  ) ;_ end of setq
  (if (setq ENT (car (entsel "\nSelect object: ")))
    (progn
      (setq EL (entget ENT))
      (cond ((= "ARC" (FLDVAL 0 EL)) (XARC))
            ((= "CIRCLE" (FLDVAL 0 EL)) (XCIRCLE))
        ((= "ELLIPSE" (FLDVAL 0 EL))
         (XELLIPSE (and
             (zerop (FLDVAL 41 EL))
             (equal (FLDVAL 42 EL) (* 2 PI) 1e-9)
             )
               )
         )
            ((= "INSERT" (FLDVAL 0 EL)) (XINSERT))
            ((= "HATCH" (FLDVAL 0 EL)) (XHATCH EL))
            ((= "LINE" (FLDVAL 0 EL)) (XLINE))
            ((= "POINT" (FLDVAL 0 EL)) (XPOINT))
        ((and (= "POLYLINE" (FLDVAL 0 EL))
          (= 8 (FLDVAL 70 EL))) (X3DPLINE))
            ((wcmatch  (FLDVAL 0 EL) "*POLYLINE") (XPLINE EL))
        ((wcmatch  (FLDVAL 0 EL) "*DIMENSION") (XDIM EL))
            ((= "SHAPE" (FLDVAL 0 EL)) (XSHAPE))
            ((= "SOLID" (FLDVAL 0 EL)) (XSOLID))
            ((= "TEXT" (FLDVAL 0 EL)) (XTEXT))
            ((= "TRACE" (FLDVAL 0 EL)) (XTRACE))
            ((= "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
  (setq *ERROR* M:ERR
        M:ERR NIL
  ) ;_ end of setq
  (princ)
) ;_ end of defun
(defun C:QUICKDRAW () (QUICKDRAW))
(defun C:Q () (QUICKDRAW))