TheSwamp
Code Red => VB(A) => Topic started by: mkweaver on November 08, 2007, 02:33:06 PM
-
I would like to get a list of all the properties for an object into an array. Is there any way to do this with VBA?
Specifically, I want to get all of the properties for a layer along with the values so I can store them or copy them to another drawing. I don't want to specify the properties because I want the code to accept new properties as they are added to the object model.
All suggestions welcome,
Mike Weaver
-
I don't think it's possible. I would really love to be proven wrong on this, just because it will be cool to see though.
-
MSDN has an article http://msdn.microsoft.com/msdnmag/issues/1200/TypeLib/default.aspx (http://msdn.microsoft.com/msdnmag/issues/1200/TypeLib/default.aspx) that explains how to do it using tlbinf32.dll, but I was hoping there was something built into vba.
Mike
-
Can be done with Lisp. Look at the 'atoms-family' function.
-
Tim,
The only way I can see to possibly get a list of object properties with Atoms-Family is to check each member of Atoms-Family against my object to see if it is a property of that object using vlax-property-available-p. Is this what you had in mind, or is there another way I'm missing?
Mike Weaver
-
Tim,
The only way I can see to possibly get a list of object properties with Atoms-Family is to check each member of Atoms-Family against my object to see if it is a property of that object using vlax-property-available-p. Is this what you had in mind, or is there another way I'm missing?
Mike Weaver
That is the way I was thinking, and how it was shown to me my MP (from here). I don't know of any other way Mike.
-
Clone it using an AxDbDocument and ThisDrawing.CopyObjects from memory.
-
MSDN has an article http://msdn.microsoft.com/msdnmag/issues/1200/TypeLib/default.aspx (http://msdn.microsoft.com/msdnmag/issues/1200/TypeLib/default.aspx) that explains how to do it using tlbinf32.dll, but I was hoping there was something built into vba.
Mike
Using info from above link, this code (as ugly and kludgy as it may be) will return a collection filled with properties of a desired Autocad entity
Function BestClassInfo(ByVal Object As Object) As TypeInfo
Set BestClassInfo = TLI.ClassInfoFromObject(Object)
On Error GoTo NotAvailable
With BestClassInfo.Parent
With TLI.TypeLibInfoFromRegistry _
(.GUID, .MajorVersion, .MinorVersion, .LCID)
Set BestClassInfo = .Me.TypeInfos.IndexedItem(BestClassInfo.TypeInfoNumber)
End With
End With
Exit Function
NotAvailable:
Err.Clear
End Function
Function ImplementedInterfaces( _
ByVal ccInfo As CoClassInfo, _
Libs As Collection, _
Optional ByVal fIncludeDefault As Boolean = True) As SearchResults
Dim SR As SearchResults
Dim IFace As InterfaceInfo
Dim TLInf As TypeLibInfo
Dim TLInfLast As TypeLibInfo
Dim strKey As String
Dim TypeInfos(0) As Integer
Dim tinfoDefault As IUnknown
Dim fLookupLib As Boolean
Set Libs = New Collection
If Not fIncludeDefault Then
Set tinfoDefault = ccInfo.DefaultInterface.ITypeInfo
End If
On Error GoTo Error
For Each IFace In ccInfo.Interfaces
If 0 = (IFace.AttributeMask And _
(IMPLTYPEFLAG_FSOURCE Or IMPLTYPEFLAG_FRESTRICTED)) Then
If Not fIncludeDefault Then
If tinfoDefault Is IFace.ITypeInfo Then
'Turn off default check once we find it
fIncludeDefault = True
GoTo DoNext
End If
End If
Set TLInf = IFace.Parent
TypeInfos(0) = IFace.TypeInfoNumber
fLookupLib = True
If TLInfLast Is Nothing Then
ElseIf TLInf.IsSameLibrary(TLInfLast) Then
'TLInfLast is simply an optimization.
'Checking IsSameLibrary is faster than
'doing a collection lookup.
fLookupLib = False
'Use the TypeLibInfo object from the
'collection so that it has the LibNum set
Set TLInf = TLInfLast
End If
If fLookupLib Then
strKey = CStr(ObjPtr(TLInf.ITypeLib))
On Error Resume Next
'Use the TypeLibInfo object from the
'collection so that it has the LibNum set
Set TLInf = Libs(strKey)
If Err Then
'New library
TLInf.LibNum = Libs.Count + 1
Libs.Add TLInf, strKey
Set TLInfLast = TLInf
End If
On Error GoTo Error
End If
'Call AddTypes, appending to the previous collection
Set ImplementedInterfaces = _
TLInf.AddTypes(TypeInfos, ImplementedInterfaces, , False)
End If
DoNext:
Next
Exit Function
Error:
Resume DoNext
End Function
Public Function ExtractProperties(pEntTypeName As String) As Collection
'Calling Code
Dim TLInf As TypeLibInfo
Dim SR As SearchResults
Dim SI As SearchItem
Dim Libs As Collection
Dim SRMembers As SearchResults
Dim ccInfo As CoClassInfo
Dim xCoInfo1 As CoClassInfo
Dim xCoInfo2 As CoClassInfo
Dim xTLInfo3 As TypeLibInfo
Dim myCoClasses As CoClasses
Dim strEntType As String
Dim oMyObj As Object
Dim i As Integer
Dim myTypeInfo As TypeInfo
Dim PropList() As String
Dim myInterfaceInfo As InterfaceInfo
Dim PropCollection As Collection
strEntType = "AcadCircle"
Set ccInfo = BestClassInfo(ThisDrawing)
Set SR = ImplementedInterfaces(ccInfo, Libs)
If Not SR Is Nothing Then
SR.Sort
For Each SI In SR
'Do a set first to avoid late bound calls
'against TLI objects
Set TLInf = Libs(SI.LibNum)
Set SRMembers = TLInf.GetMembers(SI.SearchData)
'Process members
Next
End If
Set myCoClasses = Libs.Item(1).CoClasses
For i = 1 To myCoClasses.Count
Set xCoInfo1 = myCoClasses(i)
If xCoInfo1.Name = pEntTypeName Then
Set xCoInfo2 = xCoInfo1
Set myTypeInfo = TLInf.GetTypeInfo(xCoInfo2.TypeInfoNumber)
End If
Set xCoInfo1 = Nothing
Next
Set myInterfaceInfo = xCoInfo2.Interfaces(1)
ReDim PropList(1 To myInterfaceInfo.Members.Count)
Set PropCollection = New Collection
For i = 1 To myInterfaceInfo.Members.Count
PropList(i) = myInterfaceInfo.Members(i).Name
If myInterfaceInfo.Members(i).InvokeKind = INVOKE_PROPERTYGET Then
PropCollection.Add myInterfaceInfo.Members(i).Name
End If
Next i
Set ExtractProperties = PropCollection
End Function
' ********this is the callable code ************
Public Sub TestExtract()
Dim colProperties As Collection
Set colProperties = New Collection
Set colProperties = ExtractProperties("AcadCircle") ' put your desire entity here
End Sub
Most of the code comes from the Help file for Type Lib Information Library.
Your VBA project must include a reference to TypeLineInformation (tlbinf32.dll)
Have fun :)
The result are in the attached image
-
Tim,
The only way I can see to possibly get a list of object properties with Atoms-Family is to check each member of Atoms-Family against my object to see if it is a property of that object using vlax-property-available-p. Is this what you had in mind, or is there another way I'm missing?
Mike Weaver
That is the way I was thinking, and how it was shown to me my MP (from here). I don't know of any other way Mike.
With Layer set to a layer object, I get the following:
(setq temp (vl-remove-if-not (function (lambda(var)
(vlax-property-available-p layer var))) (atoms-family 0)))
(LAYERON)
Not quite what I was expecting
-
OK, forget all that stuff in my previous post.
It gets a WHOLE lot easier.
A reference to TypeLineInformation (tlbinf32.dll) is still needed.
Public Sub testGetProps()
Dim cData As Collection
Set cData = dkb_GetProperties(ThisDrawing.ModelSpace(0)) 'select your object however suits you best
End Sub
Public Function dkb_GetProperties(pObject As Acad0bject) As Collection
Dim iInterFaceInfo As InterfaceInfo
Dim cClassInfo As TypeInfo
Dim colProperties As Collection
Dim i As Integer
Set colProperties = New Collection
Set iInterFaceInfo = InterfaceInfoFromObject(pObject)
For i = 1 To iInterFaceInfo.Members.Count
If iInterFaceInfo.Members(i).InvokeKind = INVOKE_PROPERTYGET Then
colProperties.Add iInterFaceInfo.Members(i).Name
End If
Next i
Set dkb_GetProperties = colProperties
End Function
-
Here is the results for a layer
Set cData = dkb_GetProperties(ThisDrawing.Layers(0))
-
Here is the results for a layer
Set cData = dkb_GetProperties(ThisDrawing.Layers(0))
Very good, Dave!
-
<applause.wav>
(http://www.theswamp.org/screens/mp/thumbsup.gif)
(Sorry for the brevity, long day, I'm bagged).
-
Not the first time and it won't be the last but my hat is off to you Dave.
-
Thanks guys, but all I really did was explore a help file and play with the Locals window in VBA.
tlbinf32.dll is definitely worth investigating. If I find any more goodies, I will post them.
I'm thinking this might be a good way to find some hidden functions/properties.
-
Thanks guys, but all I really did was explore a help file and play with the Locals window in VBA.
Yeah, but it's a gooder!
Something I'm working on for the lispin' folks --
(_GetPropertiesAndMethods (_ObjSel))
Select object: <Michael selects a sphere>
(
(PROPERTIES
("Application" #<VLA-OBJECT IAcadApplication 00d73d3c>)
("Centroid" (1568.79 542.192 0.0))
("color" 256)
("Database" #<VLA-OBJECT IAcadDatabase 0bc1cb6c>)
("Document" #<VLA-OBJECT IAcadDocument 0775f300>)
("EntityName" "AcDb3dSolid")
("EntityType" 3)
("Handle" "1AE")
("HasExtensionDictionary" 0)
("History" -1)
("Hyperlinks" #<VLA-OBJECT IAcadHyperlinks 0bc2851c>)
("Layer" "0")
("Linetype" "ByLayer")
("LinetypeScale" 1.0)
("Lineweight" -1)
("Material" "ByLayer")
("MomentOfInertia" (5.97049e+011 4.96199e+012 5.55409e+012))
("ObjectID" 2130322288)
("ObjectName" "AcDb3dSolid")
("OwnerID" 2130316536)
("PlotStyleName" "ByLayer")
("Position" (1568.79 542.192 0.0))
("PrincipalDirections" (1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0))
("PrincipalMoments" (4.94487e+009 4.94487e+009 4.94487e+009))
("ProductOfInertia" (1.71321e+012 0.0 0.0))
("RadiiOfGyration" (544.451 1569.57 1660.58))
("ShowHistory" 0)
("SolidType" "Sphere")
("TrueColor" #<VLA-OBJECT IAcadAcCmColor 0bb8c3d0>)
("Visible" -1)
("Volume" 2.01415e+006)
)
(METHODS
;; The number is the argument count. The next version will actually
;; name the arguments and spec the data type. Ha ha ha ha ha ha.
("AddRef" 0)
("ArrayPolar" 3)
("ArrayRectangular" 6)
("Boolean" 2)
("CheckInterference" 2)
("color" 0)
("Copy" 0)
("Delete" 0)
("Erase" 0)
("GetBoundingBox" 2)
("GetExtensionDictionary" 0)
("GetIDsOfNames" 5)
("GetTypeInfo" 3)
("GetTypeInfoCount" 1)
("GetXData" 3)
("Highlight" 1)
("History" 0)
("IntersectWith" 2)
("Invoke" 8)
("Layer" 0)
("Linetype" 0)
("LinetypeScale" 0)
("Lineweight" 0)
("Material" 0)
("Mirror" 2)
("Mirror3D" 3)
("Move" 2)
("PlotStyleName" 0)
("Position" 0)
("QueryInterface" 2)
("Release" 0)
("Rotate" 2)
("Rotate3D" 3)
("ScaleEntity" 2)
("SectionSolid" 3)
("SetXData" 2)
("ShowHistory" 0)
("SliceSolid" 4)
("TransformBy" 1)
("TrueColor" 0)
("Update" 0)
("Visible" 0)
)
)
Michael wanders off laughing maniacally looking for a life ...
-
In case someone else can make use of it.
;;;=================================================================================
;;; 1. You need to register tlbinf32.dll before using these functions.
;;; 2. Thanks to Michael Puckett and David Blackmon for sharing their findings about
;;; using tlbinf32.dll. Sorry if I missed anyone that should be credited.
;;; 3. Feel free to modify/use.
;;;=================================================================================
;;;Enum InvokeKinds
;;; INVOKE_UNKNOWN = 0,
;;; INVOKE_FUNC = 1,
;;; INVOKE_PROPERTYGET = 2,
;;; INVOKE_PROPERTYPUT = 4,
;;; INVOKE_PROPERTYPUTREF = 8,
;;; 'Special TLI values
;;; INVOKE_EVENTFUNC = 16,
;;; INVOKE_CONST = 32
;;;End Enum
;;;=================================================================================
;;;(KF:Get_Object_TypeInfo
;;; (car (entsel "\nPick object to list TypeInfo: "))
;;;)
(defun KF:Get_Object_TypeInfo (obj / appTli lstInvokeKind rv objInfo @)
(if (setq appTli (vlax-create-object "TLI.TLIApplication"))
(progn
(if (eq 'ENAME (type obj))
(setq obj (vlax-ename->vla-object obj))
)
(setq lstInvokeKind (list 0 1 2 4 8 16 32)
rv (mapcar 'list lstInvokeKind)
)
(setq objInfo (vlax-invoke appTli 'InterfaceInfoFromObject obj))
(vlax-for infoMember (vlax-get-property objInfo 'Members)
(setq @ (vl-position
(vlax-get-property infoMember 'InvokeKind)
lstInvokeKind
)
lst (nth @ rv)
rv (subst
(cons (vlax-get-property infoMember 'Name) lst)
lst
rv
)
)
)
(mapcar (function (lambda (lst)
(cons (car lst) (vl-sort (cdr lst) '<))
)
)
(mapcar 'reverse rv)
)
)
)
)
;;;=================================================================================
;;;(KF:Get_Object_PropertiesGet
;;; (car (entsel "\nPick object to list applicable properties to get: "))
;;;)
(defun KF:Get_Object_PropertiesGet (obj / lst)
(if (setq lst (KF:Get_Object_TypeInfo obj))
(cdr (nth 2 lst))
)
)
;;;=================================================================================
;;;(KF:Get_Object_PropertiesPut
;;; (car (entsel "\nPick object to list applicable properties to put: "))
;;;)
(defun KF:Get_Object_PropertiesPut (obj / lst)
(if (setq lst (KF:Get_Object_TypeInfo obj))
(cdr (nth 3 lst))
)
)
;;;=================================================================================
;;;(KF:Get_Object_Methods
;;; (car (entsel "\nPick object to list applicable methods: "))
;;;)
(defun KF:Get_Object_Methods (obj / lst)
(if (setq lst (KF:Get_Object_TypeInfo obj))
(cdr (nth 1 lst))
)
)
-
Dear Sir,
Can you write a progress as KF:Get_Object_PropertiesGet_readonly(get the Properties list that is read-only).
Thanks!
-
Try this:
(defun KF:Get_Object_PropertiesGet_ReadOnly (obj)
(vl-remove-if (function (lambda (e)
(member e (KF:Get_Object_PropertiesPut obj))
)
)
(KF:Get_Object_PropertiesGet obj)
)
)
-
Thanks xycadd for share it . :-D
-
;;; 1. You need to register tlbinf32.dll before using these functions.
How to register tlbinf32.dll in AUTOCAD ?
I have searched this file and it exists in C:\Program Files (x86)\VectorDraw\Components\1036\Ansi folder.