Liren Large Software Subsidy 13/13.iso/p/p024/5.img/R11SUPP.EXE/XREFCLIP.LSP

Lisp/Scheme | 1990-10-02 | 13.5 KB | 455 lines

;;;   XrefClip.lsp
;;;   Copyright (C) 1990 by Autodesk, Inc.
;;;
;;;   Permission to use, copy, modify, and distribute this software and its
;;;   documentation for any purpose and without fee is hereby granted.
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;   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.
;;;
;;;----------------------------------------------------------------------------;
;;;
;;;
(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 "\nError: " s))
      )
    )
    (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
        "\nPaperspace/Modelspace is disabled.  This routine will not "
        "\nrun unless it is enabled.  Enable Paper/Modelspace?  <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)

  (setq xc_ver "1.00")                ; 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, Version " xc_ver ", (c) 1990 by Autodesk, Inc. "))

  (setq xref T)


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

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

  ;; 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
  )

  (command "layer" "set" lay "")
  (command "plan" "w")

  (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 "\nFirst point of clip box: "))

  ;; Get the other point of the clip box.
  (setq xc:cp2 (getcorner xc:cp1 "\nOther point of clip box: "))

  (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 "\nInsertion point for XrefClip: ")
      (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 "\nInsertion point for XrefClip: ")
      (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 "\nModifying the new viewport. ")

  ;; 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 "\nViewport is too small. ")
  )

)
;;;
;;; 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)
    (initget 1)
    (setq temp (getstring
      "\n\nXrefClip onto what layer? ")
    )
    (if (tblsearch "layer" temp)
      (progn
        (princ "\nLayer exists. ")
        (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)
  (while (null xc_nam)
    (initget 1)
    (setq temp (getstring (strcat
      "\nXref name: "))
    )
    (if (setq xc_nam (findfile (strcat temp ".dwg")))
      (princ)
      (princ (strcat "\n" temp " not found. "))

    )
  )
  xc_nam
)
;;;
;;; Interactively set the scale of each viewport.
;;;
;;; xc_ssi == XrefClip_Setup_Scale_Interactively
;;;
(defun xc_ssi (/ ans)
  (princ "\nEnter the ratio of paper space units to model space units... ")
  (initget 6)
  (setq ans (getreal
    "\nNumber of paper space units.  <1.0>: ")
  )
  (if (= (type ans) 'REAL)
    (setq xc_vps ans)
    (setq xc_vps 1.0)
  )
  (initget 6)
  (setq ans (getreal
    "\nNumber of model space units.  <1.0>: ")
  )
  (if (= (type ans) 'REAL)
    (setq xc_vps (/ xc_vps ans))
    (setq xc_vps (/ xc_vps 1.0))
  )
  xc_vps
)
;;; --------------------------------------------------------------------------;
(defun c:xc       () (xcmain))
(defun c:xrefclip () (xcmain))
(princ
  "\n\tC:XrefClip loaded.  Start command with XC or XREFCLIP.")
(princ)