Author Topic: Copying, Exploding or Changing Viewports in Model Space  (Read 16119 times)

0 Members and 1 Guest are viewing this topic.

whdjr

  • Guest
Copying, Exploding or Changing Viewports in Model Space
« Reply #60 on: November 22, 2004, 03:34:18 PM »
Mark,

Give this a try.  This assumes you already have your titleblock and viewport inserted and are in the layout tab.

Will
Code: [Select]
;;;This program hopefully answers a question at theswamp.org by ML.
;;;
;;;Copyright by Will DeLoach
;;;Can be rewritten or reused as you see fit.
;;;
;;;Loads the activeX controls if they are not already loaded.
;;;
(vl-load-com)
;;;
;;;This function uses ssget to return a single selection and continues
;;;to loop until something is selected or a right click is detected.
;;;
(defun ss_get (typ filter / ent)
  (if (> (getvar "CVPORT") 1)
    (command "._PSPACE")
  )
  (while (not ent)
    (prompt "\nSelect a Viewport to convert to modelspace:  ")
    (cond ((setq ent (ssget typ filter)))
 ((= (getvar "ErrNo") 52)
  (exit)
 )
 ((null ent)
  (princ "\nSelection missed.  Please try again.")
 )
    )
  )
  (ssname ent 0)
)
;;;
;;;This makes a variable length vbDouble safearray.
;;;
(defun make-array (pointlist)
  (vlax-make-variant
    (vlax-safearray-fill
      (vlax-make-safearray
vlax-vbDouble
(cons 0
     (1- (length
   pointlist
 )
     )
)
      )
      pointlist
    )
  )
)
;;;
;;;This collects the coordinates for the viewport and translates the to modelspace.
;;;
(defun translate_pts (obj / pnts)
  (vla-getboundingbox obj 'll 'ur)
  (setq pnts (mapcar 'vlax-safearray->list (list ll ur))
pnts (list (list (caar pnts) (cadar pnts))
  (list (caadr pnts) (cadar pnts))
  (list (caadr pnts) (cadadr pnts))
  (list (caar pnts) (cadadr pnts))
    )
pnts (3d->2d (mapcar
      '(lambda (x)
 (trans x 3 2)
)
      pnts
    )
    )
ll   (car pnts)
ur   (caddr pnts)
  )
  pnts
)
;;;
;;;This converts 3d points to 2d points for the lightweight polyline creation.
;;;
(defun 3d->2d (lst)
  (mapcar '(lambda (x)
    (list (float (car x)) (float (cadr x)))
  )
 lst
  )
)
;;;
;;;This sets the viewport scale before the points are translated.
;;;
(defun set_scl (ent int / obj)
  (setq obj (vlax-ename->vla-object ent))
  (vla-put-standardscale obj acVpCustomScale)
  (vla-put-customscale obj int)
  obj
)
;;;
;;;This is the main program.
;;;
(defun c:vp (/ ss scl pts obj space pline ll ur)
  (cond ((not (and (setq ss (ss_get ":S:E" '((0 . "VIEWPORT"))))
  (not (initget (+ 1 2 4)))
  (setq scl (getreal "\nEnter scale factor:  "))
  (setq obj (set_scl ss (/ 1.0 scl)))
     )
)
(princ "\nUser Error. ")
)
((not (setq pts (apply 'append (translate_pts obj))))
(princ
  "\nError: Could not translate points to model space. "
)
)
(T
(command "._MSPACE")
(setq space (vla-get-modelspace
      (vla-get-activedocument (vlax-get-acad-object))
    )
)
(setq pline (vla-addlightweightpolyline space (make-array pts)))
(vla-put-closed pline T)
(command "._PSPACE")
(setvar "CTAB" "MODEL")
(command "zoom" "window" ll ur)
)
  )
  (princ)
)