Windows 95 v2.4 Fix/W95-v2.4fix.iso/ACADWIN/SUPPORT/XREFCLIP.LSP

Lisp/Scheme | 1995-02-08 | 16.8 KB | 565 lines

; Next available MSG number is    22
; MODULE_ID XREFCLIP_LSP_
;;;
;;;    xrefclip.lsp
;;;
;;;    Copyright (C) 1990, 1992, 1994 by Autodesk, Inc.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;.
;;;----------------------------------------------------------------------------
;;; 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:
;;;
;;;     Xref name:
;;;     Clip 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 corner of clip box:
;;;     Other corner:
;;;
;;;   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 clip:
;;;
;;;   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 "Funci≤n cancelada")
      (if (= s "quitar / salir abandonar")
        (princ)
        (princ (strcat "\nError: " 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 "Sφ No")
      (setq ans (getkword
        "\n┐Activar Espacio papel? <S>: ")
      )
      (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
  )

  (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 corners of the clip box.
  (while (null xc:cp2)
    (if (null xc:cp1)
        (setq xc:cp1 (getpoint "\nPrimera esquina del ßrea delimitada: "))
        (setq xc:cp2 (getcorner xc:cp1 "\nEsquina opuesta: "))
    )
  )

  ;; 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 "\nPunto de inserci≤n: ")
      (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 "\nPunto de inserci≤n: ")
      (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 "\nVentana grßfica demasiado peque±a. ")
  )

)
;;;
;;; 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┐Pegar en quΘ capa? ")
    )
    (if (tblsearch "layer" temp)
      (progn
        (princ "\nEsta capa ya existe. ")
        (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
      "\nNombre de RefX: "))
    )
    (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" temp " no encontrado. "))

    )

    ;; 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 "\nRelaci≤n entre unidades de Espacio papel y de Espacio modelo... ")
  (initget 6)
  (setq ans (getreal
    "\nN·mero de unidades de Espacio papel <1.0>: ")
  )
  (if (= (type ans) 'REAL)
    (setq xc_vps ans)
    (setq xc_vps 1.0)
  )
  (initget 6)
  (setq ans (getreal
    "\nN·mero de unidades de Espacio modelo <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))