vlex-函数的收集

繁花落叶 · 发表于 2012-11-8 15:28:03

看到明经上没有vlex的函数，特发一篇，供大家学习，一同进步。请大家多多支持。

;;;***************************************************************************;;;
;;; 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 26th 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:\\profiles\\profile1.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
)

;;;***************************************************************************;;; 
;;; vlex-vlisp.lsp                    ;;; 
;;; Assorted Visual LISP ActiveX Extention Functions for <a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a> 2004         ;;; 
;;; Copyright (C)2003 Kama Whaley, All rights reserved.            ;;; 
;;; Some functional code adapted from public sources.            ;;; 
;;; Latest Modify Date : Friday 26th 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:\\profiles\\profile1.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 
)

zyhandw · 发表于 2012-11-8 15:44:24

不会啊，明经上本来就有啊！http://bbs.mjtd.com/forum.php?mod=viewthread&tid=15980

账号		自动登录	找回密码
密码			注册

vlex-函数的收集

相关帖子