;;; ************************************************************************
;;; ***;;;
;;; vlex-vlisp.lsp ;;;
;;; assorted visual lisp activex extention functions for autocad 2004
;;; ;;;
;;; copyright (c)2003 kama whaley, all rights reserved. ;;;
;;; some functional code adapted from public sources. ;;;
;;; latest modify date : friday 27th december 2003 ;;;
;;; ************************************************************************
;;; ***;;;
;;; version 2004 1.00 12/2003: initial release (compile to vlx) ;;;
;;; ************************************************************************
;;; ***;;;
(vl-load-com)
;;; load activex support in visual lisp
;;; *********************** < first session >
;;; ***********************;;;
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-acadobject () ;;;
;;; description: returns com handle to application object ;;;
;;; args: none ;;;
;;; example: (vlex-acadobject) returns activex object ;;;
;;; ************************************************************************
;;; ***;;;
(setq *acad-object* nil)
;;; initialize global variable
(defun vlex-acadobject ()
(cond
(*acad-object*) ; return the cached object
(t
(setq *acad-object* (vlax-get-acad-object))
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-activedocument () ;;;
;;; description: returns active document object from application object
;;; ;;;
;;; args: none ;;;
;;; example: (vlex-activedocument) returns activex object ;;;
;;; ************************************************************************
;;; ***;;;
(setq *vlex-activedocument* nil)
;;; initialize global variable
(defun vlex-activedocument ()
(cond
(*vlex-activedocument*) ; return the cached object
(t
(setq *vlex-activedocument* (vla-get-activedocument
(vlex-acadobject)
)
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-modelspace () ;;;
;;; description: returns vlex-modelspace collection object of active
;;; document ;;;
;;; args: none ;;;
;;; example: (vlex-modelspace) returns activex object ;;;
;;; ************************************************************************
;;; ***;;;
(setq *vlex-modelspace* nil)
;;; initialize global variable
(defun vlex-modelspace ()
(cond
(*vlex-modelspace*) ; return the cached object
(t
(setq *vlex-modelspace* (vla-get-modelspace
(vlex-activedocument)
)
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-paperspace ;;;
;;; description: returns paper-space collection object of active document
;;; ;;;
;;; args: none ;;;
;;; example: (vlex-paperspace) returns activex object ;;;
;;; ************************************************************************
;;; ***;;;
(setq *vlex-paperspace* nil)
;;; intialize global variable
(defun vlex-paperspace ()
(cond
(*vlex-paperspace*) ; return the cached object
(t
(setq *vlex-paperspace* (vla-get-paperspace
(vlex-activedocument)
)
)
)
)
)
(defun vlex-activespace ()
(if (= 1 (vlax-get-property (vlex-activedocument) 'activespace))
(vlex-modelspace)
(vlex-paperspace)
) ; endif
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-activespace-name () ;;;
;;; description: returns name(string) of current "space" ;;;
;;; (either "model" or "paper") ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-activespace-name ()
(if (= 1 (vla-get-activespace (vlex-activedocument)))
"Model"
"Paper"
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-acadprefs () ;;;
;;; description: returns acadpreferences object ;;;
;;; args: none ;;;
;;; example: (vlex-acadprefs) returns vla-object ;;;
;;; ************************************************************************
;;; ***;;;
(setq *vlex-acadprefs* nil)
;;; initialize global variable
(defun vlex-acadprefs ()
(cond
(*vlex-acadprefs*)
(t
(setq *vlex-acadprefs* (vlax-get-property (vlex-acadobject)
'preferences
)
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-getprefkey (tabname keyname) ;;;
;;; description: returns value of specified preferences setting ;;;
;;; args: tabname(string), keyname(string) ;;;
;;; example: (vlex-getprefkey 'files 'supportpath) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-getprefkey (tabname keyname)
(vlax-get-property (vlax-get-property (vlex-acadprefs) tabname) keyname)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-setprefkey (tabname keyname new-value)
;;; ;;;
;;; description: modifies preferences setting with new value
;;; ;;;
;;; args: tabname(string), keyname(string), new-value(varies)
;;; ;;;
;;; example: (vlex-setprefkey "opensave" "incrementalsavepercent" 0)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-setprefkey (tabname keyname newval)
(vlax-put-property (vlax-get-property (vlex-acadprefs) tabname) keyname
newval
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-acadprop (propname) ;;;
;;; description: returns value of acad-object property ;;;
;;; args: propname(string) ;;;
;;; example: (vlex-acadprop 'fullname) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-acadprop (propname)
(vlax-get-property (vlex-acadobject) propname)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-name (obj) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: (vlex-name (vlex-acadobject)) returns "autocad" ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-name (obj)
(if (vlax-property-available-p obj 'name)
(vlax-get-property obj 'name)
"<NONE_NAME>"
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-getdocscollection ;;;
;;; description: returns the documents collection object ;;;
;;; args: none ;;;
;;; example:
;;; ************************************************************************
;;; ***;;;
(defun vlex-getdocscollection ()
(vlex-acadcollection "Documents")
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-acadcollection (name) ;;;
;;; description: return a root collection of the acadapplication object
;;; ;;;
;;; args: ;;;
;;; example:
;;; ************************************************************************
;;; ***;;;
(defun vlex-acadcollection (cname)
(vlax-get-property (vlex-acadobject) cname)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-docscount () ;;;
;;; description: returns the count of the documents collection ;;;
;;; args: none ;;;
;;; example: (setq numdocsopen (vlex-docscount)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-docscount ()
(vlex-collectioncount (vlex-getdocscollection))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-collectioncount (collection) ;;;
;;; description: return the count of a given collection object ;;;
;;; args: collection-object ;;;
;;; example: (setq laycount (vlex-collectioncount (vlex-getlayers)))
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-collectioncount (collection)
(vlax-get-property collection 'count)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-docslist (verbose) ;;;
;;; description: returns a list of all opened document names ;;;
;;; args: verbose<boolean> ;;;
;;; example: (setq alldocs (vlex-docslist t)) ;;;
;;; notes: verbose returns full path+filename for each document in the list
;;; ;;;
;;; if set to t (true), otherwise only the filenames are returned.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-docslist (verbose / docname out)
(setq out '())
(vlax-for each (vlex-getdocscollection) (if verbose
(setq docname (strcat
(vlax-get-property each 'path)
"\\"
(vlex-name each)
)
)
(setq docname
(vlex-name each)
)
) ; endif
(setq out (cons docname out))
)
(reverse out)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-dumpit ;;;
;;; description: dump all methods and properties for selected objects
;;; ;;;
;;; args: none ;;;
;;; examples:
;;; ************************************************************************
;;; ***;;;
(defun vlex-dumpit (/ ent)
(while (setq ent (entsel))
(vlax-dump-object (vlax-ename->vla-object (car ent)))
)
(princ)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-get____ () ;;;
;;; description: various collection functions to return collection objects
;;; ;;;
;;; args: none ;;;
;;; example: (setq colllayers (vlex-getlayers)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-getlayers ()
(vlex-doccollection 'layers)
)
(defun vlex-getltypes ()
(vlex-doccollection 'linetypes)
)
(defun vlex-gettextstyles ()
(vlex-doccollection 'textstyles)
)
(defun vlex-getdimstyles ()
(vlex-doccollection 'dimstyles)
)
(defun vlex-getlayouts ()
(vlex-doccollection 'layouts)
)
(defun vlex-getdictionaries ()
(vlex-doccollection 'dictionaries)
)
(defun vlex-getblocks ()
(vlex-doccollection 'blocks)
)
(defun vlex-getplotconfigs ()
(vlex-doccollection 'plotconfigurations)
)
(defun vlex-getviews ()
(vlex-doccollection 'views)
)
(defun vlex-getviewports ()
(vlex-doccollection 'viewports)
)
(defun vlex-getgroups ()
(vlex-doccollection 'groups)
)
(defun vlex-getregapps ()
(vlex-doccollection 'registeredapplications)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-doccollection (name) ;;;
;;; description: return a collection from the vlex-activedocument object
;;; ;;;
;;; args: collection-name(string or quote) ;;;
;;; example: (setq all-ltypes (vlex-doccollection 'linetypes)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-doccollection (cname)
(vlax-get-property (vlex-activedocument) cname)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-listcollectionmembernames (collection) ;;;
;;; description: return list of all collection member names ;;;
;;; args: collection<object> ;;;
;;; example: (vlex-list-collection-member-names (vlex-getlayers)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listcollectionmembernames (collection / itemname out)
(setq out '())
(vlax-for each collection (setq itemname (vlex-name each)
out (cons itemname out)
)
)
(reverse out)
)
;;; ************************************************************************
;;; ***;;;
;;; list collection member names ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listltypes ()
(vlex-listcollectionmembernames (vlex-getltypes))
)
(defun vlex-listlayers ()
(vlex-listcollectionmembernames (vlex-getlayers))
)
(defun vlex-listtextstyles ()
(vlex-listcollectionmembernames (vlex-gettextstyles))
)
(defun vlex-listdimstyles ()
(vlex-listcollectionmembernames (vlex-getdimstyles))
)
(defun vlex-listlayouts ()
(vlex-listcollectionmembernames (vlex-getlayouts))
)
(defun vlex-listdictionaries ()
(vlex-listcollectionmembernames (vlex-getdictionaries))
)
(defun vlex-listblocks ()
(vlex-listcollectionmembernames (vlex-getblocks))
)
(defun vlex-listplotconfigs ()
(vlex-listcollectionmembernames (vlex-getplotconfigs))
)
(defun vlex-listviews ()
(vlex-listcollectionmembernames (vlex-getviews))
)
(defun vlex-listviewports ()
(vlex-listcollectionmembernames (vlex-getviewports))
)
(defun vlex-listgroups ()
(vlex-listcollectionmembernames (vlex-getgroups))
)
(defun vlex-listregapps ()
(vlex-listcollectionmembernames (vlex-getregapps))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-countltypes () ;;;
;;; description: returns the count of the linetypes collection ;;;
;;; args: none ;;;
;;; example: (setq numltypes (vlex-countltypes)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-countltypes ()
(vlex-collectioncount (vlex-getltypes))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-acadcollection (name) ;;;
;;; description: return a root collection of the acadapplication object
;;; ;;;
;;; args:
;;; example:
;;; ************************************************************************
;;; ***;;;
(defun vlex-acadcollection (cname)
(vlax-get-property (vlex-acadobject) cname)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-sortpoints (points-list sortfield) ;;;
;;; description: sorts a list of point-list on x, y or z coordinates
;;; ;;;
;;; args: list of points (lists), sortfield(char "x", "y" or "z") ;;;
;;; example: (vlex-sortpoints mypoints "y") sorts on y-coord values
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-sortpoints (points-list xyz)
(setq xyz (strcase xyz))
(cond
((= xyz "Z") ; 3-point lists required!
(if (apply
'=
(mapcar
'(lambda (lst)
(length lst)
)
points-list
)
)
(vl-sort points-list (function (lambda (p1 p2)
(< (caddr p1) (caddr p2))
)
)
)
(princ "nCannot sort on Z-coordinates with 2D points!")
) ; endif
) ;
((= xyz "X")
(vl-sort points-list (function (lambda (p1 p2)
(< (car p1) (car p2))
)
)
)
) ;
((= xyz "Y")
(vl-sort points-list (function (lambda (p1 p2)
(< (cadr p1) (cadr p2))
)
)
)
) ;
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-collectionlist (collection) ;;;
;;; description: return a list of collection member names ;;;
;;; args: collection<object> ;;;
;;; example: (vlex-collectionlist (vlex-getltypes)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-collectionlist (collection / name out)
(setq out '())
(vlax-for each collection (setq name (vlex-name each))
(setq out (cons name out))
)
(reverse out)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-dumpcollection (collection) ;;;
;;; description: display methods and properties for each collection member
;;; ;;;
;;; args: collection<object> ;;;
;;; example: (vlex-dumpcollection (vlex-getlayers)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-dumpcollection (collection)
(vlex-mapcollection collection 'vlax-dump-object)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-mapcollection (collection function-expression) ;;;
;;; description: apply a function to all members of a given collection
;;; ;;;
;;; args: collection(vla-object), function ;;;
;;; example: (vlex-mapcollection all-arcs 'vlex-deleteobject) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-mapcollection (collection qfunction)
(vlax-map-collection collection qfunction)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-deleteobject (object) ;;;
;;; description: invokes the delete method on a given object to erase it
;;; ;;;
;;; args: object ;;;
;;; example: (vlex-deleteobject arc-object1) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-deleteobject (obj)
(princ "n***DeleteObject")
(cond
((and
(not (vlax-erased-p obj))
(vlax-read-enabled-p obj)
(vlax-write-enabled-p obj)
)
(vlax-invoke-method obj 'delete)
(if (not (vlax-object-released-p obj))
(vlax-release-object obj)
)
) ;
(t
(princ "nCannot delete object!")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-makeobject (object-or-ename) ;;;
;;; description: converts an ename type into a vla-object ;;;
;;; args: ename-or-object ;;;
;;; example: (setq myobj (vlex-makeobject (car (entsel))) ) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-makeobject (entname)
(cond
((= (type entname) 'ename)
(vlax-ename->vla-object entname)
)
((= (type entname) 'vla-object)
entname
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-objecttype (object) ;;;
;;; description: returns objectname value for given object ;;;
;;; args: object ;;;
;;; example: (= "acdbarc" (vlex-objecttype myobject)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-objecttype (obj)
(vlax-get-property obj 'objectname)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-undobegin () ;;;
;;; description: begins an undo-make group ;;;
;;; args: none ;;;
;;; example: (vlex-undobegin) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-undobegin ()
(vlax-invoke-method (vlex-activedocument) 'startundomark)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-undoend () ;;;
;;; description: closes an undo group ;;;
;;; args: none ;;;
;;; example: (vlex-undoend) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-undoend ()
(vlax-invoke-method (vlex-activedocument) 'endundomark)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-copyprop (property source-obj target-obj) ;;;
;;; description: copy named property from one object to another ;;;
;;; args: property(string or quotedval), source(object), target(object)
;;; ;;;
;;; example: (vlex-copyprop "layer" arc-object1 arc-object2) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-copyprop (propname source target)
(cond
((member (strcase propname) '("LAYER" "LINETYPE"
"COLOR" "LINETYPESCALE"
"LINEWEIGHT" "PLOTSTYLENAME"
"ELEVATION" "THICKNESS"
)
)
(cond
((and
(not (vlax-erased-p source)) ; source not erased?
(not (vlax-erased-p target)) ; target not erased?
(vlax-read-enabled-p source) ; can read from source object?
(vlax-write-enabled-p target) ; can write to target object?
)
(vlax-put-property target propname (vlax-get-property source
propname
)
)
) ;
(t
(princ "nOne or more objects inaccessible!")
)
) ; cond
) ;
(t
(princ "nInvalid property-key request!")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-mappropertylist (properties source-obj target-obj)
;;; ;;;
;;; descriiption: copies a list of properties from one object to another
;;; ;;;
;;; args: properties(list), source(object), target(object) ;;;
;;; example: (vlex-mappropertylist '("layer" "color") arc-object1
;;; arc-object2 ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-mappropertylist (proplist source target)
(foreach prop proplist
(vlex-copyprop prop source target)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profileimport (profile-name arg-file) ;;;
;;; description: imports arg file as new profile ;;;
;;; args: profile-name(string), arg-file(string) ;;;
;;; example: (vlex-profileimport "myprofile" "c:/test.arg") ;;;
;;; ************************************************************************
;;; ***;;;
;;; vba equivalent: ;;;
;;; thisdrawing.application.preferences._ ;;;
;;; profiles.importprofile _ ;;;
;;; strprofiletoimport, strargfilesource, true ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profileimport (pname argfile)
(cond
((findfile argfile)
(vlax-invoke-method (vlax-get-property (vlex-acadprefs) "Profiles")
'importprofile pname argfile
(vlax-make-variant 1 :vlax-vbboolean) ; == true
)
) ;
(t
(princ "nARG file not found to import!")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profileexport (arg-file profile-name t ) ;;;
;;; description: ;;;
;;; args: arg-file(string), profile-name(string), t(boolean) ;;;
;;; example: (vlex-profileimport "myprofile" "c:/test.arg" t) ;;;
;;; ************************************************************************
;;; ***;;;
;;; notes: ;;;
;;; exports the active profile so it can be shared with other users.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profileexport (strname strfilename boolereplace)
(if (vlex-profileexists-p strname)
(if (not (findfile strfilename))
(progn
(vlax-invoke-method (vlax-get-property (vlex-acadprefs) "Profiles")
'exportprofile strname strfilename
)
t ; return true
)
(if boolereplace
(progn
(vl-file-delete (findfile strfilename))
(if (not (findfile strfilename))
(progn
(vlax-invoke-method (vlax-get-property
(vlex-acadprefs)
"Profiles"
) 'exportprofile strname strfilename
)
t ; return true
) ; progn
(princ "nCannot replace ARG file, aborted.")
) ; endif
) ; progn
(princ (strcat "n" strfilename " already exists, aborted."))
) ; endif
) ; endif
) ; endif
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profiledelete (profile-name) ;;;
;;; description: deletes a profile from the acadapplication object
;;; ;;;
;;; args: profile-name(string) ;;;
;;; example: (vlex-profiledelete "myprofile") ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profiledelete (pname)
(vlax-invoke-method (vlax-get-property (vlex-acadprefs) "Profiles")
'deleteprofile pname
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profileexists-p (profile-name) ;;;
;;; description: boolean test for profile existence ;;;
;;; args: profile-name(string) ;;;
;;; example: (if (vlxx-profileexists-p "myprofile") ...) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profileexists-p (pname) ; search for caps profile-name in
; caps list of profiles
(not (not (member (strcase pname) (mapcar
'strcase
(vlex-profilelist)
)
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profilelist () ;;;
;;; description: returns a list of all profile ;;;
;;; args: none ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profilelist (/ hold)
(vlax-invoke-method (vlax-get-property (vlex-acadprefs) "Profiles")
'getallprofilenames 'hold
)
(if hold
(vlax-safearray->list hold)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-closealldocs ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; closes all open documents without saving ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-closealldocs (/ item cur)
(vlax-for item (vla-get-documents (vlex-acadobject)) (if (=
(vla-get-active item)
:vlax-false
)
(vla-close item :vlax-false)
(setq cur item)
)
)
(vla-sendcommand cur "_.CLOSE")
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-savealldocs ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; saves all open documents without saving ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-savealldocs (/ item cur)
(vlax-for item (vla-get-document (vlex-acadobject)) (vla-save item))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-saved-p () ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; tests to determine if the active document is saved ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-saved-p ()
(= (vla-get-saved (vlex-activedocument)) :vlax-true)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-saveas... ;;;
;;; description: save the activedocument in different acsaveastype
;;; ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; saveastype acsaveastype enum; read-write
;;;
;;; acr12_dxf
;;; autocad release12/lt2 dxf (*.dxf)
;;;
;;; ac2000_dwg
;;; autocad 2000 dwg (*.dwg)
;;;
;;; ac2000_dxf
;;; autocad 2000 dxf (*.dxf)
;;;
;;; ac2000_template
;;; autocad 2000 drawing template file (*.dwt)
;;;
;;; ac2004_dwg
;;; autocad 2004 dwg (*.dwg)
;;;
;;; ac2004_dxf
;;; autocad 2004 dxf (*.dxf)
;;;
;;; ac2004_template
;;; autocad 2004 drawing template file (*.dwt)
;;;
;;; acnative
;;; a synonym for the current drawing release format. if you want your
;;; application to save the drawing in the format of whatever version of
;;; autocad the application is running on, then use the acnative format.
;;;
;;; acunknown
;;; read-only. the drawing type is unknown or invalid.
(defun vlex-saveas2000 (name)
(vla-saveas (vlex-activedocument) name acr15_dwg)
)
(defun vlex-saveasr14 (name)
(vla-saveas (vlex-activedocument) name acr14_dwg)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-purgealldocs ;;;
;;; description: purges all documents currently opened. ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-purgealldocs (/ item cur)
(vlax-for item (vla-get-document (vlex-acadobject)) (vla-purgeall item))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-changeattributes (lst) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: (vlex-changeattributes (list blk (cons "tag" "new-value")))
;;; ;;;
;;; ************************************************************************
;;; ***;;;
;;; arguments:
;;; a list containing one atom and one or more dotted pairs.
;;; the atom is the entity name of the block to change.
;;; the dotted pairs consist of the attribute tag and the new value for
;;; that attribute.
;;;
;;; notes:
;;; modifies the specified attribute in the specified block reference
;;; ************************************************************************
;;; ***;;;
(defun vlex-changeattributes (lst / blk itm atts)
(setq blk (vlax-ename->vla-object (car lst))
lst (cdr lst)
)
(if (= (vla-get-hasattributes blk) :vlax-true)
(progn
(setq atts (vlax-safearray->list (vlax-variant-value
(vla-getattributes blk)
)
)
) ; setq
(foreach item lst
(mapcar
'(lambda (x)
(if (= (strcase (car item)) (strcase
(vla-get-tagstring x)
)
)
(vla-put-textstring x (cdr item))
) ; endif
)
atts
) ; mapcar
) ; foreach
(vla-update blk)
)
) ; endif
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-getattributes (ent) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; arguments
;;; the entity name of an attributed block
;;;
;;; example
;;; (ax::getattributes (car (entsel)))
;;; returns a list of attribute tags and associated values
;;; ************************************************************************
;;; ***;;;
(defun vlex-getattributes (ent / blkref lst)
(if (= (vla-get-objectname (setq blkref (vlax-ename->vla-object ent)))
"AcDbBlockReference"
)
(if (vla-get-hasattributes blkref)
(mapcar
'(lambda (x)
(setq lst (cons (cons (vla-get-tagstring x)
(vla-get-textstring x)
) lst
)
)
)
(vlax-safearray->list (vlax-variant-value
(vla-getattributes blkref)
)
)
) ; mapcar
) ; endif
) ; endif
(reverse lst)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-parsestring (str delim) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; arguments
;;; a delimited string and the delimiter character.
;;;
;;; example:
;;; (vlex-parsestring (getenv "acad") ";")
;;;
;;; notes:
;;; autolisp does not correctly interpret any character code outside the
;;; range of
;;; 1 to 255, so you cannot parse a null-delimited string.
;;; returns a list containing all tokens in a delimited string
;;; ************************************************************************
;;; ***;;;
(defun vlex-parsestring (str delim / lst pos token)
(setq pos (vl-string-search delim str))
(while pos
(setq lst (cons (if (= (setq token (substr str 1 pos))
delim
)
nil
token
) ; endif
lst
)
str (subst
str
(+ (strlen delim) pos 1)
)
pos (vl-string-search delim str)
) ; setq
) ; while
(if (> (strlen str) 0)
(setq lst (cons str lst))
)
(reverse lst)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-polycentroid (poly) ;;;
;;; description: ;;;
;;; args: poly(entity name) ;;;
;;; example:
;;; ************************************************************************
;;; ***;;;
;;; arguments:
;;; the entity name of a closed, planar polyline
;;;
;;; example:
;;; (ax:centroid (car (entsel)))
;;;
;;; returns the centroid of a closed polyline
;;; thanks to tony t for the original concept
;;; ************************************************************************
;;; ***;;;
(defun vlex-polycentroid (poly / pl ms va reg cen)
(setq pl (vlax-ename->vla-object poly)
ms (vlex-modelspace)
va (vlax-make-safearray vlax-vbobject '(0 . 0))
)
(vlax-safearray-put-element va 0 pl)
(setq reg (car (vlax-safearray->list (vlax-variant-value
(vla-addregion ms va)
)
)
)
cen (vla-get-centroid reg)
)
(vla-delete reg)
(vlax-safearray->list (vlax-variant-value cen))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-massoc ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; originally written by tony tanzillo
;;; returns a list containing cdrs for every occurence of key in alist
;;; arguments:
;;; an integer and an entity definition list
;;;
;;; usage:
;;; (vlex-massoc 10 (entget (car (entsel))))
;;;
;;; notes:
;;; this is especially useful for retrieving all points associated with a
;;; lightweight polyline.
;;; ************************************************************************
;;; ***;;;
(defun vlex-massoc (key alist)
(apply
'append
(mapcar
'(lambda (x)
(if (eq (car x) key)
(list (cdr x))
)
)
alist
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-extents ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; originally written by tony tanzillo
;;; returns a list containing the min and max points
;;;
;;; arguments
;;; a list with three or more points
;;;
;;; example
;;; (vlex-extents '((1 0 0) (2 2 0) (1 2 0)))
;;; ************************************************************************
;;; ***;;;
(defun vlex-extents (plist /)
(list (apply
'mapcar
(cons 'min plist)
) (apply
'mapcar
(cons 'max plist)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-rectcenter ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; returns the "center" of a rectangle
;;;
;;; arguments
;;; the entity name of a rectangle
;;;
;;; example
;;; (vlex-rectcenter (car (entsel)))
;;; ************************************************************************
;;; ***;;;
(defun vlex-rectcenter (rec)
(vlex-mid (vlex-extents (vlex-massoc 10 (entget rec))))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-mid (pts) ;;;
;;; descriptoin: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; originally written by michael weaver
;;; returns the point midway between two others
;;;
;;; arguments
;;; a list of two points
;;;
;;; example
;;; (mid '((1 1 0) (5 5 0)))
;;; ************************************************************************
;;; ***;;;
(defun vlex-mid (pts / p0 p1)
(setq p0 (nth 0 pts)
p1 (nth 1 pts)
)
(mapcar
'(lambda (ord1 ord2)
(/ (+ ord1 ord2) 2.0)
)
p0
p1
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-getpolysegment (poly pt) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example:
;;; ************************************************************************
;;; ***;;;
;;; returns a list containing the endpoints of the selected lwpoly segment
;;; ;;;
;;; thanks to tony tanzillo for showing me how to improve my routine
;;; ;;;
;;;
;;; arguments:
;;; the entity name of an lwpolyline and the point at which it was selected
;;;
;;; example:
;;; (apply 'getseg (entsel))
;;; ************************************************************************
;;; ***;;;
(defun vlex-getpolysegment (poly pt / pts i)
(setq pts (vlex-massoc 10 (entget poly))
i (caddar (ssnamex (ssget pt)))
)
(list (nth (1- i) pts) (if (and
(vlex-isclosed poly)
(= i (length pts))
)
(car pts)
(nth i pts)
) ; endif
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-isclosed (pl) ;;;
;;; description: specifies whether the 3d polyline, lightweight polyline,
;;; ;;;
;;; polyline, or spline is open or closed. ;;;
;;; args: the entity name of an lwpolyline, polyline, or spline. ;;;
;;; example: (vlex-isclosed (car (entsel))) ;;;
;;; ************************************************************************
;;; ***;;;
;;; returns:
;;; t if the object has the specified 'closed and it is really closed;
;;; nil, if the object hasn't the 'closed property.
;;; ************************************************************************
;;; ***;;;
(defun vlex-isclosed (epl / vpl)
(setq vpl (vlex-makeobject epl))
(if (vlax-property-available-p vpl 'closed)
(= (vlax-get-property vpl 'closed) :vlax-true)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; example function that convert arc objects into circle objects by first
;;; ;;;
;;; creating a circle in place of the arc and then inheriting the various
;;; ;;;
;;; properties of the arc before deleting the arc itself. ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-closearc (/ arcent arcobj trapobj circ)
(while (setq arcent (entsel "nSelect ARC object: "))
(setq arcobj (vlex-makeobject (car arcent)))
(cond
((= "AcDbArc" (vlex-objecttype arcobj))
(vlex-undobegin)
(setq circ (vla-addcircle (vlex-modelspace) (vla-get-center arcobj)
(vla-get-radius arcobj)
)
)
(vlex-mappropertylist '("Layer" "Color"
"Thickness" "Linetype"
"LinetypeScale"
) arcobj circ
)
(vlex-deleteobject arcobj)
(vlax-release-object circ)
(vlex-undoend)
) ;
(t
(princ "nNot an ARC object, try again...")
)
) ; cond
) ; endwhile
(princ)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-ltype-exists-p (strltype) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: (vlex-ltype-exists-p "dashed") ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-ltype-exists-p (strltype)
(cond
((member (strcase strltype) (mapcar
'strcase
(vlex-listltypes)
)
)
t
) ;
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-apply-ltype (obj strltype) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: (vlex-apply-ltype cirobj "dashed") ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-apply-ltype (obj strltype / entlist)
(cond
((vlex-ltype-exists-p strltype)
(cond
((and
(vlax-read-enabled-p obj) ; object can be read from
(vlax-write-enabled-p obj) ; object can be modified
)
(vla-put-linetype obj strltype)
t ; return true
) ;
(t
(princ "nVlex-Apply-Ltype: Unable to modify object!")
)
)
) ;
(t
(princ (strcat "nVlex-Apply-Ltype: Linetype [" strltype
"] not loaded."
)
)
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; example: (vlex-addline (vlex-modelspace) pt1 pt2 "doors" 4 "dashed")
;;; notes: <intcolor> and <strltype> can each be 'nil'
;;; ************************************************************************
;;; ***;;;
(defun vlex-addline (startpt endpt strlayer intcolor strltype / obj)
(cond
((and
startpt
(listp startpt)
endpt
(listp endpt)
)
(setq obj (vla-addline (vlex-modelspace) (vlax-3d-point startpt)
(vlax-3d-point endpt)
)
) ; setq
(cond
((vlax-write-enabled-p obj)
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
(vla-update obj)
(vlex-mxrelease obj)
(entlast)
) ;
(t
(princ "nUnable to modify object properties...")
)
)
) ;
(t
(princ "nVlex-AddLine: Invalid parameter list...")
)
)
)
;;; defun
(defun vlex-mxrelease (obj)
(vlax-release-object obj)
)
;;; ************************************************************************
;;; ***;;;
;;; module: ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; example: (vlex-addarc (vlex-modelspace) pt1 0.5 0 90 "0" 3 "dashed")
;;; notes:
;;; <startang> and <endang> are in degree values, not radians
;;; <intcolor> and <strltype> can each be 'nil'
;;; ************************************************************************
;;; ***;;;
(defun vlex-addarc (centerpt radius startang endang strlayer intcolor
strltype / obj
)
(cond
((and
centerpt
(listp centerpt)
radius
startang
endang
)
(setq obj (vla-addarc objspace (vlax-3d-point centerpt) radius
(vlex-dtr startang) (vlex-dtr endang)
)
)
(cond
((vlax-write-enabled-p obj)
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
(vla-update obj)
(vlex-mxrelease obj)
(entlast)
) ;
(t
(princ "nUnable to modify object properties...")
)
)
) ;
(t
(princ "nVlex-AddArc: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
;;; example: (vlex-addcircle (vlex-modelspace) pt1 0.5 "0" 3 "dashed")
;;; notes: <intcolor> and <strltype> can each be 'nil'
;;; ************************************************************************
;;; ***;;;
(defun vlex-addcircle (centerpt radius strlayer intcolor strltype / obj)
(cond
((and
centerpt
(listp centerpt)
radius
)
(setq obj (vla-addcircle (vlex-modelspace) (vlax-3d-point centerpt)
radius
)
)
(cond
((vlax-write-enabled-p obj)
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
(vla-update obj)
(vlex-mxrelease obj)
(entlast)
)
(t
(princ "nUnable to modify object properties...")
)
) ; cond
) ;
(t
(princ "nVlex-AddCircle: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-dtr (a) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-dtr (a)
(* pi (/ a 180.0))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-rtd (a) ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-rtd (a)
(/ (* a 180.0) pi)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addpline (space ptlist layer closed color ltype width)
;;; ;;;
;;; description: create lwpolyline with given properties ;;;
;;; args: space, points-list, layername, closed(t or nil), <color> is
;;; ;;;
;;; integer, <ltype> is string name, <width> is double/real number
;;; ;;;
;;; exmaple: (vlex-addpline (vlex-modelspace) ptlist "0" t 3 "dashed"
;;; 0.125) ;;;
;;; notes: <bclosed> <intcolor> <dblwidth> and <strltype> can each be 'nil'
;;; ;;;
;;; which is bylayer.
;;; ************************************************************************
;;; ***;;;
(defun vlex-addpline (ptlist strlayer bclosed intcolor strltype dblwidth /
vrtcs lst plgen plist plpoints obj
)
(cond
((and
ptlist
(listp ptlist)
(listp (car ptlist))
)
(setq plist (apply
'append
(mapcar
'3dpoint->2dpoint
ptlist
)
)
plpoints (vlex-list->variantarray plist)
obj (vla-addlightweightpolyline (vlex-modelspace) plpoints)
)
(cond
((and
(vlax-read-enabled-p obj) ; if able to read
(vlax-write-enabled-p obj) ; if open for change...
)
(if bclosed
(vla-put-closed obj :vlax-true)
) ; make closed
(if strlayer
(vla-put-layer obj strlayer)
) ; apply layer
(if intcolor
(vla-put-color obj intcolor)
) ; apply color
(if dblwidth
(vla-put-constantwidth obj dblwidth)
) ; apply constant width
(if strltype ; apply linetype and linetype
; generation
(progn
(vlex-apply-ltype obj strltype) ; apply linetype
(vla-put-linetypegeneration obj :vlax-true) ; apply
; linetype-gen
)
)
(vla-update obj) ; force graphic update
(vlex-mxrelease obj)
(entlast)
) ;
(t
(princ "nVlex-AddPline: Unable to modify object!")
)
) ; cond
) ;
(t
(princ "nVlex-AddPline: Invalid parameter list....")
)
) ; cond
)
(defun 3dpoint->2dpoint (3dpt / 2dpt)
(setq 2dpt (list (car 3dpt) (cadr 3dpt)))
)
(defun 3dpoint-list->2dpoint-list (3dplist / 2dplist)
(cond
((and
3dplist
(listp 3dplist)
(listp (car 3dplist))
)
(setq 2dplist (mapcar
'(lambda (pt)
(list (car pt) (cadr pt))
)
3dplist
)
)
)
(t
(princ "n3dpoint-list->2dpoint-list: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-list->variantarray (list) ;;;
;;; description: convert a list into a vla-variant safearray date type
;;; ;;;
;;; args: list ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-dbllist->variantarray (nlist / arrayspace sarray) ; allocate
; space for an array of 2d points
; stored as doubles
(setq arrayspace (vlax-make-safearray vlax-vbdouble ; element type
(cons 0 (- (length nlist) 1))
)
)
(setq sarray (vlax-safearray-fill arrayspace nlist)) ; return array
; variant
(vlax-make-variant sarray)
)
(defun vlex-intlist->vararray (alist)
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger ; (2) integer
(cons 0 (- (length alist) 1))
) alist
)
)
(defun vlex-varlist->vararray (alist)
(vlax-safearray-fill (vlax-make-safearray vlax-vbvariant ; (12) variant
(cons 0 (- (length alist) 1))
) alist
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addlinec (ptlist bclosed strlayer intcolor strltype / pt1 ptz)
(cond
((and
ptlist
(listp ptlist)
(listp (car ptlist))
)
(setq pt1 (car ptlist) ; save first point
ptz (last ptlist) ; save last point
)
(while (and
ptlist
(>= (length ptlist) 2)
)
(vlex-addline (vlex-modelspace) (car ptlist) (cadr ptlist) strlayer
intcolor strltype
)
(setq ptlist (cdr ptlist))
)
(if (= bclosed t)
(vlex-addline (vlex-modelspace) pt1 ptz strlayer intcolor strltype)
)
) ;
(t
(princ "nMakeLineC: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-roll-ratio (angle) ;;;
;;; description: converts angle<degrees> into ratio for ellipse roll angles
;;; ;;;
;;; args: angle<degrees> ;;;
;;; example: (setq roll-ratio (vlex-roll-ratio 45.0)) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-roll-ratio (rollangle)
(cos (vlex-dtr rollangle))
)
;;; ************************************************************************
;;; ***;;;
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addellipse (space ctr hmaj roll layer color ltype)
;;; ;;;
;;; description: create ellipse object with given properties ;;;
;;; args: space centerpt hmajorpt rollangle layer color ltype ;;;
;;; example: (vlex-addellipse (vlex-modelspace) l1 p2 45 "parts" nil nil)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
;;; notes: <space> is object, <centerpt> and <hmajorpt> are point lists
;;; ;;;
;;; <roll> is degrees angle, <layer> is string name, <color> is integer,
;;; ;;;
;;; <ltype> is string name. <color> <ltype> may be 'nil' == bylayer
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addellipse (ctr hmpt roll strlayer intcolor strltype / lst obj)
(cond
((and
ctr
(listp ctr)
hmpt
(listp hmpt)
roll
)
(setq hmpt (list (- (car hmpt) (car ctr)) (- (cadr hmpt)
(cadr ctr)
)
)
obj (vla-addellipse (vlex-modelspace) (vlax-3d-point ctr)
(vlax-3d-point hmpt)
(vlex-roll-ratio roll)
)
)
(cond
((vlax-write-enabled-p obj)
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
(vla-update obj)
) ;
(t
(princ "nUnable to modify object properties...")
)
) ; cond
(mxrelease obj)
(entlast)
) ;
(t
(princ "nInvalid paprameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addellipsearc1 ;;;
;;; description: ;;;
;;; args: ;;;
;;; example: ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addellipsearc1 (ctr hmpt roll startang endang strlayer intcolor
strltype / obj rang
)
(cond
((and
ctr
(listp ctr)
hmpt
roll
)
(setq hmpt (list (- (car hmpt) (car ctr)) (- (cadr hmhp)
(cadr ctr)
)
)
obj (vla-addellipse (vlex-modelspace) (vlax-3d-point ctr)
(vlax-3d-point hmpt)
(vlex-roll->ratio roll)
)
)
(cond
((vlax-write-enabled-p obj)
(vla-put-startangle obj (vlex-dtr startang))
(vla-put-endangle obj (vlex-dtr endang))
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
(vla-update obj)
(mxrelease obj)
(entlast)
) ;
(t
(princ "nUnable to modify object properties...")
)
) ; cond
) ;
(t
(princ "nMakeArcEllipse1: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; *;;;
;;; module:
;;; ;;;
;;; description:
;;; ;;;
;;; args:
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; *;;;
(defun vlex-addellipsearc2 (ctr hmpt hmin startang endang strlayer intcolor
strltype / obj rang
)
(cond
((and
ctr
(listp ctr)
hmpt
(listp hmpt)
hmin
)
(setq hmpt (list (- (car hmpt) (car ctr)) (- (cadr hmpt)
(cadr ctr)
)
)
obj (vla-addellipse (vlex-modelspace) (vlax-3d-point ctr)
(vlax-3d-point hmpt) hmin
)
)
(cond
((vlax-write-enabled-p obj)
(vla-put-startangle obj (vlex-dtr startang))
(vla-put-endangle obj (vlex-dtr endang))
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
(vla-update obj)
(mxrelease obj)
(entlast)
) ;
(t
(princ "nUnable to modify object properties...")
)
) ; cond
) ;
(t
(princ "nMakeArcEllipse2: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module:
;;; ;;;
;;; description: returns a list consistof start point and end point of the
;;; ;;;
;;; arc, line, or ellipse. ;;;
;;; args:
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-getellipsearcpoints (ellent / ename-ellipse vlaobject-ellipse
p-start p-end out
)
(setq vlaobject-ellipse (vlex-makeobject ellent) ; convert ename to
; object
p-start (vla-get-startpoint vlaobject-ellipse)
p-end (vla-get-endpoint vlaobject-ellipse)
out (list (vlax-safearray->list (vlax-variant-value p-start))
(vlax-safearray->list (vlax-variant-value p-end))
)
)
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addpoint ;;;
;;; description: creates point object with specified properties ;;;
;;; args: point, layer ;;;
;;; example: (vlex-addpoint p1 "defpoints")
;;; ************************************************************************
;;; ***;;;
(defun vlex-addpoint (pt strlayer / obj)
(cond
((and
pt
(listp pt)
)
(setq obj (vla-addpoint (vlex-modelspace) (vlax-3d-point pt)))
(if (vlax-write-enabled-p obj)
(progn
(if strlayer
(vla-put-layer obj strlayer)
)
(vla-update obj)
(mxrelease obj)
(entlast)
)
(princ "nVlex-AddPoint: Unable to modify object!")
) ; if
) ;
(t
(princ "nVlex-AddPoint: Invalid parameter list...")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addtext ;;;
;;; description: creates text object with sepecified properties ;;;
;;; args: string, point, justification, style, hgt, wid, rot, lay, color
;;; ;;;
;;; example: (vlex-addtext "abc" p1 "mc" "standard" 0.25 1.0 0 "text" nil)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addtext (strtxt pt just strstyle dblhgt dblwid dblrot strlay
intcol / txtobj
)
(cond
((setq txtobj (vla-addtext (vlex-activespace) strtxt (if (not
(member
(strcase just)
'
("A" "F")
)
)
(vlax-3d-point pt)
(vlax-3d-point
(car pt)
)
) ; endif
dblhgt ; ignored if just = "a" (aligned)
)
)
(vla-put-stylename txtobj strstyle)
(vla-put-layer txtobj strlay)
(if intcol
(vla-put-color txtobj intcol)
)
(setq just (strcase just)) ; force to upper case for
; comparisons...
; left/align/fit/center/middle/right
; /bl/bc/br/ml/mc/mr/tl/tc/tr
; note that "left" is not a normal
; default.
;
; alignment types...
; acalignmentleft=0
; acalignmentcenter=1
; acalignmentright=2
; acalignmentaligned=3
; acalignmentmiddle=4
; acalignmentfit=5
; acalignmenttopleft=6
; acalignmenttopcenter=7
; acalignmenttopright=8
; acalignmentmiddleleft=9
; acalignmentmiddlecenter=10
; acalignmentmiddleright=11
; acalignmentbottomleft=12
; acalignmentbottomcenter=13
; acalignmentbottomright=14
;
;
; horizontal justifications...
;
; achorizontalalignmentleft=0
;
; achorizontalalignmentcenter=1
;
; achorizontalalignmentright=2
;
; achorizontalalignmentaligned=3
;
; achorizontalalignmentmiddle=4
;
; achorizontalalignmentfit=5
;
;
;
; vertical justifications...
;
; acverticalalignmentbaseline=0
;
; acverticalalignmentbottom=1
;
; acverticalalignmentmiddle=2
;
; acverticalalignmenttop=3
;
(cond
((= just "L") ; left
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "C") ; center
(vla-put-alignment txtobj 1)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "R") ; right
(vla-put-alignment txtobj 2)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "A") ; alignment
(vla-put-alignment txtobj 3)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
)
((= just "M") ; middle
(vla-put-alignment txtobj 4)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "F") ; fit
(vla-put-alignment txtobj 5)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
)
((= just "TL") ; top-left
(vla-put-alignment txtobj 6)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "TC") ; top-center
(vla-put-alignment txtobj 7)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "TR") ; top-right
(vla-put-alignment txtobj 8)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "ML") ; middle-left
(vla-put-alignment txtobj 9)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "MC") ; middle-center
(vla-put-alignment txtobj 10)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "MR") ; middle-right
(vla-put-alignment txtobj 11)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "BL") ; bottom-left
(vla-put-alignment txtobj 12)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "BC") ; bottom-center
(vla-put-alignment txtobj 13)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
((= just "BR") ; bottom-right
(vla-put-alignment txtobj 14)
(vla-put-textalignmentpoint txtobj (vlax-3d-point pt))
(vla-put-scalefactor txtobj dblwid)
(vla-put-rotation txtobj (dtr dblrot))
)
)
(vla-update txtobj)
(vlax-release-object txtobj)
(entlast)
) ;
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addpolygon ;;;
;;; description: creates a circumscribed polygon ;;;
;;; args: center, radius, sides, flag, width, layer, color, ltype ;;;
;;; example: (vlex-addpolygon pt1 1.0 6 nil 0 "0" nil "dashed")
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addpolygon (ctrpt dblrad intsides strtype dblwid strlay intcol
strltype / pa dg ptlist deg
)
(setq pa (polar ctrpt 0 dblrad)
dg (/ 360.0 intsides) ; get angles between faces
deg dg
)
(repeat intsides
(setq ptlist (if ptlist
(append
ptlist
(list (polar ctrpt (vlex-dtr deg) dblrad))
)
(list (polar ctrpt (vlex-dtr deg) dblrad))
)
)
(setq deg (+ dg deg))
) ; repeat
(vlex-addpline ptlist strlay t intcol strltype dblwid)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addrectangle ;;;
;;; description: creates a rectangle with sepecified properties ;;;
;;; args: p1(lower left), p3(upper right), layer, color, linetype, width
;;; ;;;
;;; example: (vlex-addrectangle p1 p3 "0" nil "dashed" 0.25)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addrectangle (p1 p3 strlayer intcolor strltype dblwid / p2 p4
obj
)
(setq p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(cond
((setq obj (vlex-addpline (list p1 p2 p3 p4) strlayer t intcolor
strltype dblwidth
)
)
obj ; raise object (entity name)
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-addsolid ;;;
;;; description: creates a solid with sepecified properties ;;;
;;; args: points-list, layer(string), color(integer) ;;;
;;; example: (vlex-addsolid ptlist "0" nil) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-addsolid (ptlist strlayer intcolor / plist obj)
(cond
((and
ptlist
(listp ptlist)
(listp (car ptlist))
)
(if (= (length ptlist) 3)
(setq plist (append
ptlist
(list (last ptlist))
)
)
(setq plist ptlist)
)
(vlex-dpr "nMaking solid object...")
(cond
((setq obj (vla-addsolid (vlex-activespace) (vlax-3d-point
(car plist)
)
(vlax-3d-point (cadr plist))
(vlax-3d-point (caddr plist))
(vlax-3d-point (cadddr plist))
)
)
(if strlayer
(vla-put-layer obj strlayer)
)
(if intcolor
(vla-put-color obj intcolor)
)
(vla-update obj)
(vlax-release-object obj)
(entlast)
) ;
(t
(princ "nUnable to create object...")
)
) ; cond
) ;
(t
(princ "nVlex-AddSolid: Invalid parameter list...")
)
) ; cond
)
(defun vlex-dpr (msg) ; debugging status printer
(if $dbg
(princ msg)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-apply-ltscale (object ltscale) ;;;
;;; description: apply object linetype scaling ;;;
;;; args: ename or object, scale (real) ;;;
;;; example: (vlex-apply-ltscale objline 24.0) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-apply-ltscale (obj dblltscale)
(cond
((and
(vlax-read-enabled-p obj) ; object can be read from
(vlax-write-enabled-p obj) ; object can be modified
)
(vla-put-linetype dblltscale)
t ; return true
) ;
(t
(princ "nVlex-Apply-LtScale: Unable to modify object!")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-varsave (vlist)
;;; ;;;
;;; description: save sysvars to global list for restoring later.
;;; ;;;
;;; args:
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(setq g$vars nil)
;;; initialize global variable
(defun vlex-varsave (vlist / n)
(foreach n vlist
(setq g$vars (if g$vars
(append
g$vars
(list (list n (getvar n)))
)
(list (list n (getvar n)))
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-varrestore ()
;;; ;;;
;;; description: restore sysvars from global list for restoring later.
;;; ;;;
;;; args:
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-varrestore (/ $orr #err)
(defun #err (s)
(princ (strcat "nError: " s))
(setq g$vars nil)
(setq *error* $orr)
(princ)
)
(setq $orr *error*
*error* #err
)
(cond
((and
g$vars
(listp g$vars)
)
(foreach n g$vars
(cond
((= (strcase (car n)) "CLAYER")
(command "_.layer" "_s" (cadr n) "")
)
((= (strcase (car n)) "VIEWPORT")
(command "_.viewres" "_Y" (cadr n) "")
)
(t
(setvar (car n) (cadr n))
)
) ; cond
) ; foreach
(setq g$vars nil)
)
) ; cond
(setq *error* $orr
$orr nil
)
)
;;; *********************** < second session >
;;; ***********************;;;
;;; layers -->>
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layertable ()
;;; ;;;
;;; description: get document layers collection object
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layertable ()
(vla-get-layers (vlex-activedocument))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layzero ()
;;; ;;;
;;; description: set active layer in document to zero "0"
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layzero ()
(vla-put-activelayer (vlex-activedocument) (vla-item
(vlex-layertable) 0
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layactive (name)
;;; ;;;
;;; description: set active layer to <name> if it exists
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layactive (name / iloc out)
(cond
((and
(tblsearch "layer" name)
(setq iloc (vl-position name (vlex-listlayers)))
)
(vla-put-activelayer (vlex-activedocument) (vla-item
(vlex-layertable)
iloc
)
)
(setq out name)
) ;
(t
(princ (strcat "nLayer not defined: " name))
)
) ; cond
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layeron (laylist)
;;; ;;;
;;; description: turn on all layers in given list
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layeron (laylist)
(vlax-for each (vla-get-layers (vlex-activedocument)) (if (member
(strcase
(vla-get-name each)
)
laylist
)
(if
(vlax-write-enabled-p each)
(vla-put-layeron each :vlax-true)
)
)
(vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layeroff (laylist)
;;; ;;;
;;; description: turn off all layers in given list
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layeroff (laylist)
(vlax-for each (vlex-layertable) (if (member (strcase
(vla-get-name each)
) laylist
)
(if (vlax-write-enabled-p each)
(vla-put-layeron each :vlax-false)
)
) (vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layerfreeze (laylist)
;;; ;;;
;;; description: freeze all layers in given list
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layerfreeze (laylist)
(vlax-for each (vlex-layertable) (if (member (strcase
(vla-get-name each)
) laylist
)
(if (vlax-write-enabled-p each)
(vla-put-freeze each :vlax-true)
)
) (vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layerthaw (laylist)
;;; ;;;
;;; description: thaw all layers in given list
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layerthaw (laylist)
(vlax-for each (vlex-layertable) (if (member (strcase
(vla-get-name each)
) laylist
)
(if (vlax-write-enabled-p each)
(vla-put-freeze each :vlax-false)
)
) (vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layernoplot (laylist)
;;; ;;;
;;; description: toggle plot/no-plot setting for layers.
;;; ;;;
;;; example: (vlex-layernoplot '("doors" "windows") t) ;;;
;;; sets layers to not plot ;;;
;;; (vlex-layernoplot '("doors" "windows") nil) ;;;
;;; sets layers to plot ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layernoplot (laylist on-off)
(vlax-for each (vlex-layertable) (if (member (strcase
(vla-get-name each)
) laylist
)
(if (vlax-write-enabled-p each)
(if on-off
(vla-put-plottable each :vlax-true)
(vla-put-plottable each :vlax-false)
)
)
) (vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layerlock (laylist)
;;; ;;;
;;; description: lock all layers in given list
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layerlock (laylist)
(vlax-for each (vlex-layertable) (if (member (strcase
(vla-get-name each)
) laylist
)
(if (vlax-write-enabled-p each)
(vla-put-lock each :vlax-true)
)
) (vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layerunlock (laylist)
;;; ;;;
;;; description: unlock all layers in given list
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layerunlock (laylist)
(vlax-for each (vlex-layertable) (if (member (strcase
(vla-get-name each)
) laylist
)
(if (vlax-write-enabled-p each)
(vla-put-lock each :vlax-false)
)
) (vlax-release-object each)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-listlayers-locked ()
;;; ;;;
;;; description: returns a list of layers that are currently locked
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listlayers-locked (/ each out)
(vlax-for each (vlex-layertable) (if (= (vlax-get-property each "Lock")
:vlax-true
)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-listlayers-frozen ()
;;; ;;;
;;; description: returns a list of layers that are currently frozen or
;;; 'nil' ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listlayers-frozen (/ each out)
(vlax-for each (vlex-layertable) (if (= (vlax-get-property each "Freeze")
:vlax-true
)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-listlayers-off ()
;;; ;;;
;;; description: returns a list of layers that are currently turned off
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listlayers-off (/ each out)
(vlax-for each (vlex-layertable) (if (= (vlax-get-property each "LayerOn")
:vlax-false
)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-listlayers-plottable ()
;;; ;;;
;;; description: returns a list of layers that are currently plottable
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listlayers-plottable (/ each out)
(vlax-for each (vlex-layertable) (if (= (vlax-get-property each
"Plottable"
) :vlax-true
)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-listlayers-plottable-not ()
;;; ;;;
;;; description: returns a list of layers that are currently not plottable
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-listlayers-plottalbe-not (/ each out)
(vlax-for each (vlex-layertable) (if (= (vlax-get-property each
"Plottable"
) :vlax-false
)
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-layer-frozen-p (lname)
;;; ;;;
;;; description: returns t or nil if named layer is currently frozen
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-layer-frozen-p (lname / each)
(if (and
(setq fl (vlex-listlayers-frozen)) ; any frozen layers?
(member (strcase lname) (mapcar
'strcase
fl
)
)
)
t
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-setlweight (obj intlwt)
;;; ;;;
;;; description: set lineweight index property for given object (or layer)
;;; ;;;
;;; example:
;;; ;;;
;;; notes: ;;;
;;; "bylwdefault" = -3 ;;;
;;; "byblock" = -2 ;;;
;;; "bylayer" = -1 ;;;
;;; other values are 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60,
;;; ;;;
;;; 70, 80, 90, 100, 106, 120, 140, 158, 200, 211 ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-setlweight (obj intlwt)
(cond
((member intlwt '(0 5 9 13 15 18 20 25 30 35 40 50 60 70 80 90 100 106
120 140 158 200 211
)
)
(vla-put-lineweight obj inelwt)
t ; return true
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-definelayer (strname intcolor strltype boolecur)
;;; ;;;
;;; description: returns name if named layer is correctly created.
;;; ;;;
;;; example: (vlex-definelayer "mylayer1" 3 "dashed" t)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-definelayer (strname intcolor strltype boolecur / iloc obj out)
(cond
((not (tblsearch "layer" strname))
(setq obj (vla-add (vlex-layertable) strname))
(setq iloc (vl-position strname (vlex-listlayers)))
(cond
((vlax-write-enabled-p obj)
(if intcolor
(vla-put-color obj intcolor)
)
(if strltype
(vlex-apply-ltype obj strltype)
)
)
(t
(princ "nUnable to modify object properties...")
)
) ; cond
(if boolecur
(vla-put-activelayer (vlex-activedocument) (vla-item
(vlex-layertable)
iloc
)
)
)
(setq out strname)
)
(t
(princ (strcat "nLayer already exists: " strname))
)
)
out
)
;;; selection sets -->>
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-ssetexists-p (name)
;;; ;;;
;;; notes: boolean test if selection set <name> exists in drawing session
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-ssetexists-p (name)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list
(vla-get-selectionsets
(vlex-activedocument)
) name
)
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-selectbytype (objtype)
;;; ;;;
;;; notes: return selection set of objects by type (string value)
;;; ;;;
;;; example: (setq myset (vlex-selectbytype "circle")) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-selectbytype (objtype / ss)
(if (vlex-ssetexists-p "%TEMP_SET")
(vla-delete (vla-item (vla-get-selectionsets
(vlex-activedocument)
) "%TEMP_SET"
)
)
)
(setq ss (vla-add (vla-get-selectionsets (vlex-activedocument))
"%TEMP_SET"
)
)
(vla-select ss acselectionsetall nil nil (vlex-intlist->vararray
(list 0)
)
(vlex-varlist->vararray (list objtype))
)
ss
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-selectonscreen-filter (groupcodes filterlists)
;;; ;;;
;;; notes: return selection set by filtering during on-screen selection
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-selectonscreen-filter (groupcodes filterlists / ss)
(if (vlex-ssetexists-p "%TEMP_SET")
(vla-delete (vla-item (vla-get-selectionsets
(vlex-activedocument)
) "%TEMP_SET"
)
)
)
(setq ss (vla-add (vla-get-selectionsets (vlex-activedocument))
"%TEMP_SET"
)
)
(vla-select ss acselectionsetall nil nil (vlex-intlist->vararray groupcodes)
(vlex-varlist->vararray filterlists)
)
ss
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-pickcircles
;;; ;;;
;;; notes: return selection set of circles on layer "0" only
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-pickcircles ()
(if (setq ss (vlex-selectonscreen-filter '(0 8) '("CIRCLE" "0")))
(vlax-for item ss (princ (vla-get-objectname item)) (terpri))
) ; if
(terpri)
ss
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-getcircles
;;; ;;;
;;; notes: return selection set of circle objects only
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun c:getcircles ()
(if (setq ss (vlex-selectbytype "CIRCLE"))
(vlax-for item ss (princ (vla-get-objectname item)) (terpri))
)
ss
)
;;; profiles . . . -->>
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profiles ()
;;; ;;;
;;; notes: get profiles collection object ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profiles ()
(vla-get-profiles (vlex-acadprefs))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profilereload (name argname)
;;; ;;;
;;; notes: import profile from arg to replace existing profile definition
;;; ;;;
;;; example: (vlex-profilereload "profile1" "c:profilesprofile1.arg")
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profilereload (name argname)
(cond
((= (vlax-get-property (vlex-profiles) 'activeprofile) name) ; or
; following code.
; (= (vla-get-activeprofile
; (vlex-profiles)) name)
(princ "nCannot delete a profile that is in use.")
) ;
((and
(vlex-profileexists-p name)
(findfile argname)
)
(vlex-profiledelete name)
(vlex-profileimport name argname)
(vla-put-activeprofile (vlex-profiles) name)
) ;
((and
(not (vlex-profileexists-p name))
(findfile argname)
)
(vlex-profileimport name argname)
(vla-put-activeprofile (vlex-profiles) name)
) ;
((not (findfile argname))
(princ (strcat "nCannot locate ARG source: " argname))
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profileexportx (pname argfile)
;;; ;;;
;;; notes: export an existing profile to a new external .arg file
;;; ;;;
;;; example: (vlex-profileexportx "profile1" "c:/profiles/profile1.arg")
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profileexportx (pname argfile)
(cond
((vlex-profileexists-p pname)
(vlax-invoke-method (vlex-profiles) 'exportprofile pname argfile
(vlax-make-variant 1 :vlax-vbboolean) ; == true
)
) ;
(t
(princ "nNo such profile exists to export.")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profilecopy (name1 name2)
;;; ;;;
;;; notes: copies an existing profile to a new profile
;;; ;;;
;;; example: (vlex-profilecopy pname newname)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profilecopy (name1 name2)
(cond
((and
(vlex-profileexists-p name1)
(not (vlex-profileexists-p name2))
)
(vlax-invoke-method (vlex-profiles) 'copyprofile name1 name2)
) ;
((not (vlex-profileexists-p name1))
(princ "nError: No such profile exists.")
) ;
((vlex-profileexists-p name2)
(princ "nProfile already exists, copy failed.")
)
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profilerename (oldname newname)
;;; ;;;
;;; notes: renames an existing profile
;;; ;;;
;;; example: (vlex-profilerename oldname newname)
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profilerename (oldname newname)
(cond
((and
(vlex-profileexists-p oldname)
(not (vlex-profileexists-p newname))
)
(vlax-invoke-method (vlex-profiles) 'renameprofile oldname newname)
) ;
(t
(princ)
) ; add your error handling here?
) ; cond
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-profilereset (strname)
;;; ;;;
;;; notes: reset given profile to default settings
;;; ;;;
;;; example: (vlex-profilereset "profile1")
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-profilereset (strname)
(if (vlex-profileexists-p strname)
(vlax-invoke-method (vlex-profiles) 'resetprofile strname)
(princ (strcat "nProfile [" strname "] does not exist."))
) ; endif
)
;;; application state . . . -->>
;;; these functions provide interaction with the acadapplication object to
;;; enable
;;; control over the window state and visibility of the session object
;;; itself.
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-getwindowstate ()
;;; ;;;
;;; notes: get the autocad application window state
;;; ;;;
;;; enumerated constants (vb/vba): acenum 1=min 2=normal 3=max
;;; ;;;
;;; example: (vlex-getwindowstate) return 1, 2 or 3
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-getwindowstate ()
(vla-get-windowstate (vlex-acadobject))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-setwindowstate ()
;;; ;;;
;;; notes: modify the autocad application window state
;;; ;;;
;;; enumerated constants (vb/vba): acenum 1=min 2=normal 3=max
;;; ;;;
;;; example: (vlex-setwindowstate 3) maximizes the window display
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-setwindowstate (acenum)
(vla-put-windowstate (vlex-acadobject) acenum)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-hideautocad ()
;;; ;;;
;;; notes: hide autocad application
;;; ;;;
;;; example: (vlex-hideautocad) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-hideautocad ()
(vla-put-visible (vlex-acadobject) :vlax-false)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-showautocad ()
;;; ;;;
;;; notes: display autocad application (if hidden)
;;; ;;;
;;; example: (vlex-showautocad) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-showautocad ()
(vla-put-visible (vlex-acadobject) :vlax-true)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-hideshowtest (delay-time)
;;; ;;;
;;; notes: temporarily hides autocad applicaiton to demonstrate the two
;;; ;;;
;;; functions given above. time value is in milliseconds. ;;;
;;; example: (vlex-hideshowtest 500) ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-hideshowtest (delay-time)
(vlex-hideautocad) ; hide autocad...
(vl-cmdf "delay" delay-time) ; wait for <x> milliseconds...
(vlex-showautocad) ; show autocad again
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-docprefs () ;;;
;;; notes: provides object access to document/database-preferences
;;; collection ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-docprefs ()
(vla-get-preferences (vlex-activedocument))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-lwdisplayon/off ()
;;; ;;;
;;; notes: turn lineweight display setting on or off ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-lwdisplayon ()
(vla-put-lineweightdisplay (vlex-docprefs) :vlax-true)
)
(defun vlex-lwdisplayoff ()
(vla-put-lineweightdisplay (vlex-docprefs) :vlax-false)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-objectsorbysnapon/off () ;;;
;;; notes: turn object-sort (sortents) option for "sort by snap" on or off
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-objectsortbysnapon ()
(vla-put-objectsortbysnap (vlex-docprefs) :vlax-true)
)
(defun vlex-objectsortbysnapoff ()
(vla-put-objectsortbysnap (vlex-docprefs) :vlax-false)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-xrefediton/off () ;;;
;;; notes: turn xref editing option on or off ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-xrefediton ()
(vla-put-xrefedit (vlex-docprefs) :vlax-true)
)
(defun vlex-xrefeditoff ()
(vla-put-xrefedit (vlex-docprefs) :vla-false)
]
)
;;; menus & toolbars. . . -->>
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-menugroups () ;;;
;;; notes: returns vla-object for menugroups collection ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-menugroups ()
(vla-get-menugroups (vlex-acadobject))
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-menugroups-listall () ;;;
;;; notes: returns a list of all defined menugroups names ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-menugroups-listall (/ out)
(vlax-for each (vlex-menugroups) (setq out (cons (vla-get-name each) out)))
(reverse out)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-menugroup-exists-p () ;;;
;;; notes: returns ordinal position of menugroup name in collection(list)
;;; of ;;;
;;; all currently defined menugroups. if not found, returns 'nil'
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-menugroup-exists-p (name)
(if (member (strcase name) (mapcar
'strcase
(vlex-menugroups-listall)
)
)
(vl-position name (vlex-menugroups-listall))
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-toolbars (mgroup) ;;;
;;; notes: returns vla-object(collection object) for all toolbars
;;; associated ;;;
;;; with a given menugroup. if menugroup is not found, returns nil.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-toolbars (mgroup)
(if (vlex-menugroup-exists-p mgroup)
(vla-get-toolbars (vla-item (vlex-menugroups) (vl-position
(strcase mgroup)
(mapcar
'strcase
(vlex-menugroups-listall)
)
)
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-toolbars-listall (mgroup)
;;; ;;;
;;; notes: returns a list of all toolbar names for a given menugroup. if
;;; ;;;
;;; menugroup not found, or if no toolbars are found for menugroup,
;;; ;;;
;;; returns 'nil
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-toolbars-listall (mgroup / tb out)
(if (setq tb (vlex-toolbars mgroup))
(vlax-for each tb (setq out (cons (vla-get-name each) out)))
)
(reverse out)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-toolbar-exists-p (mgroup tbname) ;;;
;;; notes: returns ordinal position of toolbar name with menugroup toolbars
;;; ;;;
;;; collection. if menugroup is not found, or if toolbar name is not
;;; ;;;
;;; found in collection, returns 'nil'.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-toolbar-exists-p (mgroup tbname)
(if (and
(vlex-menugroup-exists-p mgroup)
(member (strcase tbname) (mapcar
'strcase
(vlex-toolbars-listall mgroup)
)
)
)
(vl-position tbname (vlex-toolbars-listall mgroup))
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-toolbar (mgroup tbname / loc) ;;;
;;; notes: returns vla-object to given(named) toolbar within a given
;;; ;;;
;;; menugroup. if menugroup or toolbar not found, returns 'nil'.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-toolbar (mgroup tbname / loc)
(if (setq loc (vlex-toolbar-exists-p mgroup tbname))
(vla-item (vlex-toolbars mgroup) loc)
)
)
;;; ************************************************************************
;;; *****;;;
;;; module: vlex-toolbar-show (mgroup tbname / tb) ;;;
;;; notes: show a given toolbar(set "visible" to "true"), given a menugroup
;;; ;;;
;;; and toolbar name to apply this to. returns t if successful, 'nil'
;;; otherwise.;;;
;;; ************************************************************************
;;; *****;;;
(defun vlex-toolbar-show (mgroup tbname / tb)
(if (setq tb (vlex-toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-false)
(progn
(vla-put-visible tb :vlax-true)
t
)
)
)
)
;;; ************************************************************************
;;; *****;;;
;;; module: vlex-toolbar-hide (mgroup tbname / tb) ;;;
;;; notes: hide a given toolbar(set "visible" to "true"), given a menugroup
;;; ;;;
;;; and toolbar name to apply this to. returns t if successful, 'nil'
;;; otherwise.;;;
;;; ************************************************************************
;;; *****;;;
(defun vlex-toolbar-hide (mgroup tbname / tb)
(if (setq tb (vlex-toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(progn
(vla-put-visible tb :vlax-false)
t
)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-toolbar-dock (mgroup tbname dock)
;;; ;;;
;;; description: dock a given toolbar along top, bottom, left or right
;;; edged ;;;
;;; of window.
;;; ;;;
;;; notes: allowable <dock> values are 0(top), 1(bottom), 2(left),
;;; ;;;
;;; and 3(right). returns 1 if successful, -1 if toolbar is not
;;; ;;;
;;; visible, -2 if parameter is invalid, or 0 if toolbar not found.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-toolbar-dock (mgroup tbname dock / tb)
(if (setq tb (vlex-toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(if (member dock '(0 1 2 3))
(progn
(vlax-invoke-method tb 'dock dock)
1
)
-2 ; invalid dockstatus parameter
)
-1 ; toolbar not visible
)
0 ; toolbar not found
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-toolbar-folat (mgroup tbname top left rows)
;;; ;;;
;;; description: float a given toolbar at specified position(top and left)
;;; ;;;
;;; and display with specified number of rows. returns 1 if successful,
;;; ;;;
;;; -1 if toolbar is not visible, 0 if toolbar is not found.
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-toolbar-folat (mgroup tbname top left rows)
(if (setq tb (vlex-toolbar mgroup tbname))
(if (= (vla-get-visible tb) :vlax-true)
(progn
(vlax-invoke-method tb 'float top left rows)
1
)
-1 ; toolbar not visible
)
0 ; toolbar not found
)
)
;;; reactors. . . -->>
;;; summary of reactor types and events ;;;
;;; reactor events ;;;
;;; vlr-dwg-reactor : vlr-beginclose ;;;
;;; : vlr-begindwgopen ;;;
;;; : vlr-beginsave ;;;
;;; : vlr-enddwgopen ;;;
;;; : vlr-savecomplete ;;;
;;; ;;;
;;; vlr-lisp-reactor : vlr-lispended ;;;
;;; : vlr-lispcancelled ;;;
;;; : vlr-lispwillstart (first line of lisp code string) ;;;
;;; ;;;
;;; vlr-command-reator : vlr-commandwillstart ;;;
;;; : vlr-commandended ;;;
;;; : vlr-commandcancelled ;;;
;;; : vlr-commandfailed ;;;
;;; ;;;
;;; vlr-mouse-reactor : vlr-begindoubleclick ;;;
;;; : vlr-beginrightclick ;;;
;;; other reactor types...
;;; vlr-object-reactor ;;;
;;; vlr-linker-reactor ;;;
;;; vlr-acdb-reactor ;;;
;;; vlr-editor-reactor ;;;
;;; vlr-dxf-reactor ;;;
;;; vlr-undo-reactor ;;;
;;; vlr-toolbar-reactor ;;;
;;; vlr-sysvar-reactor ;;;
;;; vlr-wblock-reactor ;;;
;;; vlr-window-reactor ;;;
;;; vlr-xref-reactor ;;;
;;; vlr-miscellaneous-reactor ;;;
;;; ;;;
;;; ;;;
;;; ************************************************************************
;;; ***;;;
;;; example: function examples using command-reactors and dwg-reactors
;;; ;;;
;;; ************************************************************************
;;; ***;;;
;;; (vlr-command-reactor ;; trap command events...
;;; nil ; no data? yet?
;;; ;; define call backs
;;; '(
;;; (:vlr-commandwillstart . trapcommandstart)
;;; (:vlr-commandended . trapcommandended)
;;; (:vlr-commandcancelled . trapcommandcancelled)
;;; (:vlr-commandfailed . trapcommandfailed)
;;; )
;;; )
;;;
;;; (vlr-dwg-reactor ;; trap drawing session events...
;;; nil ; no data? yet?
;;; ;; define call backs
;;; '(
;;; (:vlr-beginclose . trapbegindwgclose)
;;; (:vlr-beginsave . trapbeginsave)
;;; (:vlr-savecomplete . trapsavecomplete)
;;; (:vlr-begindwgopen . trapbegindwgopen)
;;; (:vlr-enddwgopen . trapenddwgopen)
;;; )
;;; )
;;; this is a vlr-command-reactor to commandwillstart ;;;
;;; it initializes currentcommandname global, used by other reactors
;;; ;;;
(defun trapcommandstart (reactor callbackdata) ; reset all reactor globals
(setq #*someglobal* nil
#*anotherglobal* nil
currentcommandname (cond
((car callbackdata))
((getvar "CMDNAMES"))
)
)
(cond
((= currentcommandname "PLOT") ; do your stuff here, call another
; function, etc.
;
) ;
((= currentcommandname "PRINT") ; do your stuff here...
) ;
((= (substr currentcommandname 1 3)) ; do your stuff here...
)
(t ;
(prompt (strcat "nTesting " currentcommandname
" CommandWillStart reactor..."
)
)
)
(t
nil
)
)
(princ)
)
;;; this is a good method for firing off routines when a drawing is closed.
;;; ;;;
;;; i have used this to capture work information to save to database and
;;; ;;;
;;; track contract hours per drawing, not just per acad session. ;;;
(defun trapbegindwgclose (reactor callbackdata) ; reset all reactor globals
; to nil
(setq #*someglobal* nil
#*anotherglobal* nil
)
(cond
(t
(prompt (strcat currentcommandname " beginClose"))
(cleanallreactors)
)
)
(princ)
)
;;; remove all references to reactors from given event types... ;;;
(defun cleanallreactors ()
(mapcar
'vlr-remove-all
'(:vlr-acdb-reactor :vlr-dwg-reactor :vlr-command-reactor
:vlr-linker-reactor :vlr-object-reactor
:vlr-mouse-reactor :vlr-lisp-reactor
)
)
)
;;; example using a simple command reactor to set a layer current whenever
;;; a ;;;
;;; dimension command is executed. it restores the previous layer after the
;;; ;;;
;;; command completes or if the command either is cancelled or fails for
;;; some ;;;
;;; reason (other than a genarl autocad failure like power loss).
;;; ;;;
;;; funciton to define layer of given name.
;;; notes: you cannot issue a (command) or (vl-cmdf) function call within a
;;; ;;;
;;; command reactor. that would cause an infinite recursive loop.
;;; therefore, ;;;
;;; you should make sure you define the layer before or outside of the
;;; ;;;
;;; reator callback function and simply issue a layer-set operation in the
;;; ;;;
;;; callback function. ;;;
(setq g$layc (vlex-definelayer "DIMENSIONS" nil nil nil))
;;; make sure not to reload reactor attachments over top of each other!
;;; ;;;
(defun vlex-load-command-reactors ()
(if (null g$vlex1)
(progn
(vlr-command-reactor ; trap command events...
nil ; no data? yet?
; define call backs
'((:vlr-commandwillstart . vlex-commandstart)
(:vlr-commandended . vlex-commandended)
(:vlr-commandcancelled . vlex-commandcancelled)
(:vlr-commandfailed . vlex-commandfailed)
)
)
(setq g$vlex1 t)
)
)
)
;;; (vlex-load-command-reactors)
;;; ************************************************************************
;;; ***;;;
;;; react to command ending properly
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-commandended (reactor callbackdata) ; reset all reactor
; globals
(setq #*someglobal* nil
#*anotherglobal* nil
currentcommandname (cond
((car callbackdata))
((getvar "CMDNAMES"))
)
) ; setq
(cond
((= "DIM" (substr currentcommandname 1 3))
(m2k_restorelayer)
)
(t
nil
)
)
(princ)
)
;;; ************************************************************************
;;; ***;;;
;;; function to restore saved layer
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun m2k_restorelayer ()
(if g$layx
(setvar "clayer" g$layx)
)
(setq g$layx nil)
)
;;; ************************************************************************
;;; ***;;;
;;; react to command getting ready to execute
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun trapcommandstart (reactor callbackdata) ; reset all reactor globals
(setq #*someglobal* nil
#*anotherglobal* nil
currentcommandname (cond
((car callbackdata))
((getvar "CMDNAMES"))
)
) ; setq
(cond
((= "DIM" (substr currentcommandname 1 3))
(setq g$layx (getvar "clayer"))
(cond
((and
g$layc
(tblsearch "layer" g$layc)
)
(setvar "clayer" g$layc)
)
(t
(princ "nLayer (DIMENSIONS) has not been defined.")
)
)
)
(t
nil
)
)
(princ)
)
;;; ************************************************************************
;;; ***;;;
;;; react to cancelled command
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-commandcancelled (reactor callbackdata)
(m2k_restorelayer)
(princ)
)
;;; ************************************************************************
;;; ***;;;
;;; react to failed command
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-commandfailed (reactor callbackdata)
(m2k_restorelayer)
(princ)
)
;;; visual lisp custom functions. . . -->>
;;; ************************************************************************
;;; ***;;;
;;; module: ex:2dpoint (pt)
;;; ;;;
;;; purpose: converts an autolisp point into a 2d activex point
;;; ;;;
;;; arguments: a point list (2d or 3d)
;;; ;;;
;;; example: (ex:2dpoint (getpoint))
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun ex:2dpoint (pt)
(vl-load-com)
(vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble
'(0 . 1)
) (list (car pt) (cadr pt))
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: ex:activatelastlayout ()
;;; ;;;
;;; purpose: activates the rightmost layout tab
;;; ;;;
;;; arguments: none ;;;
;;; example: ;;;
;;; notes: none ;;;
;;; debug: nil ;;;
;;; ************************************************************************
;;; ***;;;
(defun ex:activatelastlayout (/ i layouts cnt layout)
(vl-load-com)
(setq i -1
layouts (vla-get-layouts (vla-get-activedocument
(vlax-get-acad-object)
)
)
cnt (1- (vla-get-count layouts))
) ; setq
(vlax-for layout layouts (if (= (vla-get-taborder layout) 1)
(vla-activate layout)
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: selectionsettoarray (ss / c r)
;;; ;;;
;;; purpose: returns an variant array of subtype object filled with the
;;; ;;;
;;; contents of a selection set
;;; ;;;
;;; example: (selectionsettoarray myss) ;;;
;;; arguments: a selection set ;;;
;;; notes: 1. use this whenever you need to pass a selection set as an
;;; ;;;
;;; array to an activex function ;;;
;;; 2. if you need a different subtype, simply change the
;;; reference;;;
;;; to vlax-vbobject ;;;
;;; debug: nil ;;;
;;; ************************************************************************
;;; ***;;;
(defun selectionsettoarray (ss / c r)
(vl-load-com)
(setq c -1)
(repeat (sslength ss)
(setq r (cons (ssname ss (setq c (1+ c))) r))
)
(setq r (reverse r))
(vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0
(1-
(length r)
)
)
) (mapcar
'vlax-ename->vla-object
r
)
)
)
;;; ************************************************************************
;;; ***;;;
;;; module: ex:addobjectstoblock (blk ss)
;;; ;;;
;;; purpose: adds a selection set of objects to an existing block
;;; definition;;;
;;; arguments: the entity name of a block insert and a selection set
;;; ;;;
;;; example: (ex:addobjectstoblock (car (entsel)) (ssget)) ;;;
;;; notes: existing block references will not show a change until you
;;; ;;;
;;; regen the drawing ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; ***;;;
(defun ex:addobjectstoblock (blk ss / doc blkref blkdef inspt refpt)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
blkref (vlax-ename->vla-object blk)
blkdef (vla-item (vla-get-blocks doc) (vla-get-name blkref))
inspt (vlax-variant-value (vla-get-insertionpoint blkref))
ssarray (selectionsettoarray ss)
refpt (vlax-3d-point '(0 0 0))
)
(foreach ent (vlax-safearray->list ssarray)
(vla-move ent inspt refpt)
)
(vla-copyobjects doc ssarray blkdef)
(foreach ent (vlax-safearray->list ssarray)
(vla-delete ent)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:mappedshare (share / fso drives drive letter)
;;; ;;;
;;; purpose: returns the logical drive letter to which a network share is
;;; mapped ;;;
;;; arguments: a unc path ;;;
;;; example: (ex:mappedshare "myservermyshare")
;;; ;;;
;;; notes: 1. be sure to substitute two backslashes for every one in
;;; the unc path ;;;
;;; 2. this routine requires the use scrrun.dll. visite the
;;; ;;;
;;; microsoft scripting web site if you do not have it.
;;; ;;;
;;; debug: nil ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:mappedshare (share / fso drives drive letter)
(vl-load-com)
(setq fso (vlax-create-object "Scripting.FileSystemObject"))
(vlax-for drive (setq drives (vlax-get-property fso 'drives))
(if (= (strcase (vlax-get-property drive 'sharename))
(strcase share)
)
(setq letter (vlax-get-property drive 'driveletter))
)
)
(vlax-release-object drives)
(vlax-release-object fso)
letter
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:buildfilter (filter) ;;;
;;; purpose: returns a list containing a pair of variants for use as
;;; ;;;
;;; activex selection set filters ;;;
;;; arguments: a unc path ;;;
;;; example: (ex:buildfilter '((0 . "lwpolyline") (8 . "walls")))
;;; ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:buildfilter (filter)
(vl-load-com)
(mapcar
'(lambda (lst typ)
(vlax-make-variant (vlax-safearray-fill (vlax-make-safearray typ
(cons 0
(1-
(length lst)
)
)
) lst
)
)
)
(list (mapcar
'car
filter
) (mapcar
'cdr
filter
)
)
(list vlax-vbinteger vlax-vbvariant)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:centroid (poly / pl ms va reg cen)
;;; ;;;
;;; purpose: returns the centroid of a closed polyline ;;;
;;; arguments: the entity name of a closed, planar polyline
;;; ;;;
;;; example: (ex:centroid (car (entsel))) ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:centroid (poly / pl ms va reg cen)
(vl-load-com)
(setq pl (vlax-ename->vla-object poly)
ms (vla-get-modelspace (vla-get-activedocument
(vlax-get-acad-object)
)
)
va (vlax-make-safearray vlax-vbobject '(0 . 0))
)
(vlax-safearray-put-element va 0 pl)
(setq reg (car (vlax-safearray->list (vlax-variant-value
(vla-addregion ms va)
)
)
)
cen (vla-get-centroid reg)
)
(vla-delete reg)
(vlax-safearray->list (vlax-variant-value cen))
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:changeattributes (lst / item atts)
;;; ;;;
;;; purpose: modifies the specified attribute in the specified block
;;; reference ;;;
;;; arguments: a list containing one atom and one or more dotted pairs.
;;; ;;;
;;; the atom is the entity name of the block to change. ;;;
;;; the dotted pairs consist of the attribute tag and the new
;;; value for that attribute.
;;; example: (ex:changeattributes (list ename '("myattribute" .
;;; "newvalue"))) ;;;
;;; notes: 1. thanks to chuck balmer for spotting the bug in this
;;; routine. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:changeattributes (lst / item atts)
(vl-load-com)
(if (safearray-value (setq atts (vlax-variant-value
(vla-getattributes
(vlax-ename->vla-object
(car lst)
)
)
)
)
)
(progn
(foreach item (cdr lst)
(mapcar
'(lambda (x)
(if (= (strcase (car item)) (strcase
(vla-get-tagstring x)
)
)
(vla-put-textstring x (cdr item))
)
)
(vlax-safearray->list atts)
)
)
(vla-update (vlax-ename->vla-object (car lst)))
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:changebitmap (mnugroup tbrname btnname bitmap)
;;; ;;;
;;; purpose: changes the button top for the specified toobar button
;;; ;;;
;;; arguments: the name of the menu group, the name of the toolbar, ;;;
;;; the name of the toolbar button and the bitmap to use ;;;
;;; example: (ex:changebitmap "acad" "dimension" "linear dimension"
;;; "test.bmp") ;;;
;;; notes: 1. if the bitmap is not in the autocad search path, you must
;;; specify ;;;
;;; the full path to file ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:changebitmap (mnugroup tbrname btnname bitmap)
(vl-load-com)
(vla-setbitmaps (vla-item (vla-item (vla-get-toolbars (vla-item
(vla-get-menugroups
(vlax-get-acad-object)
) mnugroup
)
) tbrname
) btnname
) bitmap bitmap
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:closeall () ;;;
;;; purpose: closes all open documents without saving ;;;
;;; arguments: none ;;;
;;; example: ;;;
;;; notes: ;;;
;;; author: frank whaley ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:closeall (/ item cur)
(vl-load-com)
(vlax-for item (vla-get-documents (vlax-get-acad-object)) (if (=
(vla-get-active item) :vlax-false
)
(vla-close item :vlax-false)
(setq cur item)
)
)
(vla-sendcommand cur "_.CLOSE")
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:deleteobjectfromblock (ent)
;;; ;;;
;;; purpose: deletes the specified subentity from a block definition and
;;; returns the ;;;
;;; remaining of items in that block definition ;;;
;;; arguments: the entity name of the subentity to delete ;;;
;;; example: (ex:deleteobjectfromblock (car (nentsel))) ;;;
;;; notes: 1. as shown, you can use the nentsel function to obtain the
;;; name of an entity within a block.
;;; 2. existing block reference will not show a change until you
;;; regen the drawing.
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:deleteobjectfromblock (ent / doc blk)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
ent (vlax-ename->vla-object ent)
blk (vla-objectidtoobject doc (vla-get-ownerid ent))
)
(vla-delete ent)
(vla-get-count blk)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:drawvpborder (vp / ll ur coords pl)
;;; ;;;
;;; purpose: draws a rectangle representing the area displayed by a paper
;;; space viewport ;;;
;;; arguments: the entity name of a paper space view port ;;;
;;; example: (ex:drawvpborder (car (entsel))) ;;;
;;; notes: 1. the return value is the entity name of the newly created
;;; lwpolyline ;;;
;;; 2. the layout containing the viewport to be drawn must be
;;; active ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:drawvpborder (vp / ll ur coords pl)
(vl-load-com)
(setq vp (vlax-ename->vla-object vp))
(vla-getboundingbox vp 'll 'ur)
(setq ll (trans (vlax-safearray->list ll) 3 2)
ur (trans (vlax-safearray->list ur) 3 2)
coords (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble
(cons 0 7)
) (list (nth 0 ll) (nth 1 ll)
(nth 0 ur) (nth 1 ll)
(nth 0 ur) (nth 1 ur)
(nth 0 ll) (nth 1 ur)
)
)
)
(vla-put-closed (setq pl (vla-addlightweightpolyline
(vla-get-modelspace
(vla-get-document vp)
) coords
)
)
:vlax-true
)
(vlax-vla-object->ename pl)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:drivetype (drv) ;;;
;;; purpose: returns a string identifying the type of drive specified
;;; ;;;
;;; arguments: a drive letter ;;;
;;; example: (mapcar 'ex:drivetype (ex:listdrives)) ;;;
;;; notes: 1. this routine requires the use scrrun.dll. ;;;
;;; visit the microsoft scripting web site if you do not have
;;; it. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:drivetype (drv / fso drives drive typ)
(vl-load-com)
(setq fso (vlax-create-object "Scripting.FileSystemObject"))
(if (vlax-invoke-method fso 'driveexists drv)
(progn
(setq drives (vlax-get-property fso 'drives)
drive (vlax-get-property drives 'item drv)
typ (vlax-get-property drive 'drivetype)
)
(vlax-release-object drive)
(vlax-release-object drives)
(vlax-release-object fso)
(nth typ '("UNKNOWN" "REMOVABLE"
"FIXED" "REMODTE"
"CDROM" "RAMDISK"
)
)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:listdrives (drv) ;;;
;;; purpose: returns a list containing all logical drives currently
;;; defined ;;;
;;; arguments: none ;;;
;;; example: ;;;
;;; notes: 1. this routine requires the use scrrun.dll. ;;;
;;; visit the microsoft scripting web site if you do not have
;;; it. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:listdrives (/ fso drive drives lst)
(vl-load-com)
(setq fso (vlax-create-object "Scripting.FileSystemObject"))
(vlax-for drive (setq drives (vlax-get-property fso 'drives))
(setq lst (cons (vlax-get-property drive 'driveletter) lst))
)
(vlax-release-object drives)
(vlax-release-object fso)
(reverse lst)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:parse (str delim / lst pos) ;;;
;;; purpose: returns a list containing all tokens in a delimited string
;;; ;;;
;;; arguments: a delimited string and the delimiter character. ;;;
;;; example: (ex:parse (getenv "acad") ";") ;;;
;;; notes: 1. autolisp does not correctly interpret any character code
;;; outside the ;;;
;;; range of 1 to 255, so you cannot parse a null delimited
;;; string. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:parse (str delim / lst pos token)
(setq pos (vl-string-search delim str))
(while pos
(setq lst (cons (if (= (setq token (substr str 1 pos))
delim
)
nil
token
) lst
)
str (substr str (+ pos 2))
pos (vl-string-search delim str)
)
)
(if (> (strlen str) 0)
(setq lst (cons str lst))
)
(reverse lst)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:exportproject (pname fname) ;;;
;;; purpose: exports the specified project to disk ;;;
;;; arguments: the name of a project and the full path to a file ;;;
;;; example: (ex:exportproject "johnson" "c:tempproject.txt")
;;; ;;;
;;; notes: 1. if the specified file exists, it will be overwritten
;;; ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:exportproject (pname fname / fh prj)
(vl-load-com)
(setq fh (open fname "w"))
(if (setq prj (vl-registry-read (strcat "HKEY_CURRENT_USER"
(vlax-product-key) "Profiles"
(getvar "CPROFILE")
"Project Settings" pname
) "RefSearchPath"
)
)
(progn
(write-line (strcat "[" pname "]") fh)
(foreach folder (ex:parse prj ";")
(write-line folder fh)
)
)
(princ "nThe specified windows registry key is not exists.")
)
(close fh)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:importtproject (fname) ;;;
;;; purpose: imports a project exported by ex:exportproject
;;; ;;;
;;; arguments: the full path to a file containing an exported project
;;; ;;;
;;; example: (ex:importproject "c:tempproject.txt") ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:importproject (fname / pname fh l lst)
(vl-load-com)
(if (setq fh (open fname "r"))
(progn
(setq pname (read-line fh)
pname (substr pname 2 (- (strlen pname) 2))
lst ""
)
(while (setq l (read-line fh))
(setq lst (strcat lst l ";"))
)
(vl-registry-write (strcat "HKEY_CURRENT_USER"
(vlax-product-key) "Profiles"
(getvar "CPROFILE") "Project Settings"
pname
) "RefSearchPath" (substr lst 1 (1-
(strlen lst)
)
)
)
(close fh)
)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getattributes (ent) ;;;
;;; purpose: returns a list of attribute tags, associated values and
;;; entity names ;;;
;;; arguments: the entity name os an attributed block ;;;
;;; example: (ex:getattributes (car (entsel)) ;;;
;;; notes: 1. you can use the entity name in each sublist to update a
;;; given attribute;;;
;;; 2. if there are no editable attributes in the given block,
;;; this function returns nil.
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getattributes (ent / lst)
(vl-load-com)
(if (safearray-value (setq lst (vlax-variant-value
(vla-getattributes
(vlax-ename->vla-object ent)
)
)
)
)
(mapcar
'(lambda (x)
(list (vla-get-tagstring x) (vla-get-textstring x)
(vlax-vla-object->ename x)
)
)
(vlax-safearray->list lst)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getboundingbox (ent) ;;;
;;; purpose: returns the extents of an individual entity ;;;
;;; arguments: an entity name ;;;
;;; example: (ex:getboundingbox (car (entsel))) ;;;
;;; notes: 1. do not use this routine wity xlines or rays ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getboundingbox (ent / ll ur)
(vl-load-com)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar
'vlax-safearray->list
(list ll ur)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getconstantattributes (ent) ;;;
;;; purpose: returns a list of constant attributes tags and their
;;; values ;;;
;;; arguments: the entity name of a block with constant attributes ;;;
;;; example: (ex:getconstantattributes (car (entsel))) ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getconstantattributes (ent / atts)
(vl-load-com)
(cond
((and
(safearray-value (setq atts (vlax-variant-value
(vla-getconstantattributes
(vlax-ename->vla-object ent)
)
)
)
)
)
(mapcar
'(lambda (x)
(cons (vla-get-tagstring x) (vla-get-textstring x))
)
(vlax-safearray->list atts)
)
) ;
(t
(princ (strcat "nThe block reference "" (vla-get-name
(vlax-ename->vla-object ent)
) "\" doesn't include constant attributes tags and their values"
)
)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getcurvelength (ent) ;;;
;;; purpose: returns the length of a curve ;;;
;;; arguments: the entity name of a line, arc, circle, polyline (heavy or
;;; lightweight). ;;;
;;; example: (ex:getcurvelength (car (entsel))) ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getcurvelength (curve /)
(vl-load-com)
(setq curve (vlax-ename->vla-object curve))
(vlax-curve-getdistatparam curve (vlax-curve-getendparam curve))
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getfilesize (filename) ;;;
;;; purpose: returns the size of the specified file in bytes
;;; ;;;
;;; arguments: a string specifying the full path to a file ;;;
;;; example: (ex:getfilesize "c:\autoexec.bat") ;;;
;;; notes: 1. there are reports of vl-file-size and acet-file-size
;;; malfunction on ;;;
;;; win2k systems. use this as a substitute. it requires
;;; scrrun.dll. ;;;
;;; visit the microsoft scripting web site if you do not have it. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getfilesize (filename / fso file size)
(vl-load-com)
(if (findfile filename)
(progn
(setq fso (vlax-create-object "Scripting.FileSystemObject")
file (vlax-invoke-method fso 'getfile filename)
size (vlax-variant-value (vlax-get-property file 'size))
)
(vlax-release-object file)
(vlax-release-object fso)
)
)
size
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getlastheight (style) ;;;
;;; purpose: returns the last height used for a given text style
;;; ;;;
;;; arguments: the name of a text style ;;;
;;; example: (ex:setlastheight "standard" (* (ex:getlastheight
;;; "standard") 2.0)) ;;;
;;; notes: 1. the example sets the standard text style height to twice
;;; whatever it was before ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getlastheight (style)
(vl-load-com)
(vla-get-lastheight (vla-item (vla-get-textstyles
(vla-get-activedocument
(vlax-get-acad-object)
)
) style
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:setlastheight (style height) ;;;
;;; purpose: sets the default height for a variable-height text style
;;; ;;;
;;; arguments: the name of a text style whose height is 0 and a double
;;; indicating the ;;;
;;; default height to be used the next time a text command is
;;; invoke ;;;
;;; example: (ex:setlastheight "standard" 2.5) ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:setlastheight (style height)
(vl-load-com)
(vla-put-lastheight (vla-item (vla-get-textstyles
(vla-get-activedocument
(vlax-get-acad-object)
)
) style
) height
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getparentblocks (blkname / doc) ;;;
;;; purpose: returns a list conaining the entity names of any block
;;; definitions that ;;;
;;; reference the specified block ;;;
;;; arguments: a string identifying the block to search for ;;;
;;; example: none ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getparentblocks (blkname / doc)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(apply
'append
(mapcar
'(lambda (x)
(if (= :vlax-false (vla-get-islayout (vla-objectidtoobject doc
(vla-get-ownerid
(vlax-ename->vla-object x)
)
)
)
)
(list x)
)
)
(ex:listblockrefs blkname)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:listblockrefs (blkname / lst) ;;;
;;; purpose: returns a list conaining the entity names of every reference
;;; to the specified block ;;;
;;; arguments: a string identifying the block to search for ;;;
;;; example: none ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:listblockrefs (blkname / lst)
(setq lst (entget (cdr (assoc 330 (entget (tblobjname "block" blkname))))))
(apply
'append
(mapcar
'(lambda (x)
(if (entget (cdr x))
(list (cdr x))
)
)
(repeat 2
(setq lst (reverse (cdr (member (assoc 102 lst) lst))))
)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getplotdevices () ;;;
;;; purpose: returns a list containing all available plot devices
;;; ;;;
;;; arguments: none ;;;
;;; example: none ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getplotdevices ()
(vl-load-com)
(vlax-safearray->list (vlax-variant-value (vla-getplotdevicenames
(vla-item
(vla-get-layouts
(vla-get-activedocument
(vlax-get-acad-object)
)
) "Model"
)
)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:petxdata (vlaobj xdata) ;;;
;;; purpose: attach extended entity data to an autocad object.
;;; ;;;
;;; arguments: an activex object and an extended entity data list in the
;;; same format as ;;;
;;; returned by getxdata. ;;;
;;; example: (ex:putxdata myvlaobj '((1001 . "acadx") (1000 .
;;; "mystringdata"))) ;;;
;;; notes: the extended entity data application names as noted in the
;;; 1001 group ;;;
;;; code must be registered with the autolisp function regapp
;;; prior to ;;;
;;; attaching data to an object. see the autocad help files for
;;; valid extended;;;
;;; entity data codes and values. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:putxdata (vlaobj xdata)
(setq xdata (ex:buildfilter (mapcar
'(lambda (item / key)
(setq key (car item))
(if (<= 1010 key 1033)
(cons key (vlax-variant-value
(vlax-3d-point
(cdr item)
)
)
)
item
)
)
xdata
)
)
)
(vla-setxdata vlaobj (car xdata) (cadr xdata))
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:lisp-value (v) ;;;
;;; purpose: returns the lisp value of an activex variant. ;;;
;;; arguments: an activex variant or safearray. ;;;
;;; example: (ex:lisp-value myvariant) ;;;
;;; notes: this function will recursively dig into a safearray and
;;; convert all ;;;
;;; values, including nested safearray's, into a lisp value.
;;; ;;;
;;; author: vladimir nesterovsky 2002 ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:lisp-value (v)
(cond
((= (type v) 'variant)
(ex:lisp-value (variant-value v))
)
((= (type v) 'safearray)
(mapcar
'ex:lisp-value
(safearray-value v)
)
)
(t
v
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:getxdata (vlaobj appid) ;;;
;;; purpose: get extended entity data attached to an autocad object.
;;; ;;;
;;; arguments: an activex object and an application name that has been
;;; registed with ;;;
;;; the autolisp function regapp. ;;;
;;; example: (ex:getxdata myvlaobj "acadx") ;;;
;;; notes: returns a list of extended entity data attached to the
;;; object. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:getxdata (vlaobj appid / xtype xdata)
(vla-getxdata vlaobj appid 'xtype 'xdata)
(mapcar
'(lambda (key val)
(cons key (ex:lisp-value val))
)
(vlax-safearray->list xtype)
(vlax-safearray->list xdata)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:labelarea (ent) ;;;
;;; purpose: creates a text entity that reports the area of a given
;;; entity. ;;;
;;; arguments: the entity name of any object that supports the area
;;; property ;;;
;;; (arc, circle, ellipse, lwpolyline, polyline, region or
;;; spline) ;;;
;;; example: (ex:labelarea (car (entsel))) ;;;
;;; notes: 1. the first time an entity is labeled, the text will appear
;;; at the ;;;
;;; entity's start point or center point ;;;
;;; 2. call ex:labelarea again to update a label. the label will
;;; update ;;;
;;; regardless of its current position ;;;
;;; 3. the are is formatted in the current units ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:labelarea (ent / elist xdata text start area)
(vl-load-com)
(regapp "LABELAREA")
(setq elist (entget ent '("LABELAREA"))
xdata (assoc -3 elist)
text (if xdata
(entget (handent (cdr (cadadr xdata))))
)
start (if (not text)
(cdr (assoc 10 elist))
)
area (vla-get-area (setq ent (vlax-ename->vla-object ent)))
)
(if (not text)
(progn
(setq text (vla-addtext (vla-get-block (vla-item
(vla-get-layouts
(vla-get-activedocument
(vlax-get-acad-object)
)
) (cdr
(assoc 410
elist
)
)
)
) (rtos area) (vlax-3d-point start) 0.25
)
)
)
(vla-put-textstring (setq text (vlax-ename->vla-object (cdr
(assoc -1
text
)
)
)
)
(rtos area)
)
)
(vla-setxdata ent (vlax-make-variant (vlax-safearray-fill
(vlax-make-safearray vlax-vbinteger '
(0 . 1)
) '
(1001 1005)
)
) (vlax-make-variant (vlax-safearray-fill
(vlax-make-safearray vlax-vbvariant '
(0 . 1)
)
(list "LABELAREA"
(vla-get-handle text)
)
)
)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:labelordinate (ss attname ordinate) ;;;
;;; purpose: cycles through a selection set filling a specified attribute
;;; with a ;;;
;;; block's position (x, y or z) ;;;
;;; arguments: a selection set containing blocks to label, the name of the
;;; attribute to ;;;
;;; change and an integer indicating which ordinate value to
;;; use ;;;
;;; (0=x, 1=y, 2=z) ;;;
;;; example: (ex:labelordinate ss "pos" 0) ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:labelordinate (ss attname ordinate / c block atts val att)
(vl-load-com)
(setq c -1)
(repeat (sslength ss)
(setq block (vlax-ename->vla-object (ssname ss (setq c (1+ c))))
atts (vlax-safearray->list (vlax-variant-value
(vla-getattributes block)
)
)
val (rtos (nth ordinate (vlax-safearray->list
(vlax-variant-value
(vla-get-insertionpoint block)
)
)
) 2 0
)
)
(foreach att atts
(if (= (strcase attname) (strcase (vla-get-tagstring att)))
(vla-put-textstring att val)
)
)
(vla-update block)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:listlayouts () ;;;
;;; purpose: returns a list containing all layouts in the current
;;; document ;;;
;;; arguments: none ;;;
;;; example: ;;;
;;; notes: 1. ex:listlayouts returns a list of layout names sorted by
;;; tab order, ;;;
;;; not name like layoutlist ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:listdocuments (/ fname lst)
(vl-load-com)
(vlax-for doc (vla-get-documents (vlax-get-acad-object)) (setq lst
(cons
(if
(/=
(setq fname
(vla-get-fullname doc)
)
""
)
fname
(vla-get-name doc)
) lst
)
)
)
(reverse lst)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:listdocuments () ;;;
;;; purpose: returns a list containing the name or full path of every
;;; open document. ;;;
;;; arguments: none ;;;
;;; example: ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:listlayouts (/ layouts c lst lay)
(vl-load-com)
(setq layouts (vla-get-layouts (vla-get-activedocument
(vlax-get-acad-object)
)
)
c -1
)
(repeat (vla-get-count layouts)
(setq lst (cons (setq c (1+ c))
lst
)
)
)
(vlax-for lay layouts (setq lst (subst
(vla-get-name lay)
(vla-get-taborder lay)
lst
)
)
)
(reverse lst)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:listtoolbars (groupname) ;;;
;;; purpose: returns a list containing the name of every toolbar in the
;;; secified menu group ;;;
;;; arguments: a string containing the name of a currently loaded menu
;;; group ;;;
;;; example: (ex:listtoolbars "acad") ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:listtoolbars (groupname / mgroups mgroup lst)
(vl-load-com)
(if (not (vl-catch-all-error-p (setq mgroup (vl-catch-all-apply 'vla-item
(list
(vla-get-menugroups
(vlax-get-acad-object)
) groupname
)
)
)
)
)
(vlax-for tbar (vla-get-toolbars mgroup) (setq lst (cons
(vla-get-name tbar)
lst
)
)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:makelayer (lname) ;;;
;;; purpose: create a new layer. ;;;
;;; arguments: the new layer name ;;;
;;; example: (ex:makelayer "a-wall") ;;;
;;; notes: returns the new layer object on successful creation, an
;;; existing layer ;;;
;;; object if the layer already exists, or nil if the layer name
;;; cannot be created.
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:makelayer (lname / olayer)
(vl-load-com)
(if (vl-catch-all-error-p (setq olayer (vl-catch-all-apply 'vla-add
(list
(vla-get-layers
(vla-get-activedocument
(vlax-get-acad-object)
)
) lname
)
)
)
)
nil
olayer
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:renamelayout (oldname newname) ;;;
;;; purpose: rename an existing layout ;;;
;;; arguments: a string containing the name of the layout to renam and a
;;; string ;;;
;;; containing the new name for it ;;;
;;; example: (ex:renamelayout "layout1" "mylayout") ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:renamelayout (oldname newname)
(vl-load-com)
(vla-put-name (vla-item (vla-get-layouts (vla-get-activedocument
(vlax-get-acad-object)
)
) oldname
) newname
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:selectattributedblocks (lst) ;;;
;;; purpose: returns a selection set containing blocks whose attribute
;;; values match ;;;
;;; the specified criteria ;;;
;;; arguments: a block name, the attribute tag which to search and the
;;; value being sought;;;
;;; example: (ex:selectattributedblocks '("window" "keynote" "57"))
;;; ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:selectattributedblocks (lst / ss ss2 c ent att)
(vl-load-com)
(if (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 2 (car lst)))))
(progn
(setq c 0)
(repeat (sslength ss)
(setq ent (vlax-ename->vla-object (ssname ss c)))
(if (vla-get-hasattributes ent)
(foreach att (vlax-safearray->list (vlax-variant-value
(vla-getattributes ent)
)
)
(if (= (strcase (vla-get-tagstring att)) (strcase (cadr lst)))
(if (= (strcase (vla-get-textstring att)) (strcase
(caddr lst)
)
)
(progn
(vla-highlight ent :vlax-true)
(if (not ss2)
(setq ss2 (ssadd (ssname ss c)))
(ssadd (ssname ss c) ss2)
)
)
)
)
)
)
(setq c (1+ c))
)
)
)
ss2
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:setprofile (pname) ;;;
;;; purpose: sets a profile active ;;;
;;; arguments: the name of an existing profile ;;;
;;; example: (ex:setprofile "myprofile") ;;;
;;; notes: 1. this cannot be used to initialize a "vertical" product
;;; from autocad. ;;;
;;; in other words, you cannot start autocad and switch to something
;;; like ;;;
;;; mechanical desktop. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:setprofile (pname)
(vl-load-com)
(vla-put-activeprofile (vla-get-profiles (vla-get-preferences
(vlax-get-acad-object)
)
) pname
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:togglelayouts () ;;;
;;; purpose: toggles the display of layout tabs ;;;
;;; arguments: none ;;;
;;; example: none ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:togglelayouts (/ prefdisplay)
(vl-load-com)
(setq prefdisplay (vla-get-display (vla-get-preferences
(vlax-get-acad-object)
)
)
)
(vla-put-displaylayouttabs prefdisplay (if (=
(vla-get-displaylayouttabs prefdisplay)
:vlax-true
)
:vlax-false
:vlax-true
)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:togglemsbackground () ;;;
;;; purpose: toggles the modelspace background color between black and
;;; white ;;;
;;; arguments: none ;;;
;;; example: none ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:togglemsbackground (/ prefdisplay)
(vl-load-com)
(setq prefdisplay (vla-get-display (vla-get-preferences
(vlax-get-acad-object)
)
)
color (vlax-variant-value (vlax-variant-change-type
(vla-get-graphicswinmodelbackgrndcolor prefdisplay)
vlax-vblong
)
)
)
(vla-put-graphicswinmodelbackgrndcolor prefdisplay
(vlax-make-variant (if (= color 0)
16777215
0
) vlax-vblong
)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:togglepsbackground () ;;;
;;; purpose: toggles the paperspace background color between black and
;;; white ;;;
;;; arguments: none ;;;
;;; example: none ;;;
;;; notes: none ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:togglepsbackground (/ prefdisplay)
(vl-load-com)
(setq prefdisplay (vla-get-display (vla-get-preferences
(vlax-get-acad-object)
)
)
color (vlax-variant-value (vlax-variant-change-type
(vla-get-graphicswinlayoutbackgrndcolor prefdisplay)
vlax-vblong
)
)
)
(vla-put-graphicswinlayoutbackgrndcolor prefdisplay
(vlax-make-variant (if (= color 0)
16777215
0
) vlax-vblong
)
)
(princ)
)
;;; ************************************************************************
;;; **************;;;
;;; module: c:layerfiltersdelete () ;;;
;;; purpose: delete all layer filters in the current drawing. ;;;
;;; arguments: none ;;;
;;; example: command: layerfiltersdelete ;;;
;;; --or-- ;;;
;;; command: lfd ;;;
;;; notes: i could not see doing this as anything other than a user
;;; command. ;;;
;;; but the original command names is too long to type in, hence
;;; the aliased version.
;;; author: r. robert bell ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun c:layerfiltersdelete ()
(vl-load-com)
(vl-catch-all-apply '(lambda ()
(vla-remove (vla-getextensiondictionary
(vla-get-layers
(vla-get-activedocument
(vlax-get-acad-object)
)
)
) "ACAD_LAYERFILTERS"
)
)
)
(princ "\nAll layer filter have been deleted.")
(princ)
)
(defun c:lfd ()
(c:layerfiltersdelete)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:listtovariantarray (lst vartype) ;;;
;;; purpose: converts a list to an activex variant array ;;;
;;; arguments: a list. the list can be nested up to one level deep. ;;;
;;; e.g.: (list "1" 2 (list 1.0 2.0 3.0)) ;;;
;;; example: (listtovariantarray (list (list 2.0 3.0 0.0) 1 2.0
;;; "string")) ;;;
;;; notes: 1. if your list includes various data types, pass
;;; vlax-vbvariant for the ;;;
;;; vartype argument ;;;
;;; 2. entity names are converted to objectids ;;;
;;; 3. to convert a point list to activex coordinates: ;;;
;;; (list->variantarray (apply 'append ptlist) vlax-vbdouble)
;;; ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:listtovariantarray (lst vartype)
(vl-load-com)
(vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vartype
(cons 0
(1-
(length lst)
)
)
) (mapcar
'(lambda (x)
(cond
((= (type x) 'list)
(vlax-safearray-fill
(vlax-make-safearray
(if
(apply
'=
(mapcar
'type
x
)
)
(cond
(
(=
(type
(car x)
) 'real
)
vlax-vbdouble
)
(
(=
(type
(car x)
) 'int
)
vlax-vbinteger
)
(
(=
(type
(car x)
) 'str
)
vlax-vbstring
)
)
vlax-vbvariant
)
(cons 0
(1-
(length x)
)
)
)
x
)
)
((= (type x) 'ename)
(vla-get-objectid
(vlax-ename->vla-object x)
)
)
(t
x
)
)
)
lst
) ; mapcar
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: ex:selectionsettoarray (ss) ;;;
;;; purpose: returns an variant array of subtype object filled with the
;;; contents of ;;;
;;; a selection set. ;;;
;;; arguments: a selection set ;;;
;;; example: (selectonsettoarray myss) ;;;
;;; notes: 1. use this whenever you need to pass a selecton set as an
;;; array to an ;;;
;;; activex function ;;;
;;; 2. if you need a different subtype, simply change the reference
;;; to ;;;
;;; vlax-vbobject. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun ex:selectionsettoarray (ss / c r)
(vl-load-com)
(setq c -1)
(repeat (sslength ss)
(setq r (cons (ssname ss (setq c (1+ c))) r))
)
(setq r (reverse r))
(vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0
(1-
(length r)
)
)
) (mapcar
'vlax-ename->vla-object
r
)
)
)
;;; utilities... -->>
;;; ************************************************************************
;;; **************;;;
;;; module: xllist->listofpoints (coordlist / ptlist) ;;;
;;; purpose: convert a list of x, y values from a single list into a list
;;; of paired ;;;
;;; lists from (x y x y x y ...) into ((x y)(x y)(x y)...) ;;;
;;; notes: this is necessary to convert the results of using
;;; (vla-get-coordinates) ;;;
;;; on a lwpolyline object into a list of vertext points ;;;
;;; source: taken from garden path tutorial ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun xylist->listofpoints (coordlist / ptlist)
(while coordlist
(setq ptlist (append
ptlist
(list (list (car coordlist) (cadr coordlist)))
)
coordlist (cddr coordlist)
)
)
ptlist
)
;;; ************************************************************************
;;; **************;;;
;;; module: is-vla-object (obj) ;;;
;;; purpose: boolean test if data type is vla-object ;;;
;;; ************************************************************************
;;; **************;;;
(defun is-vla-object (obj)
(equal (type obj) 'vla-object)
)
;;; ************************************************************************
;;; **************;;;
;;; module: is-string (arg) ;;;
;;; purpose: boolean test if data type is string ;;;
;;; ************************************************************************
;;; **************;;;
(defun is-string (arg)
(equal (type arg) 'str)
)
;;; ************************************************************************
;;; **************;;;
;;; module: is-real (arg) ;;;
;;; purpose: boolean test if data type is real number(double, float,
;;; etc.) ;;;
;;; ************************************************************************
;;; **************;;;
(defun is-real (arg)
(equal (type arg) 'real)
)
;;; ************************************************************************
;;; **************;;;
;;; module: is-ename (arg) ;;;
;;; purpose: boolean test if data type is autocad ename (entity name)
;;; ;;;
;;; ************************************************************************
;;; **************;;;
(defun is-ename (arg)
(equal (type arg) 'ename)
)
;;; ************************************************************************
;;; **************;;;
;;; module: is-variant (arg) ;;;
;;; purpose: boolean test if data type is variant ;;;
;;; ************************************************************************
;;; **************;;;
(defun is-variant (arg)
(equal (type arg) 'variant)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-makeename (object) ;;;
;;; purpose: convert vla-object into ename data type ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-makeename (object)
(if (is-vla-object object)
(vlax-vla-object->ename object)
object
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-makeobject (object) ;;;
;;; purpose: convert ename into vla-object data type ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-makeobject (object)
(if (is-ename object)
(vlax-ename->vla-object object)
object
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: intlist->vararray (alist) ;;;
;;; purpose: convert a list of integer values into a variant safe-array
;;; ;;;
;;; ************************************************************************
;;; **************;;;
(defun intlist->vararray (alist)
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger ; (2) integer
(cons 0 (- (length alist) 1))
) alist
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: varlist->vararray (alist) ;;;
;;; purpose: convert a list of variant values into a variant safe-array
;;; ;;;
;;; ************************************************************************
;;; **************;;;
(defun varlist->vararray (alist)
(vlax-safearray-fill (vlax-make-safearray vlax-vbvariant ; (12) variant
(cons 0 (- (length alist) 1))
) alist
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-applyltypegen (object) ;;;
;;; purpose: apply linetype generation to lwpolyline object ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-applyltypegen (object / obj)
(setq object (vlex-makeobject object)) ; make sure not ename first!
(vla-put-linetypegeneration object :vlax-true)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-put-bylayer (obj) ;;;
;;; purpose: put object color=bylayer, linetype=bylayer ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-put-bylayer (obj)
(if (vlax-write-enabled-p obj)
(progn
(vla-put-color obj 255) ; (vla-put-linetype obj ...);; <-- i
; need to figure this out!!!
)
) ; endif
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-activelayout () ;;;
;;; purpose: returns object to active layout ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-activelayout ()
(vla-get-activelayout (vlex-activedocument))
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-activelayoutname () ;;;
;;; purpose: returns object name to active layout (string value) ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-activelayoutname ()
(vla-get-name (vlex-activelayout))
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-activeplotconfig () ;;;
;;; purpose: returns object to active plot configuration ;;;
;;; debug: nil ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-plotconfigs (/ pc out)
(vlax-for each (vlax-get-property (vlex-activedocument)
'plotconfigurations
) (if (vlax-property-available-p each 'getplotdevicenames)
(setq out (cons (vlax-get-property each
'getplotdevicenames
) out
)
)
) (setq itemname (vlex-name each)
out (cons itemname out)
)
)
out
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-snapoff () ;;;
;;; purpose: turns off osnaps ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-snapoff ()
(vla-put-objectsnapmode (vlex-activedocument) :vlax-false)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-snapon () ;;;
;;; purpose: turns on osnaps ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-snapon ()
(vla-put-objectsnapmode (vlex-activedocument) :vlax-true)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-opendwg (fullname) ;;;
;;; purpose: open named drawing file(no error trapping is done! ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-opendwg (fullname)
(command "vbastmt" (strcat "AcadApplication.Documents.Open " (chr 34)
fullname (chr 34)
)
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-dwgnamed-p () ;;;
;;; purpose: returns t if drawing has been saved with a name, otherwise
;;; returns 'nil'. ;;;
;;; debug: t ;;;
;;; ************************************************************************
;;; **************;;;
(defun vlex-dwgnamed-p ()
(if (= 1 (getvar "dwgtitled"))
t
nil
)
)
;;; ************************************************************************
;;; **************;;;
;;; module: vlex-activeplotconfig () ;;;
;;; purpose: returns object to active plot configuration ;;;
;;; ************************************************************************
;;; **************;;;
;;; zooming functions... --->
(defun vlex-zoomextents ()
(vla-zoomextents (vlex-acadobject))
)
(defun vlex-zoomall ()
(vla-zoomall (vlex-acadobject))
)
(defun vlex-zoomcenter (pt)
(vla-zoomcenter (vlex-acadobject) (vlax-3d-point pt) 1.0)
)
(defun vlex-zoomprevious ()
(vla-zoomprevious (vlex-acadobject))
)
(defun vlex-zoomwindow (p1 p2)
(vla-zoomwindow (vlex-acadobject) (vlax-3d-point p1)
(vlax-3d-point p2)
)
)
(defun vlex-zoomout ()
(vla-zoomout (vlex-acadobject) 0.5 1)
)
(defun vlex-zoomin ()
(vla-zoomscaled (vlex-acadobject) 2.0 1)
)
;;; ************************************************************************
;;; ***;;;
;;; module: vlex-help
;;; ;;;
;;; description:
;;; ;;;
;;; args:
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; ***;;;
(defun vlex-help (/ cmd)
(setq separator "///////////////////////////////////////")
(foreach cmd (list separator "VLEX Constant Globals:" "Acad-Object"
"vlex-ActiveDocument" "vlex-PaperSpace"
"vlex-ActiveSpace" "vlex-ModelSpace" "vlex-AcadPrefs"
separator "VLEX Exposed Functions:" ; environment
; profiles
"vlex-GetPrefKey" "vlex-SetPrefKey"
"vlex-ProfileImport" "vlex-ProfileExport"
"vlex-ProfileExists-p" "vlex-ProfileDelete"
"vlex-ProfileList" "vlex-Profiles" "vlex-ProfileReLoad"
"vlex-ProfileExportX" "vlex-ProfileCopy"
"vlex-ProfileRename" "vlex-ProfileReset" separator ; d
; ocuments
"vlex-CloseAllDocs" "vlex-SaveAllDocs"
"vlex-SaveAs2000" "vlex-SaveAsR14" "vlex-Saved-p"
"vlex-PurgeAllDocs" "vlex-GetDocsCollection"
"vlex-DocCollection" "vlex-DocsCount" "vlex-DocsList"
separator ; properties
"vlex-CopyProp" "vlex-MapPropertyList"
"vlex-ChangeAttributes" "vlex-GetAttributes" separator ; string
"vlex-ParseString" "vlex-Massoc" separator ; undo
"vlex-UndoBegin" "vlex-UndoEnd" separator ; return
; list
"vlex-Extents" "vlex-RectCenter" "vlex-Mid"
"vlex-PolyCentroid" "vlex-GetPolySegment"
"vlex-GetEllipseArcPoints" separator ; object
"vlex-AcadProp" "vlex-ObjectType" "vlex-MakeObject"
"vlex-DeleteObject" "vlex-DumpIt" "vlex-Name"
"vlex-MxRelease" separator ; collection
"vlex-CollectionCount" "vlex-CollectionList"
"vlex-AcadCollection" "vlex-MapCollection"
"vlex-DumpCollection" separator ; modify1
"vlex-IsClosed" "vlex-CloseArc" separator ; sort
"vlex-SortPoints" separator ; linetype
"vlex-CountLtypes" "vlex-Ltype-Exists-p" separator ; v
; lex-getxxx
"vlex-GetLayers" "vlex-GetLtypes" "vlex-GetTextStyles"
"vlex-GetDimStyles" "vlex-GetLayouts"
"vlex-GetDictionaries" "vlex-GetBlocks"
"vlex-GetPlotConfigs" "vlex-GetViews"
"vlex-GetViewPorts" "vlex-GetGroups" "vlex-GetRegApps"
separator ; vlex-listxxx
"vlex-ListLayers" "vlex-ListLtypes"
"vlex-ListTextStyles" "vlex-ListDimStyles"
"vlex-ListLayouts" "vlex-ListDictionaries"
"vlex-ListBlocks" "vlex-ListPlotConfigs"
"vlex-ListViews" "vlex-ListViewPorts" "vlex-ListGroups"
"vlex-ListRegApps"
separator ; create entity
"vlex-AddArc" "vlex-AddCircle" "vlex-AddLine"
"vlex-AddLineC" "vlex-AddPline" "vlex-AddEllipse"
"vlex-AddEllipseArc1" "vlex-AddEllipseArc2"
"vlex-AddRectangle" "vlex-AddPolygon"
"vlex-Apply-Ltype" "vlex-Apply-LtScale"
"vlex-AddPolygon" "vlex-AddRectangle" "vlex-AddSolid"
separator ; transition
"vlex-DTR" "vlex-RTD" "3dpoint->2dpoint"
"3dpoint-list->2dpoint-list" "vlex-Roll-Ratio"
"vlex-DblList->VariantArray" "vlex-IntList->VarArray"
"vlxx-VarList->VarArray" separator ; prompt
"vlex-DPR" separator ; sysvars
"vlex-VarSave" "vlex-VarRestore" separator ; layers
"vlex-LayerTable" "vlex-LayZero" "vlex-LayActive"
"vlex-LayActive" "vlex-LayerOn" "vlex-LayerOff"
"vlex-LayerFreeze" "vlex-LayerThaw" "vlex-LayerNoPlot"
"vlex-LayerLock" "vlex-LayerUnLock"
"vlex-ListLayers-Locked" "vlex-ListLayers-Frozen"
"vlex-ListLayers-Off" "vlex-ListLayers-Plottable"
"vlex-ListLayers-Plottalbe-Not" "vlex-Layer-Frozen-p"
"vlex-SetLweight" separator ; selection sets
"vlex-SSetExists-p" "vlex-SelectByType"
"vlex-SelectOnScreen-Filter" "vlex-PICKCIRCLES"
"C:GETCIRCLES" separator ; application state . . .
"vlex-GetWindowState" "vlex-SetWindowState"
"vlex-HideAutoCAD" "vlex-ShowAutoCAD"
"vlex-HideShowTest" "vlex-DocPrefs" "vlex-LWdisplayON"
"vlex-LWdisplayOFF" "vlex-ObjectSortBySnapON"
"vlex-ObjectSortBySnapOFF" "vlex-XrefEditON"
"vlex-XrefEditOFF" separator ; menus & toolbars. . .
"vlex-MenuGroups" "vlex-MenuGroups-ListAll"
"vlex-MenuGroup-Exists-p" "vlex-Toolbars"
"vlex-Toolbars-ListAll" "vlex-Toolbar-Exists-p"
"vlex-Toolbar" "vlex-Toolbar-Show" "vlex-Toolbar-Hide"
"vlex-Toolbar-Dock" "vlex-Toolbar-Folat" separator ; v
; isual lisp custom functions. . .
"ex:2DPoint" "ex:ActivateLastLayout"
"ex:AddObjectsToBlock" "ex:MappedShare"
"ex:BuildFilter" "ex:Centroid" "ex:ChangeAttributes"
"ex:ChangeBitmap" "ex:CloseAll"
"ex:DeleteObjectFromBlock" "ex:DrawVpBorder"
"ex:DriveType" "ex:ListDrives" "ex:Parse"
"ex:ExportProject" "ex:ImportProject"
"ex:GetAttributes" "ex:GetBoundingBox"
"ex:GetConstantAttributes"
"ex:GetCurveLength" "ex:GetFileSize" "ex:GetLastHeight"
"ex:SetLastHeight" "ex:GetParentBlocks"
"ex:ListBLockRefs" "ex:GetPlotDevices" "ex:PutXData"
"ex:lisp-value" "ex:GetXData" "ex:LabelArea"
"ex:LabelOrdinate" "ex:ListDocuments" "ex:ListLayouts"
"ex:ListToolbars" "ex:MakeLayer" "ex:RenameLayout"
"ex:SelectAttributedBlocks" "ex:SetProfile"
"ex:ToggleLayouts" "ex:ToggleMSBackground"
"ex:TogglePSBackground" "C:LayerFiltersDelete"
"ex:listToVariantArray" "ex:selectionsetToArray"
separator ; utilities...
"vlex-ActiveSpace-Name" "xyList->ListOfPoints"
"Is-Vla-Object" "Is-String" "Is-Real" "Is-Ename"
"Is-Variant" "vlex-MakeEname" "vlex-MakeObject"
"IntList->VarArray" "VarList->VarArray"
"vlex-ApplyLtypeGen" "vlex-Put-ByLayer"
"vlex-ActiveLayout" "vlex-ActiveLayoutName"
"vlex-PlotConfigs" "vlex-OpenDwg" "vlex-DwgNamed-p"
separator ; zooming functions...
"vlex-ZoomExtents" "vlex-ZoomAll" "vlex-ZoomCenter"
"vlex-ZoomPrevious" "vlex-ZoomWindow" "vlex-ZoomOut"
"vlex-ZoomIn"
)
(princ cmd)
(terpri)
)
(princ)
)
;;; ************************************************************************
;;; *;;;
;;; module:
;;; ;;;
;;; description:
;;; ;;;
;;; args:
;;; ;;;
;;; example:
;;; ;;;
;;; ************************************************************************
;;; *;;;
(defun vlex-version ()
(princ "\nVlex-Lisp 2004 ver. 1.00")
(princ "\nCopyright (C) 2004 Kama Whaley, All rights reserved.")
(terpri)
(princ)
)
(vlex-version)
(princ)
vlex-vlisp.rar
posted on 2008-03-12 21:35
深藏记忆 阅读(1395)
评论(0) 编辑 收藏 所属分类:
Vlisp之韵