Liren Large Software Subsidy 13/13.iso/p/p024/10.img/BONUS3.LIB/XREFCLIP.LSP

Text File | 1993-02-08 | 16.5 KB | 573 lines

;;;   XrefClip.lsp
;;;   (C) ¬⌐┼v 1988-1992  Autodesk ñ╜Ñq
;;;
;;;   Ñ╗╡{ªíñwÑ╤ Autodesk ñ╜Ñq╡∙ÑU¬⌐┼v, ╢╚⌐≤ñU¡z▒í¬pñUÑi▒┬╗P▒zíu│\ÑiívíC
;;;   ╗╒ñUñú▒oÑHÑ⌠ª≤º╬ªí╡oªµ⌐╬ÑX¬⌐ª╣╡{ªí¬║íu¡∞⌐l╜Xív; ª²ñ╣│\▒zªb»S⌐w¡lÑ═
;;;   ¬║ñuº@ñW╡▓ªXª╣╡{ªí¬║íuÑ╪¬║╜Xív¿╧Ñ╬íCª│├÷│o├■¡lÑ═ñuº@¬║▒°Ñ≤ªpñU:
;;;
;;;   ( i)  │]¡pñW╗Pñuº@ñW¼╥»┬║Θ░w╣∩ Autodesk ñ╜Ñq¬║▓ú½~íC
;;;   (ii)  ╕ⁿª│íu¬⌐┼v  (C) 1988-1992  Autodesk ñ╜Ñqív¬║¬⌐┼v│qºiíC
;;;
;;;
;;;
;;;   AUTODESKñ╜Ñq┤ú¿╤ª╣╡{ªí╢╚¿╤º@íu├■ªⁿív¬║░╤ª╥, ª╙ÑBñú▒╞░úª│Ñ⌠ª≤┐∙╗~¬║
;;;   Ñi»αíCAUTODESKñ╜Ñq»Sª╣º_╗{Ñ⌠ª≤»S⌐wÑ╬│~ñº╛A║┘⌐╩, ÑHñ╬░╙╖~╛P░Γ⌐╥┴⌠ºt
;;;   ÑX¿π¬║½O├╥íCAUTODESKñ╜ÑqªP«╔ÑτñúÑX¿πª╣╡{ªí░⌡ªµ«╔ñ@⌐wñú╖|íuññ┬_ív⌐╬
;;;   íuº╣Ñ■╡L╗~ív¬║½O├╥íC
;;;
;;;
;;;   by Jan S. Yoder
;;;   02 July 1990
;;;
;;;----------------------------------------------------------------------------
;;; DESCRIPTION
;;;
;;;   This routine is intended to make the task of inserting, sizing, and
;;;   positioning of external references easier, by clearing the screen of
;;;   all graphics, creating a viewport exclusively for the XREF, creating
;;;   a layer on which to attach the XREF, and zooming to the extents of
;;;   the XREF in current UCS plan view.
;;;
;;;   The routine may be called with either XC or XREFCLIP.
;;;
;;;   If TILEMODE is set to 1 or ON, you are asked whether you want to reset
;;;   it, and if not, you are exited from the routine.  If you elect to change
;;;   it, or it is already 0 or OFF, then you are prompted:
;;;
;;;     XrefClip, Version 1.00, (c) 1990 by Autodesk, Inc.
;;;     Xref name:
;;;     XrefClip onto what layer?
;;;
;;;   The XREF name must be a valid drawing file name that can be found on
;;;   AutoCAD's search paths.  The layer name must not be the name of an
;;;   existing layer name;  if it is you are so informed and asked for a
;;;   new name.
;;;
;;;   At this point, all of the viewports are turned off, and all thawed
;;;   layers are frozen.  A new viewport is fit to the screen, and the
;;;   XREF is attached to the layer specified in that viewport.  The XREF
;;;   is zoomed to its extents so that you may select the area you want to
;;;   clip (inclusively.)
;;;
;;;   You are prompted for the two clip points;
;;;
;;;     First point of clip box:
;;;     Other point of clip box:
;;;
;;;   and the zoom ratio;
;;;
;;;     Enter the ratio of paper space units to model space units...
;;;     Number of paper space units.  <1.0>:
;;;     Number of model space units.  <1.0>: (8)
;;;
;;;   All of the viewports are restored to their former state, and a box
;;;   designating the clipped viewport can be dragged around and you are
;;;   prompted for a location for the clipped view.
;;;
;;;     Insertion point for XrefClip:
;;;
;;;   A new viewport containing the clipped view of the XREF will be inserted
;;;   at the location specified.
;;;
;;;
;;; REVISIONS
;;;
;;;   Version 1.10 -- 11 Mar 1991 - Fixed multiple XREF of a file.
;;;   Version 1.11 -- 27 Mar 1991 - Fixed ZOOM problem.
;;;
;;;
;;;
;;;
;;;----------------------------------------------------------------------------;
;;;
;;;
(defun xcmain ( / xc_err s xc_oer xc_oce xc_oem xc_olu xc_ocv
                  curlay xc_nam lay xc:sov xc_vpn xc:ltg xc:ltl)

  ;;
  ;; Internal error handler defined locally
  ;;

  (defun xc_err (s)                   ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
    (if (/= s "Function cancelled")
      (if (= s "quit / exit abort")
        (princ)
        (princ (strcat "\n┐∙╗~: " s))
      )
    )
    (if (= 8 (logand (getvar "undoctl")))(command "_.UNDO" "_EN"))
    (if xc_oer                        ; If an old error routine exists
      (setq *error* xc_oer)           ; then, reset it
    )
    (if xc_oce (setvar "cmdecho" xc_oce)) ; Reset command echoing on error
    (if xc_oem (setvar "expert" xc_oem)) ; Reset expert mode on error
    (princ)
  )

  (if *error*                         ; If there is an error routine defined
    (setq xc_oer   *error*            ; Store AutoLisp error routine
          *error*  xc_err)            ; Temporarily replace it
  )

  (setq xc_oce (getvar "cmdecho"))
  (setq xc_oem (getvar "expert"))
  (setvar "cmdecho" 0)                ; Turn off command echoing
  (setvar "expert" 5)                 ; Turn expert mode way up.
  (command "_.UNDO" "_GROUP")            ; Set start of Undo group
  (if (xc_ctm)                        ; Is Tile-mode on? T or nil
    (progn
      (xc_sxc)                        ; Set up for Xref Clip
      (xc_dxc)                        ; Do XREF clipping
    )
  )
  (if (/= xc_ocv 1) (setvar "cvport" xc_ocv) (command "_.PSPACE"))
  (command "_.LAYER" "_SET" curlay "")
  (if xc_oer                          ; If an old error routine exists
    (setq *error* xc_oer)             ; then, reset it
  )
  (command "_.UNDO" "_END")              ; Set Undo End

  (if xc_oem (setvar "expert" xc_oem)) ; Reset expert mode
  (if xc_oce (setvar "cmdecho" xc_oce)) ; Reset command echoing
  (princ)
)
;;;
;;; Check Tile-mode.  Returns T if ON and nil if not on.
;;;
;;; xc_ctm == MView_Check_TileMode
;;;
(defun xc_ctm (/ ans)
  (if (= (getvar "TILEMODE") 1)
    (progn
      (initget "Yes No")
      (setq ans (getkword (strcat
        "\nÑ╝▒╥Ñ╬íu╣╧»╚¬┼╢íí■╝╥½¼¬┼╢íívÑ\»α; ╢╖▒╥Ñ╬ª╣Ñ\»αñ~Ñi¿╧Ñ╬Ñ╗▒`ªííC"
        "\n▒╥Ñ╬íu╣╧»╚¬┼╢íí■╝╥½¼¬┼╢íív? <Y>: "))
      )
      (if (= ans "No")
        nil
        (progn
          (setvar "TILEMODE" 0)
          T
        )
      )
    )
    T
  )
)
;;;
;;; Get set up for reference file clipping; get the file name, the layer to
;;; put it on, and make the layers, and set up all of the layers correctly
;;; to minimize "viewports".
;;;
;;; xc_sxc == MView_Setup_for_Xref_Clip
;;;
(defun xc_sxc (/ xc_ver xc_xdf xc_xlf xref xdpnd)

  (setq xc_ver "1.11")                ; Reset this local if you make a change.

  (setq xc_ocv (getvar "cvport"))
  (if (/= xc_ocv 1)
    (command "_.PSPACE")                ; Change to paperspace
  )

  (princ (strcat
    "\nXrefClip, ¬⌐Ñ╗ " xc_ver ", (c) 1990  Autodesk ñ╜ÑqíC "))

  (setq xref T)


  ;; Save the current layer name.
  (setq curlay (getvar "clayer"))

  ;; Get the name of the xref...
  (setq xc_nam (xc_gxn))

  ;; Check whether the XREF has already been attached.  Or whether a block
  ;; by that name exists in the current drawing.
  ;;   xc_xrs == xref_status == 0 -- not in current drawing.
  ;;                            1 -- Xref in current drawing.
  ;;                            2 -- Block ref in current drawing.
  ;; Also set xdpnd True if the layer on which the Xref or block insert
  ;; has been placed is an exclusive layer, nil otherwise.
  (setq xc_xrs (xc_gxs xc_nam))

  ;; Get a layer name for the Xref.  It must not already exist!
  (setq lay (xc_gln))

  ;; Make a layer for the new viewport.
  (command "_.VPLAYER" "_NEW" (strcat lay "-vp") "")
  (command "_.VPLAYER" "_F" (strcat lay "-vp") "_ALL"
           "_T" (strcat lay "-vp") "" "")
  (command "_.LAYER" "_SET" (strcat lay "-vp") "")

  ;; Save the names of all the layers that are thawed globally.
  (xc_sgt)

  ;; Freeze all of 'em except the current layer.
  (command "_.LAYER" "_F" (strcat "~" lay "-vp") "")

  ;; Save the names of all the viewports that are ON.
  (xc_sov)

  ;; Freeze all of 'em except the current layer.
  (command "_.MVIEW" "_OFF" xc:sov "")

  ;; Create a new viewport on the viewport layer.  Fit it to the screen.
  (command "_.MVIEW" "_F")

  ;; Make a new layer for the Xref.  Make it exclusive.
  (command "_.VPLAYER" "_NEW" lay "")
  (command "_.VPLAYER" "_F" lay "_ALL" "_T" lay "_S" "_L" "" "")

  ;; Save the entity name of the viewport.
  (setq xc_vpn (entlast))

  (if (= (getvar "cvport") 1)
    (command "_.MSPACE")                ; Change to modelspace
  )

  ;; If xdpnd is true, thaw the layer on which the xref or insert has
  ;; been placed previously.
  (if xdpnd
    (progn
      (command "_.LAYER" "_T" xc_xrl "_T" (strcat xc_xri "*") "")
      (command "_.VPLAYER" "_T" xc_xrl "_CUR" "")
    )
  )

  (command "_.LAYER" "_SET" lay "")

  (if (not xdpnd)
    (progn
      (command "_.VPLAYER" "_F" (strcat "~" lay) "" "")
    )
  )
  ;; Do the Xref attach or block insertion.
  (command "_.XREF" "" xc_nam "0,0" "" "" "")

  ;; Zoom extents in plan view
  (command "_.ZOOM" "_E")
)
;;;
;;;
;;;
;;;
;;; xc_dxc == MView_Do_Xref_Clip
;;;
(defun xc_dxc (/ xc:cp1 xc:cp2 xc_vps xs ys nxs nys ip)
  ;; Get the first point of the clip box.
  (setq xc:cp1 (getpoint "\níu║I«╪ív▓─ñ@¿ñ┬I: "))

  ;; Get the other point of the clip box.
  (setq xc:cp2 (getcorner xc:cp1 "\níu║I«╪ívÑtñ@¿ñ┬I: "))

  ;; Sort the two points into lower-left to upper-right order.
  (if (> (car xc:cp1) (car xc:cp2))
    (setq x (car xc:cp1)
          xc:cp1 (list (car xc:cp2) (cadr xc:cp1) 0.0)
          xc:cp2 (list x (cadr xc:cp2) 0.0)
    )
  )
  (if (> (cadr xc:cp1) (cadr xc:cp2))
    (setq x (cadr xc:cp1)
          xc:cp1 (list (car xc:cp1) (cadr xc:cp2) 0.0)
          xc:cp2 (list (car xc:cp2) x 0.0)
    )
  )

  (if (/= (getvar "cvport") 1)
    (command "_.PSPACE")                ; Change to paperspace
  )

  ;; Get the scale of the clip region.
  (setq xc_vps (xc_ssi))

  ;; Set the X and Y scale factors based on the two points
  ;; and the scale factor entered.
  (setq xs (- (car  xc:cp2) (car  xc:cp1))
        ys (- (cadr xc:cp2) (cadr xc:cp1))
        nxs (/ xs xc_vps)
        nys (/ ys xc_vps)
  )
  ;; Delete the last viewport.
  (entdel xc_vpn)

  ;; Turn back ON all of the viewports.
  (command "_.MVIEW" "_ON" xc:sov "")

  ;; Thaw the layers which we froze earlier.
  (command "_.LAYER")

  (foreach n xc:ltg (command "_THAW" n))
  (command "")
  (command "_.LAYER" "_SET" curlay "")

  (if (tblsearch "block" "xc_box")
    (progn
      (princ "\níuXrefClipív┤íñ▐┬I: ")
      (command "_.INSERT" "xc_box" "_xscale" nxs "_yscale" nys "_rotate" 0 pause)
    )
    (progn
      (command "_.PLINE" "0,0" "_W" "0" "" "1,0" "1,1" "0,1" "_CL")
      (command "_.CHPROP" (entlast) "" "_C" "bylayer" "_LT" "bylayer" "_LA" "0" "")
      (command "_.BLOCK" "xc_box" "0,0" (entlast) "")
      (princ "\níuXrefClipív┤íñ▐┬I: ")
      (command "_.INSERT" "xc_box" "_xscale" nxs "_yscale" nys "_rotate" 0 pause)
    )
  )

  ;; Get the block insertion point and scale factors.
  (setq ip (xc_val 10 (entlast) nil))

  ;; Delete the block.
  (entdel(entlast))

  ;;(princ "\n¡╫º∩╖síu╡°╡íívíC")

  ;; Create the new viewport.
  (command "_.LAYER" "_SET" (strcat lay "-vp") "")
  (command "_.VPLAYER" "_F" lay "_C" "")
  (command "_.MVIEW" ip (strcat "@" (rtos nxs) "," (rtos nys) "," "0.0"))

  (setq xc_vpn (entlast))
  (setq temp (xc_val 69 xc_vpn nil))

  (if (= (getvar "cvport") 1)
    (command "_.MSPACE")                ; Change to modelspace
  )

  (command "_.VPLAYER" "_F" lay "_ALL" "_T" lay "_S" "_L" "" "")

  (if (> (xc_val 68 xc_vpn nil) 0)
    (progn

      (setvar "cvport" temp)

      (command "_.PLAN" "")
      (command "_.ZOOM" "_C" (xc_a2p xc:cp1 xc:cp2) ys)
    )
    (princ "\níu╡°╡íívñ╙ñpíC")
  )

)
;;;
;;; Get the midpoint between two points.
;;;
;;; xc_a2p == XrefClip_Average_2_Points
;;;
(defun xc_a2p (a b / c)
  (setq c (list (/ (+ (car  a) (car  b)) 2.0)
                (/ (+ (cadr a) (cadr b)) 2.0)
                0.0
          )
  )
)
;;;
;;; Get the value associated with key "n" in "e".
;;; If "f" is T the "e" is an entity list, else it is an entity name.
;;;
;;; xc_val == XrefClip_assoc_VALue
;;;
(defun xc_val (n e f)
  (if f ; if f then e is an entity list.
    (cdr (assoc n e))
    (cdr (assoc n (entget e)))
  )
)

;;;
;;; Save the names of all the viewports that are ON,
;;; because we are going to temporarily turn them all OFF.
;;;
;;; xc_sov == XrefClip_Save_On_Viewports
;;;
(defun xc_sov (/ ss sov sslen)
  (setq xc:sov (ssadd)
        j      0
  )
  (setq ss (ssget "x" '((0 . "viewport")))) ; Get all vports in database.
  (setq sslen (sslength ss))
  (while (< j sslen)
    (setq sov (ssname ss j))
    (if (and (> (xc_val 68 sov nil) 1) (/= (xc_val 69 sov nil) 1))
      (ssadd sov xc:sov)
    )
    (setq j (1+ j))
  )
  xc:sov
)
;;;
;;; Save the layer names of all the layers that are globally Thawed,
;;; because we are going to temporarily Freeze all of them.
;;;
;;; xc_sgt == XrefClip_Save_Globally_Thawed_layers
;;;
(defun xc_sgt (/ lay)
  (setq lay (tblnext "layer" T))      ; Get first layer in database.
  (if (/= (logand (cdr(assoc 70 lay)) 1) 1)
    (setq xc:ltg (list (cdr(assoc 2 lay))))
  )
  (while (setq lay (tblnext "layer"))
    (if (/= (logand (cdr(assoc 70 lay)) 1) 1)
      (setq xc:ltg (append xc:ltg (list (cdr(assoc 2 lay)))))
    )
  )
  xc:ltg
)
;;;
;;; Save the layer names of all the layers in the current viewport that
;;; are locally thawed, because we are going to temporarily freeze them.
;;;
;;; xc_slt == XrefClip_Save_Locally_Thawed_layers
;;;
(defun xc_slt (/ lay)
  (setq lay (tblnext "layer" T))      ; Get first layer in database.
  (if (/= (logand (cdr(assoc 70 lay)) 2) 2)
    (setq xc:ltl (list (cdr(assoc 2 lay))))
  )
  (while (setq lay (tblnext "layer"))
    (if (/= (logand (cdr(assoc 70 lay)) 2) 2)
      (setq xc:ltl (append xc:ltl (list (cdr(assoc 2 lay)))))
    )
  )
  xc:ltl
)
;;;
;;; Set a layer if it exists?  Create it otherwise?
;;;
;;; xc_gln == XrefClip_Get_Layer_Name
;;;
(defun xc_gln (/ temp)
  (while (null temp)
    (setq temp (getstring
      "\n\níuXrefClipív╕m⌐≤ª≤╝h? ")
    )
    (if (tblsearch "layer" temp)
      (progn
        (princ "\níu╣╧╝hívñwªsªbíC")
        (setq temp nil)
      )
    )
  )
  temp
)
;;;
;;; Get the xref file name and verify that it exists.
;;;
;;; xc_gxn == XrefClip_Get_Xref_Name
;;;
(defun xc_gxn (/ temp xc_nam sl a b)
  (while (null xc_nam)
    (setq temp (getstring (strcat
      "\níuÑ~│í░╤ª╥ívªW║┘: "))
    )
    (setq sl (strlen temp))

    (if (and (> sl 4) (= (substr temp (- sl 3)) ".dwg"))
      (setq temp (substr temp 1 (- sl 4)))
    )

    (if (setq xc_nam (findfile (strcat temp ".dwg")))
      (princ)
      (princ (strcat "\nºΣñú¿∞íu" temp "ívíC"))

    )

    ;; Remove pathname
    (setq a 1)
    (repeat (strlen temp)
      (if (member (substr temp a 1) '("/" "\\" ":"))
        (setq b a)
      )
      (setq a (1+ a))
    )
    (if b
      (setq temp (substr temp (1+ b)))
    )
    (setq xc_snm (strcase temp))
  )
  xc_nam
)
;;;
;;; Interactively set the scale of each viewport.
;;;
;;; xc_ssi == XrefClip_Setup_Scale_Interactively
;;;
(defun xc_ssi (/ ans)
  (princ "\n┐ΘñJíu╣╧»╚¬┼╢í│µª∞ív╣∩íu╝╥½¼¬┼╢í│µª∞ív¬║ñ±¿╥... ")
  (initget 6)
  (setq ans (getreal
    "\níu╣╧»╚¬┼╢í│µª∞ív╝╞¡╚ <1.0>: ")
  )
  (if (= (type ans) 'REAL)
    (setq xc_vps ans)
    (setq xc_vps 1.0)
  )
  (initget 6)
  (setq ans (getreal
    "\níu╝╥½¼¬┼╢í│µª∞ív╝╞¡╚ <1.0>: ")
  )
  (if (= (type ans) 'REAL)
    (setq xc_vps (/ xc_vps ans))
    (setq xc_vps (/ xc_vps 1.0))
  )
  xc_vps
)
;;;
;;; Check whether the XREF has already been attached.  Or whether a block
;;; by that name exists in the current drawing.
;;;   xc_xrs == xref_status == 0 -- not in current drawing.
;;;                            1 -- Xref in current drawing.
;;;                            2 -- Block ref in current drawing.
;;;
;;; xc_gxs == XrefClip_Get_Xref_Status
(defun xc_gxs (nam / ss)
  (cond
    ((and nam (setq ent (tblsearch "block" xc_snm)))
      (cond
        ((= (cdr(assoc 70 ent)) 4)
          (setq flag 1)
        )
        (T
          (setq flag 2)
        )
      )
      (if (= (getvar "cvport") 1)
        (command "_.MSPACE")                ; Change to modelspace
      )
      (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 xc_snm))))
      (if ss
        (setq xc_xre (entget (ssname ss 0))
              xc_xri (cdr(assoc 2 xc_xre))
              xc_xrl (tblsearch "layer" (cdr(assoc 8 xc_xre)))
        )
      )
      (if (/= (getvar "cvport") 1)
        (command "_.PSPACE")                ; Change to paperspace
      )
      (cond
        ((= (logand (cdr(assoc 70 xc_xrl)) 2) 2)
          (setq xdpnd T
                xc_xrl (cdr(assoc 2 xc_xrl))
          )
        )
        (T
          (setq xdpnd nil)
        )
      )
    )
    (T
      (setq flag 0)
    )
  )
  flag
)
;;; --------------------------------------------------------------------------;
(defun c:xc       () (xcmain))
(defun c:xrefclip () (xcmain))
(princ
  "\n\tíuC:XrefClipívñw╕ⁿñJ; ╜╨ÑH XC ⌐╬ XREFCLIP ▒╥░╩½ⁿÑOíC")
(princ)