;;; LayoutsToDwgs.lsp
;;; Created 2000-03-27
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2003-12-12 Sets UCS to world in model space to avoid problem with wblock
;;;
;;; For AutoCAD 2000, 2000i, 2002, 2004
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Creates drawings of all layouts.
;;; Only one layout at a time is saved, the rest are deleted.
;;; This is handy when you want to save to pre A2k versions.
;;; The new drawings are saved to the current drawings path
;;; and overwrites existing drawings.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:LayoutsToDwgsMod (/ fn path msg msg2 fileprefix)
(defun DelAllLayouts (Keeper / TabName)
(vlax-for Layout
(vla-get-Layouts
(vla-get-activedocument (vlax-get-acad-object))
)
(if
(and
(/= (setq TabName (strcase (vla-get-name layout))) "MODEL")
(/= TabName (strcase Keeper))
)
(vla-delete layout)
)
)
)
(vl-load-com)
(setq msg "")
(setq msg2 "")
(command "._undo" "_BE")
(setq fileprefix (getstring "Enter filename prefix: "))
(foreach lay (layoutlist)
(if (/= lay "Model")
(progn
(command "_.undo" "_M")
(DelAllLayouts lay)
;;; pbe Sep 2018 ;;;
(if (setq vpselected nil
viewports (ssget "_X"
(list '(0 . "VIEWPORT")
(cons 410 (getvar 'ctab))
'(-4 . "/=")
'(69 . 1)
)
)
)
(repeat (setq i (sslength viewports))
(setq vpselected
(Cons (jb:vp-outline
(setq e (ssname viewports (setq i (1- i))))
)
vpselected
)
)
)
)
;;; ;;;
(setvar "tilemode" 1)
(command "ucs" "w")
;;; pbe Sep 2018 ;;;
(setq not_this (ssadd))
(Foreach objects vpselected
(if
(setq ss (ssget "_CP" (pts_list objects)))
(repeat (setq i (sslength ss))
(ssadd (setq e (ssname ss (setq i (1- i)))) not_this)
(ssdel objects not_this)
)
)
)
(command "_erase" "all" "_Remove" not_this "")
;;; ;;;
(setvar "tilemode" 0)
(setq path (getvar "DWGPREFIX"))
(setq fn (strcat path fileprefix lay ".dwg"))
(if (findfile fn)
(progn
(command ".-wblock" fn "_Y")
(if (equal 1 (logand 1 (getvar "cmdactive")))
(progn
(setq msg (strcat msg "\n" fn))
(command "*")
)
(setq msg2 (strcat msg2 "\n" fn))
)
)
(progn
(command ".-wblock" fn "*")
(setq msg (strcat msg "\n" fn))
)
)
(command "_.undo" "_B")
)
)
)
(if (/= msg "")
(progn
(prompt "\nFollowing drawings were created:")
(prompt msg)
)
)
(if (/= msg2 "")
(progn
(prompt "\nFollowing drawings were NOT created:")
(prompt msg2)
)
)
(command "._undo" "_E")
(textscr)
(princ)
)
(defun dxf (n ed) (cdr (assoc n ed)))
(defun ax:List->VariantArray (lst)
(vlax-Make-Variant
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0 (- (length lst) 1))
)
lst
)
)
)
(defun jb:vp-outline ( ent / ad ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ npl)
(setq ad (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "tilemode") 0)
(progn
(if (= (getvar "cvport") 1)
(progn
(if ;(setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
ent
(progn
(setq vpno (dxf 69 (entget ent)))
(vla-Display (vlax-ename->vla-object ent) :vlax-true)
(vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
; this to ensure trans later is working on correct viewport
(setvar "cvport" vpno)
; (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
(setq ok T)
(setq ss nil)
)
)
)
(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
ok T
)
)
(if ok
(progn (setq circle nil)
(setq ven (vlax-ename->vla-object ent))
(if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
(progn (if (= (vla-get-clipped ven) :vlax-false)
(progn ; not clipped
(vla-getboundingbox ven 'vpbl 'vpur)
(setq vpbl (trans (vlax-safearray->list vpbl) 3 2)
msbl (trans vpbl 2 1)
msbl (trans msbl 1 0)
vpur (trans (vlax-safearray->list vpur) 3 2)
msur (trans vpur 2 1)
msur (trans msur 1 0)
vpbr (list (car vpur) (cadr vpbl) 0)
msbr (trans vpbr 2 1)
msbr (trans msbr 1 0)
vpul (list (car vpbl) (cadr vpur) 0)
msul (trans vpul 2 1)
msul (trans msul 1 0)
plist (list (car msbl)
(cadr msbl)
(car msbr)
(cadr msbr)
(car msur)
(cadr msur)
(car msul)
(cadr msul)
)
)
)
(progn ; clipped
(setq pl (entget (dxf 340 (entget ent))))
(if (= (dxf 0 pl) "CIRCLE")
(setq circle T)
(progn (setq plist (vla-get-coordinates
(vlax-ename->vla-object (dxf -1 pl))
)
plist (vlax-safearray->list (vlax-variant-value plist))
n 0
pl nil
)
(repeat (/ (length plist) 2)
(setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
xy (trans xy 2 1)
xy (trans xy 1 0)
pl (cons (car xy) pl)
pl (cons (cadr xy) pl)
n (+ n 2)
)
)
(setq plist (reverse pl))
)
)
)
)
(if circle
(vla-AddCircle
(vla-get-ModelSpace ad)
(ax:List->VariantArray
(trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
)
(/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
)
(progn
(vla-Put-Closed
(setq npl
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
)
:vlax-True
)
)
)
)
)
)
)
)
)
(if ent
(progn
(vla-put-mspace ad :vlax-false)
(command "._pspace")
(vlax-vla-object->ename npl)
)
) ; equal
)
(defun pts_list (e / pts a b)
(setq a (vlax-curve-getstartparam e)
b (vlax-curve-getendparam e)
)
(while (<= a b)
(setq pts (cons (vlax-curve-getpointatparam e a) pts))
(if
(equal '(0 0 0) (vlax-curve-getsecondderiv e a) 1e-5)
(setq a (1+ a))
(setq a (+ 0.2 a))
)
)
pts
)
