;;-----------------------=={ Copy to Drawings }==-----------------------;;
;; ;;
;; This program enables the user to copy a selection of objects to a ;;
;; selected set of drawings, without opening the drawings in the ;;
;; AutoCAD Editor. ;;
;; ;;
;; The program will first prompt the user to make a selection of ;;
;; objects residing in the active drawing layout that are to be ;;
;; copied. Following a valid selection, the user will be prompted via ;;
;; a dialog interface to compile a list of drawings (dwg/dwt/dws) to ;;
;; which the selected objects will be copied. ;;
;; ;;
;; The program will then proceed to copy every object in the selection ;;
;; to each selected drawing using an ObjectDBX interface. ;;
;; ;;
;; The program will retain all information associated with each ;;
;; copied object, including the position, scale, rotation, etc. ;;
;; Properties such as layers & linetypes will be imported if not ;;
;; already present in the external drawing. Similarly, the drawing ;;
;; layout in which the source objects reside will be created if not ;;
;; already present in the external drawing. ;;
;; ;;
;; The program is compatible for use with all drawing objects ;;
;; (including XRefs & Dynamic Blocks) with the exception of Viewports. ;;
;; ;;
;; After copying the set of objects to each drawing, the program will ;;
;; save the external drawing. Due to a restriction on the saveas ;;
;; method when invoked through an ObjectDBX interface, all drawings ;;
;; will be saved to the native format, i.e. the latest version ;;
;; available - this is unfortunately unavoidable. ;;
;; ;;
;; Note that when saving drawings through ObjectDBX, drawing file ;;
;; thumbnails will be lost until the next manual save. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 17-05-2013 ;;
;;----------------------------------------------------------------------;;

(defun c:c2dwg ( / *error* _getitem acd app dbx doc dwl inc lst sel tab var vrs )

(defun *error* ( msg )
(if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
(vlax-release-object dbx)
)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(defun _getitem ( col itm )
(if (not (vl-catch-all-error-p (setq itm (vl-catch-all-apply 'vla-item (list col itm)))))
itm
)
)

(setq app (vlax-get-acad-object)
acd (vla-get-activedocument app)
tab (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")
)
(cond
( (not
(and
(setq sel (ssget (list '(0 . "~VIEWPORT") (cons 410 tab))))
(setq lst (LM:GetFiles "Select Drawings to Copy to" "" "dwg;dwt;dws"))
)
)
(princ "\n*Cancel*")
)
( (progn
(setq dbx
(vl-catch-all-apply 'vla-getinterfaceobject
(list (setq app (vlax-get-acad-object))
(if (vla-object (ssname sel (setq inc (1- inc)))) var))
)
(setq var
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject (cons 0 (1- (length var)))) var
)
)
)
(foreach dwg lst
(if
(or (setq doc (cdr (assoc (strcase dwg) dwl)))
(and (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list dbx dwg))))
(setq doc dbx)
)
)
(progn
(vla-copyobjects acd var
(vla-get-block
(cond
( (_getitem (vla-get-layouts doc) tab))
( (vla-add (vla-get-layouts doc) tab))
)
)
)
(vla-saveas doc dwg)
)
(princ (apply 'strcat (cons "\nUnable to interface with file: " (cdr (fnsplitl dwg)))))
)
)
(princ
(strcat "\n"
(itoa (sslength sel))
(if (= 1 (sslength sel))
" object"
" objects"
)
" copied to " (itoa (length lst))
(if (= 1 (length lst))
" drawing."
" drawings."
)
)
)
(if (= 'vla-object (type dbx))
(vlax-release-object dbx)
)
)
)
(princ)
)

;;-----------------------=={ Get Files Dialog }==-----------------------;;
;; ;;
;; An analog of the 'getfiled' function for multiple files. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Arguments: ;;
;; title - String specifying the dialog box label. ;;
;; default - Default directory; can be a null string ("") ;;
;; ext - Filename extension filter (e.g. "dwg;lsp") ;;
;;----------------------------------------------------------------------;;
;; Returns: List of selected files, else nil ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 18-04-2013 ;;
;;----------------------------------------------------------------------;;

(defun LM:GetFiles ( title default ext / *error* dch dcl des dir dirdata lst rtn )

(defun *error* ( msg )
(if (= 'file (type des))
(close des)
)
(if (and (= 'int (type dch)) (< 0 dch))
(unload_dialog dch)
)
(if (and (= 'str (type dcl)) (findfile dcl))
(vl-file-delete dcl)
)
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(if
(and
(setq dcl (vl-filename-mktemp nil nil ".dcl"))
(setq des (open dcl "w"))
(progn
(foreach x
'(
"lst : list_box"
"{"
" width = 40.0;"
" height = 20.0;"
" fixed_width = true;"
" fixed_height = true;"
" alignment = centered;"
" multiple_select = true;"
"}"
""
"but : button"
"{"
" width = 20.0;"
" height = 1.8;"
" fixed_width = true;"
" fixed_height = true;"
" alignment = centered;"
"}"
""
"getfiles : dialog"
"{"
" key = \"title\"; spacer;"
" : row"
" {"
" alignment = centered;"
" : edit_box { key = \"dir\"; label = \"Folder:\"; }"
" : button"
" {"
" key = \"brw\";"
" label = \"Browse\";"
" fixed_width = true;"
" }"
" }"
" spacer;"
" : row"
" {"
" : column"
" {"
" : lst { key = \"box1\"; }"
" : but { key = \"add\" ; label = \"Add Files\"; }"
" }"
" : column {"
" : lst { key = \"box2\"; }"
" : but { key = \"del\" ; label = \"Remove Files\"; }"
" }"
" }"
" spacer; ok_cancel;"
"}"
)
(write-line x des)
)
(setq des (close des))
(lst (strcase ext) ";"))
(set_tile "title" (if (= "" title) "Select Files" title))
(set_tile "dir"
(setq dir
(LM:getfiles:fixdir
(if (or (= "" default) (not (vl-file-directory-p (LM:getfiles:fixdir default))))
(getvar 'dwgprefix)
default
)
)
)
)
(setq lst (LM:getfiles:updatefilelist dir ext nil))
(mode_tile "add" 1)
(mode_tile "del" 1)

(action_tile "brw"
(vl-prin1-to-string
'(if (setq tmp (LM:getfiles:browseforfolder "" nil 512))
(setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir tmp)) ext rtn)
rtn (LM:getfiles:updateselected dir rtn)
)
)
)
)

(action_tile "dir"
(vl-prin1-to-string
'(if (= 1 $reason)
(setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir (LM:getfiles:fixdir $value))) ext rtn)
rtn (LM:getfiles:updateselected dir rtn)
)
)
)
)

(action_tile "box1"
(vl-prin1-to-string
'(
(lambda ( / itm tmp )
(setq itm (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" $value ")"))))
(if (= 4 $reason)
(cond
( (equal '("..") itm)
(setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir (LM:getfiles:updir dir))) ext rtn)
rtn (LM:getfiles:updateselected dir rtn)
)
)
( (and
(not (vl-filename-extension (car itm)))
(vl-file-directory-p (setq tmp (LM:getfiles:checkredirect (strcat dir "\\" (car itm)))))
)
(setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir tmp)) ext rtn)
rtn (LM:getfiles:updateselected dir rtn)
)
)
( (setq rtn (LM:getfiles:sort (append rtn (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)))
rtn (LM:getfiles:updateselected dir rtn)
lst (LM:getfiles:updatefilelist dir ext rtn)
)
)
)
(if (vl-some 'vl-filename-extension itm)
(mode_tile "add" 0)
)
)
)
)
)
)

(action_tile "box2"
(vl-prin1-to-string
'(
(lambda ( / itm )
(setq itm (mapcar '(lambda ( n ) (nth n rtn)) (read (strcat "(" $value ")"))))
(if (= 4 $reason)
(setq rtn (LM:getfiles:updateselected dir (vl-remove (car itm) rtn))
lst (LM:getfiles:updatefilelist dir ext rtn)
)
(mode_tile "del" 0)
)
)
)
)
)

(action_tile "add"
(vl-prin1-to-string
'(
(lambda ( / itm )
(if
(setq itm
(vl-remove-if-not 'vl-filename-extension
(mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" (get_tile "box1") ")")))
)
)
(setq rtn (LM:getfiles:sort (append rtn (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)))
rtn (LM:getfiles:updateselected dir rtn)
lst (LM:getfiles:updatefilelist dir ext rtn)
)
)
(mode_tile "add" 1)
(mode_tile "del" 1)
)
)
)
)

(action_tile "del"
(vl-prin1-to-string
'(
(lambda ( / itm )
(if (setq itm (read (strcat "(" (get_tile "box2") ")")))
(setq rtn (LM:getfiles:updateselected dir (LM:getfiles:removeitems itm rtn))
lst (LM:getfiles:updatefilelist dir ext rtn)
)
)
(mode_tile "add" 1)
(mode_tile "del" 1)
)
)
)
)

(if (zerop (start_dialog))
(setq rtn nil)
)
)
)
(*error* nil)
rtn
)

(defun LM:getfiles:listbox ( key lst )
(start_list key)
(foreach x lst (add_list x))
(end_list)
lst
)

(defun LM:getfiles:listfiles ( dir ext lst )
(vl-remove-if '(lambda ( x ) (member (strcat dir "\\" x) lst))
(cond
( (cdr (assoc dir dirdata)))
( (cdar
(setq dirdata
(cons
(cons dir
(append
(LM:getfiles:sortlist (vl-remove "." (vl-directory-files dir nil -1)))
(LM:getfiles:sort
(if (member ext '(("") ("*")))
(vl-directory-files dir nil 1)
(vl-remove-if-not
(function
(lambda ( x / e )
(and
(setq e (vl-filename-extension x))
(setq e (strcase (substr e 2)))
(vl-some '(lambda ( w ) (wcmatch e w)) ext)
)
)
)
(vl-directory-files dir nil 1)
)
)
)
)
)
dirdata
)
)
)
)
)
)
)

(defun LM:getfiles:checkredirect ( dir / itm pos )
(cond
( (vl-directory-files dir)
dir
)
( (and
(= (strcase (getenv "UserProfile"))
(strcase (substr dir 1 (setq pos (vl-string-position 92 dir nil t))))
)
(setq itm
(cdr
(assoc (substr (strcase dir t) (+ pos 2))
'(
("my documents" . "Documents")
("my pictures" . "Pictures")
("my videos" . "Videos")
("my music" . "Music")
)
)
)
)
(vl-file-directory-p (setq itm (strcat (substr dir 1 pos) "\\" itm)))
)
itm
)
( dir )
)
)

(defun LM:getfiles:sort ( lst )
(apply 'append
(mapcar 'LM:getfiles:sortlist
(vl-sort
(LM:getfiles:groupbyfunction lst
(lambda ( a b / x y )
(and
(setq x (vl-filename-extension a))
(setq y (vl-filename-extension b))
(= (strcase x) (strcase y))
)
)
)
(function
(lambda ( a b / x y )
(and
(setq x (vl-filename-extension (car a)))
(setq y (vl-filename-extension (car b)))
(< (strcase x) (strcase y))
)
)
)
)
)
)
)

(defun LM:getfiles:sortlist ( lst )
(mapcar (function (lambda ( n ) (nth n lst)))
(vl-sort-i (mapcar 'LM:getfiles:splitstring lst)
(function
(lambda ( a b / x y )
(while
(and
(setq x (car a))
(setq y (car b))
(= x y)
)
(setq a (cdr a)
b (cdr b)
)
)
(cond
( (null x) b)
( (null y) nil)
( (and (numberp x) (numberp y)) (< x y))
( (= "." x))
( (numberp x))
( (numberp y) nil)
( (string
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (= 92 b)
(list 32 34 92 b 34 32)
)
( (or (< 47 b 58)
(and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
(and (= 46 b) (< 47 a 58) (list (strcase str))
)
)

(defun LM:getfiles:browseforfolder ( msg dir flg / err fld pth shl slf )
(setq err
(vl-catch-all-apply
(function
(lambda ( / app hwd )
(if (setq app (vlax-get-acad-object)
shl (vla-getinterfaceobject app "shell.application")
hwd (vl-catch-all-apply 'vla-get-hwnd (list app))
fld (vlax-invoke-method shl 'browseforfolder (if (vl-catch-all-error-p hwd) 0 hwd) msg flg dir)
)
(setq slf (vlax-get-property fld 'self)
pth (vlax-get-property slf 'path)
pth (vl-string-right-trim "\\" (vl-string-translate "/" "\\" pth))
)
)
)
)
)
)
(if slf (vlax-release-object slf))
(if fld (vlax-release-object fld))
(if shl (vlax-release-object shl))
(if (vl-catch-all-error-p err)
(prompt (vl-catch-all-error-message err))
pth
)
)

(defun LM:getfiles:full->relative ( dir path / p q )
(setq dir (vl-string-right-trim "\\" dir))
(cond
( (and
(setq p (vl-string-position 58 dir))
(setq q (vl-string-position 58 path))
(not (eq (strcase (substr dir 1 p)) (strcase (substr path 1 q))))
)
path
)
( (and
(setq p (vl-string-position 92 dir))
(setq q (vl-string-position 92 path))
(eq (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
)
(LM:getfiles:full->relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
)
( (and
(setq q (vl-string-position 92 path))
(eq (strcase dir) (strcase (substr path 1 q)))
)
(strcat ".\\" (substr path (+ 2 q)))
)
( (eq "" dir)
path
)
( (setq p (vl-string-position 92 dir))
(LM:getfiles:full->relative (substr dir (+ 2 p)) (strcat "..\\" path))
)
( (LM:getfiles:full->relative "" (strcat "..\\" path)))
)
)

(defun LM:getfiles:str->lst ( str del / pos )
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos) (LM:getfiles:str->lst (substr str (+ pos 1 (strlen del))) del))
(list str)
)
)

(defun LM:getfiles:updatefilelist ( dir ext lst )
(LM:getfiles:listbox "box1" (LM:getfiles:listfiles dir ext lst))
)

(defun LM:getfiles:updateselected ( dir lst )
(LM:getfiles:listbox "box2" (mapcar '(lambda ( x ) (LM:getfiles:full->relative dir x)) lst))
lst
)

(defun LM:getfiles:updir ( dir )
(substr dir 1 (vl-string-position 92 dir nil t))
)

(defun LM:getfiles:fixdir ( dir )
(vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

(defun LM:getfiles:removeitems ( itm lst / idx )
(setq idx -1)
(vl-remove-if '(lambda ( x ) (member (setq idx (1+ idx)) itm)) lst)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
(strcat
" "

""
""
)
)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;

;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(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 c:cvd (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ)
(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"))))
(progn (setq ent (ssname ss 0))
(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)))
)
(vla-Put-Closed
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
:vlax-True
)
)
)
)
)
)
)
)
(if ss
(vla-put-mspace ad :vlax-false)
) ; equal (command "._pspace"))
(princ)
(command "_copyclip" "c" vpbl vpur "")
;(command "._pspace")
)
(c:cvd)
(command "script" "c2dwg.scr")

;(command "_copybase"(pause)(pause)"")

************************ c2dwg.scr ****************************

c2dwg
p

(command "._pspace")
(command "_copybase"(pause)(pause)"")

Advertisements