Mark,
Give this a try. This assumes you already have your titleblock and viewport inserted and are in the layout tab.
Will
;;;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)
)
