[RESOLVED] Ideas Wanted: ITypeInfo-like Solution

I'm developing a usercontrol. That usercontrol would like to discover every public property of any control contained on the parent form. Of course the usercontrol needs to do this dynamically, with no knowledge of what types of controls may exist in the parent. This enumeration of properties is to test for specific ones that can contain a specific property object type. These property names are not the same on every control and that doesn't include adding custom usercontrols into the mix.

I've gotten this done for any control that exists on the parent/top-level object, i.e., the form. Task completed via the use of IDispatch and ITypeInfo interfaces. The beauty of this is that the usercontrol can query this information without the form running. And this leads me to my question...

Can anyone think of a way to enumerate property names (not really interested in method names) of the parent/top-level object that a usercontrol sits on, while that parent/top-level object is not running, i.e., you are modifying its design. I do not want to hardcode any property names, want them dynamically discovered. If this doesn't seem doable, I'll revert to less preferred means of getting the property names.

P.S. The reason I can't do this via ITypeInfo, at the form level, is that unless the form is running, the form's ITypeInfo does not implement all methods, including the one I use to discover its controls' property names even when the form is not running.

Note: This solution does not need to work when the project is compiled and ITypeInfo will likely fail 100% of the time.

Hi LaVolpe,

I'm going to summarize my understanding of this. I certainly don't have an answer, as I haven't messed with ITypeInfo that much (although I have messed with it a bit).

So, if I understand correctly, we're talking about...

• ... being in the IDE, and in design-mode (i.e., not running).
• ... a custom user control we can do something to to get some code to run while in the IDE design-mode.
• ... having this UC enumerate all other controls (custom, OCX, built-in, whatever), and then enumerate their Public properties.

Two separate thoughts come to mind for me, and neither may be the solution:

1) The first thought I had was some code I played with by The Trick. It was actually in response to exploring an answer a question by Dilettante. He wanted to get a list of the "initial" property settings of all controls at runtime (either IDE or compiled). Basically, he wanted the values we'd see if we opened the .FRM file with notepad. For compiled, it involved almost dis-assembling the EXE. For the IDE, it involved reaching deep into the p-code memory image and snatching the values. But, the more I ponder this, I don't think this is heading toward an answer for you.

2) After pondering thought #1, it dawned on me that you basically do want the list of properties we'd see in the .FRM file. Or, if we don't want to depend on whether or not we've saved, you want the property bag of each control, and then access some kind of Properties collection of that PropertyBag. Since the IDE can use these property bags to save a .FRM file, I'd think there'd be some way to "get at" them if you wanted. However, it'd take considerable exploring on my part to sort that out. So ... I'll just leave you with my ideas.

Good Luck,
Elroy

Elroy, didn't mean to be too secretive. The tool I'm designing is a drop-in and only applies before its host is compiled. It turns most of itself off when compiled. It is a tool, not a feature -- invisible at run-time. This tool is interested in specific property types: Image, Font, etc. Parsing a project file is not applicable for this tool. I have 99.9% of the enumeration done; just kinda stuck on automating the property name enumeration for the parent object at design-time, not run-time. The last resort is a simple one... offer the user a method to manually identify the property names of interest. But as of now, all but this last step can be done automatically. Automation in this case translates to preventing the user from missing a key property name for inclusion into the tool.

And maybe a little more clarification is needed?

With a usercontrol on a form and the form is in design view, if any changes are made on the form, my usercontrol's WriteProperties event triggers. While in that event, all controls are still 'loaded' on the designer form. I can execute these two statements and they return without a problem:
Msgbox UserControl.Parent.Icon.Handle
MsgBox CallByName(UserControl.Parent, "Icon", vbGet).Handle

However, executing IUnknown:QueryInterface for the IDispatch, then executing IDispatch:GetTypeInfo all returns just fine, with valid interfaces. Only for the form, not its controls, I cannot execute ITypeInfo:GetAttrType. The HRESULT returns not implemented. I don't know if VB is using GetAttrType or simply calling ITypeInfo:GetIDsOfNames & then IDispatch.Invoke since I passed those lines of code the property name. Is it just a case of the IDispatch for the form in design view is a proxy of some sort, limited methods? If so, is another IDispatch related to the form that can be called? This may have something to do with FORM1 being derived from FORM and not being able to get IDispatch for a generic FORM?

I even tried to execute QueryInterface, passing it an IUnknown GUID & then asking that for its IDispatch. That resulted in a different IDispatch reference (comparing ObjPtrs), but its ITypeInfo also did not implement GetAttrType. I'm not hell-bent on doing this without user-intervention, but it would be a plus.

P.S. I'm sure this is has something to do with my question: When instead I tried to set a generic Object variable to New Form1, VB threw an error: An instance of 'Form1' cannot be created because its designer window is open.

In my UpDown control I used the following to retrieve a list of all "BuddyControl" properties.

Code:

---

    Const INVOKE_PROPERTYGET As Long = 2, INVOKE_PROPERTYPUT As Long = 4
    Dim TLI As Object, ObjInterface As Object, ObjMember As Object
    Dim LastMemberName As String, PropUBound As Long
    On Error Resume Next
    Set TLI = CreateObject("TLI.TLIApplication")
    If Err.Number <> 0 Then Set TLI = Nothing
    On Error GoTo 0
    Dim ControlEnum As Object
    For Each ControlEnum In .ControlsEnum
        If ControlIsValid(ControlEnum) = True Then
            If ControlEnum.Container Is .ControlsContainer Then
                If Not TLI Is Nothing Then
                    Set ObjInterface = TLI.InterfaceInfoFromObject(ControlEnum)
                    PropUBound = UBound(BuddyProperties())
                    ReDim Preserve BuddyProperties(0 To PropUBound + 1) As String
                    For Each ObjMember In ObjInterface.Members
                        With ObjMember
                        Select Case .InvokeKind
                            Case INVOKE_PROPERTYGET, INVOKE_PROPERTYPUT
                                If .Name = LastMemberName Then
                                    BuddyProperties(PropUBound + 1) = BuddyProperties(PropUBound + 1) & LastMemberName & "|"
                                Else
                                    LastMemberName = .Name
                                End If
                        End Select
                        End With
                    Next ObjMember
                End If
                ComboBuddyControl.AddItem ProperControlName(ControlEnum)
            End If
        End If
    Next ControlEnum

---

Very similar to what I'm doing, though I'm using DispCallFunc API instead of the DLL you are using. In your specific case, if you did this, it should error, if executed from WriteProperties when change made to the form and saved:

Set ObjInterface = TLI.InterfaceInfoFromObject(UserControl.Parent)
MsgBox ObjInterface.Members.Count << errors

The error does not occur when the form is loaded (and testing calls from the UC Show event for example). But in my case, calling the interface after the form is loaded does me no good unless the same code would work when compiled and it doesn't. It seems after the project is compiled, all references to Members collection (ITypeInfo:GetFuncDesc) are invalid because ITypeInfo:GetAttrType is not implemented after compiling.

Edited: FYI
Const INVOKE_PROPERTYGET As Long = 2, INVOKE_PROPERTYPUT As Long = 4
Above constants are same as VB's: vbGet & vbLet

@Krool, for comparison, here is my routine

Code:

---

Private Sub pvGetPropNames(TheObject As Object, cProps As Collection, PropType As String)

    ' Well commented because I may not remember all the details 6 months from now.
    ' We are looking for any property on any control that uses passed PropType:(Font, Picture)

    Dim aData(0 To 11) As Long, f As Long
    Dim ITypeInfo As IUnknown
    Dim IDispatch As IUnknown
    Dim farPtr As Long, sName As String
    ' VTable offsets for the IUnknown, ITypeInfo & IDispatch interfaces
    Const IUNK_QueryInterface As Long = 0&
    Const IDSP_GetTypeInfo As Long = 16&
    Const ITYP_GetTypeAttr As Long = 12&
    Const ITYP_GetFuncDesc As Long = 20&
    Const ITYP_GetDocument As Long = 48&
    Const ITYP_ReleaseTypeAttr As Long = 76&
    Const ITYP_ReleaseFuncDesc As Long = 80&
       
   
    aData(0) = &H20400: aData(2) = &HC0&: aData(3) = &H46000000
    ' ^^ IDispatch GUID. Get IDispatch for passed object
    pvCallFunction_COM ObjPtr(TheObject), IUNK_QueryInterface, vbLong, VarPtr(aData(0)), VarPtr(IDispatch)
    If IDispatch Is Nothing Then Exit Sub
   
    ' from IDispatch, get the ITypeInfo interface
    pvCallFunction_COM ObjPtr(IDispatch), IDSP_GetTypeInfo, vbLong, 0&, 0&, VarPtr(ITypeInfo)
    If ITypeInfo Is Nothing Then Exit Sub
   
    ' from ITypeInfo, call GetTypeAttr() method to return pointer to TYPEATTR structure
    pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetTypeAttr, vbLong, VarPtr(farPtr)
    If farPtr = 0& Then Exit Sub
   
    CopyMemory aData(0), ByVal farPtr, 48&  ' only need a portion of the entire TYPEATTR structure
    ' from ITypeInfo, call ReleaseAttr() method
    pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseTypeAttr, vbEmpty, farPtr
           
    For f = 0& To (aData(11) And &HFFFF&) - 1&    ' TYPEATTR.cFuncs; check each method/property
        ' from ITypeInfo, call GetFuncDesc() method to return pointer to FUNCDESC structure
        pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetFuncDesc, vbLong, f, VarPtr(farPtr)
        If farPtr = 0& Then Exit For
        CopyMemory aData(0), ByVal farPtr, 20& ' only need a portion of the entire FUNCDESC structure
        ' from ITypeInfo, call ReleaseFuncDesc() method
        pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseFuncDesc, vbEmpty, farPtr
        ' from ITypeInfo, call GetDocumentation()method to retrieve method/property name
        pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, aData(0), VarPtr(sName), 0&, 0&, 0&
        If (aData(4) And VbSet) Then ' property set vs get/let; since we want object-related properties only
        ' ^^ aData(4) = FUNCDESC.invkind
            On Error Resume Next    ' if calling a write-only property: error
            If TypeName(CallByName(TheObject, sName, VbGet)) = PropType Then
                If Err Then Err.Clear Else cProps.Add sName
            End If
            On Error GoTo 0
        End If
        sName = vbNullString
    Next
End Sub

---

Your ObjInterface = my IDispatch
Your ObjInterface.Members = my ITypeInfo.GetTypeAttr.cFuncs

Edited: You probably figured it out, but for others... The pvCallFunction_COM function is a separate subroutine that wraps the complex DispCallFunc API call

Maybe this one?
http://www.vbforums.com/showthread.p...=1#post4862613

@pekko, thanx for a slightly different spin, but same results. If interested, you can see what I'm trying to describe by using the code from that link in this sample project:

1. Create new test project
2. Add a new usercontrol to the project
3. In the user control paste below code
4. Close the usercontrol code & design windows
5. Add a command button to the form (no code, just for testing purposes)
6. Add the usercontrol to the form and then close the form. This will trigger the WriteProperties event

Code:

---

Option Explicit

'Modified from http://www.vb-helper.com/howto_get_property_information.html
'Set a project reference to the TypeLib Information library

Public Enum EPType
    ReadableProperties = 2
    WriteableProperties = 4
End Enum

Private Function EnumerateProperties(pObject As Object, pType As EPType) As Variant

Dim TypeLib As TLI.InterfaceInfo, Prop As TLI.MemberInfo, Ret As Variant
Set TypeLib = TLI.InterfaceInfoFromObject(pObject)

On Error Resume Next
For Each Prop In TypeLib.Members
    If Prop.InvokeKind = pType Then
        Ret = TLI.InvokeHook(pObject, Prop.MemberId, INVOKE_PROPERTYGET)
        If Err = 0 Then Debug.Print Left$(Prop.Name & Space$(30), 30) & Left$(TypeName(Ret) & Space$(10), 10) & Ret
        Err.Clear
    End If
Next

End Function

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    EnumerateProperties UserControl.Parent.Controls("Command1"), ReadableProperties

STOP ' walk this line by line using F8. When you get to the For Each statement
      ' in next function, hover mouse over Members. Error, but On Error Resume Next is hiding it
    EnumerateProperties UserControl.Parent, ReadableProperties  ' <<< this fails
End Sub

---

That last line is what I'm trying to achieve, but the method I need is not implemented on the interface when the parent (form) is in design view. Just looking for another way around it

If a solution arises, I'll definitely look at it. But in the mean time, I will hardcode a few property names (yuck). These will be known and can exist on any standard form/MDI or usercontrol: Icon, Picture, MouseIcon, Palette, MaskPicture. Each will be tested for their existence and I'll also offer the user a run-time option to add any additional property names on startup.

Quote:

---

Originally Posted by LaVolpe

@Krool, for comparison, here is my routine

Code:

---

Private Sub pvGetPropNames(TheObject As Object, cProps As Collection, PropType As String)

    ' Well commented because I may not remember all the details 6 months from now.
    ' We are looking for any property on any control that uses passed PropType:(Font, Picture)

    Dim aData(0 To 11) As Long, f As Long
    Dim ITypeInfo As IUnknown
    Dim IDispatch As IUnknown
    Dim farPtr As Long, sName As String
    ' VTable offsets for the IUnknown, ITypeInfo & IDispatch interfaces
    Const IUNK_QueryInterface As Long = 0&
    Const IDSP_GetTypeInfo As Long = 16&
    Const ITYP_GetTypeAttr As Long = 12&
    Const ITYP_GetFuncDesc As Long = 20&
    Const ITYP_GetDocument As Long = 48&
    Const ITYP_ReleaseTypeAttr As Long = 76&
    Const ITYP_ReleaseFuncDesc As Long = 80&
       
   
    aData(0) = &H20400: aData(2) = &HC0&: aData(3) = &H46000000
    ' ^^ IDispatch GUID. Get IDispatch for passed object
    pvCallFunction_COM ObjPtr(TheObject), IUNK_QueryInterface, vbLong, VarPtr(aData(0)), VarPtr(IDispatch)
    If IDispatch Is Nothing Then Exit Sub
   
    ' from IDispatch, get the ITypeInfo interface
    pvCallFunction_COM ObjPtr(IDispatch), IDSP_GetTypeInfo, vbLong, 0&, 0&, VarPtr(ITypeInfo)
    If ITypeInfo Is Nothing Then Exit Sub
   
    ' from ITypeInfo, call GetTypeAttr() method to return pointer to TYPEATTR structure
    pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetTypeAttr, vbLong, VarPtr(farPtr)
    If farPtr = 0& Then Exit Sub
   
    CopyMemory aData(0), ByVal farPtr, 48&  ' only need a portion of the entire TYPEATTR structure
    ' from ITypeInfo, call ReleaseAttr() method
    pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseTypeAttr, vbEmpty, farPtr
           
    For f = 0& To (aData(11) And &HFFFF&) - 1&    ' TYPEATTR.cFuncs; check each method/property
        ' from ITypeInfo, call GetFuncDesc() method to return pointer to FUNCDESC structure
        pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetFuncDesc, vbLong, f, VarPtr(farPtr)
        If farPtr = 0& Then Exit For
        CopyMemory aData(0), ByVal farPtr, 20& ' only need a portion of the entire FUNCDESC structure
        ' from ITypeInfo, call ReleaseFuncDesc() method
        pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseFuncDesc, vbEmpty, farPtr
        ' from ITypeInfo, call GetDocumentation()method to retrieve method/property name
        pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, aData(0), VarPtr(sName), 0&, 0&, 0&
        If (aData(4) And VbSet) Then ' property set vs get/let; since we want object-related properties only
        ' ^^ aData(4) = FUNCDESC.invkind
            On Error Resume Next    ' if calling a write-only property: error
            If TypeName(CallByName(TheObject, sName, VbGet)) = PropType Then
                If Err Then Err.Clear Else cProps.Add sName
            End If
            On Error GoTo 0
        End If
        sName = vbNullString
    Next
End Sub

---

Your ObjInterface = my IDispatch
Your ObjInterface.Members = my ITypeInfo.GetTypeAttr.cFuncs

Edited: You probably figured it out, but for others... The pvCallFunction_COM function is a separate subroutine that wraps the complex DispCallFunc API call

---

Hi LaVolpe,

I am using the above routine but the code crashes at this line :

Code:

---

pvCallFunction_COM ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, aData(0), VarPtr(sName), 0&, 0&, 0&

---

FYI, in reality, I am actually using your CallFunction_COM wrapper equivalent from a previous post of yours as follows :

Code:

---

Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aData(0), VarPtr(sName), 0&, 0&, 0&)

---

Any idea why the code is crashing when calling the GetDocumentation Method.

GetDocumentation method of ITypeInfo is fairly straightfoward: pass MemberID (aData(0)), and 4 strings which all can be null. That is what the call is doing.

If it is crashing, might want to double check a couple things:
ITypeInfo is not Nothing
sName = vbNullString before the call
aData(0) is the MemberID. Is there any chance it has an invalid value?

Also look at your DipsCallFunc API declaration, specifically the paTypes & paValues parameters. Are they ByRef or ByVal? In whatever CallFunction_COM wrapper you are using, ...
- if those API params are ByVal, then they will be passed to that API using VarPtr(...) else they will not

I doubt those last comments apply, otherwise, I'd expect a crash well before that line if ByRef/ByVal usage was incorrect.

the paTypes & paValues parameters are passed ByRef in the DispCallFunc Declaration.

Yes. ITypeInfo is not Nothing and sName = vbNullString before the call

Unless I am missing somthing, everything looks fine but the call still crashes!

I suspect aData(0) is the one causing the problem


Here is what I have:

Code:

---

Option Explicit
 
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, _
ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, _
ByRef retVAR As Variant) As Long

Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)

Const CC_STDCALL As Long = 4


Sub Test()

    Dim aData(0 To 11) As Long, f As Long
    Dim ITypeInfo As IUnknown
    Dim IDispatch As IUnknown
    Dim farPtr As Long, sName As String

    ' VTable offsets for the IUnknown, ITypeInfo & IDispatch interfaces
    Const IUNK_QueryInterface As Long = 0
    Const IDSP_GetTypeInfo As Long = 16
    Const ITYP_GetTypeAttr As Long = 12
    Const ITYP_GetFuncDesc As Long = 20
    Const ITYP_GetDocument As Long = 48

    Const ITYP_ReleaseTypeAttr As Long = 76
    Const ITYP_ReleaseFuncDesc As Long = 80
   
       
   
    aData(0) = &H20400: aData(2) = &HC0&: aData(3) = &H46000000
   
    ' ^^ IDispatch GUID. Get IDispatch for passed object  ' Application
    CallFunction_COM ObjPtr(Application), IUNK_QueryInterface, vbLong, CC_STDCALL, VarPtr(aData(0)), VarPtr(IDispatch)
    If IDispatch Is Nothing Then MsgBox "error":  Exit Sub
   
'    ' from IDispatch, get the ITypeInfo interface
    CallFunction_COM ObjPtr(IDispatch), IDSP_GetTypeInfo, vbLong, CC_STDCALL, 0&, 0&, VarPtr(ITypeInfo)
    If ITypeInfo Is Nothing Then MsgBox "error": Exit Sub

'    ' from ITypeInfo, call GetTypeAttr() method to return pointer to TYPEATTR structure
    CallFunction_COM ObjPtr(ITypeInfo), ITYP_GetTypeAttr, vbLong, CC_STDCALL, VarPtr(farPtr)
    If farPtr = 0& Then MsgBox "error": Exit Sub
       
        CopyMemory aData(0), ByVal farPtr, 48&    ' only need a portion of the entire TYPEATTR structure
   
'    ' from ITypeInfo, call ReleaseAttr() method
    CallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseTypeAttr, vbEmpty, CC_STDCALL, farPtr
   
''
    For f = 0 To (aData(11) And &HFFFF&) - 1&  ' TYPEATTR.cFuncs; check each method/property
''        ' from ITypeInfo, call GetFuncDesc() method to return pointer to FUNCDESC structure
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetFuncDesc, vbLong, CC_STDCALL, f, VarPtr(farPtr))
        If farPtr = 0& Then MsgBox "error": Exit For
       
        CopyMemory aData(0), ByVal farPtr, 20&  ' only need a portion of the entire FUNCDESC structure
       
''        ' from ITypeInfo, call ReleaseFuncDesc() method
      Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_ReleaseFuncDesc, vbEmpty, CC_STDCALL, farPtr)
     
     
      Debug.Print ITypeInfo Is Nothing '<==  Rreturns False
      Debug.Print sName = vbNullString '<==  Rreturns TRUE
 
       
      ' from ITypeInfo, call GetDocumentation()method to retrieve method/property name
      Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aData(0), VarPtr(sName), 0&, 0&, 0&)
       
       
'        If (aData(4) And VbSet) Then ' property set vs get/let; since we want object-related properties only
''        ' ^^ aData(4) = FUNCDESC.invkind
            On Error Resume Next    ' if calling a write-only property: error
           
            Debug.Print sName
'            If TypeName(CallByName(TheObject, sName, VbGet)) = PropType Then
'                If Err Then Err.Clear Else cProps.Add sName
'            End If
            On Error GoTo 0
'        End If
        sName = vbNullString
    Next

 
End Sub



Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
   
    Dim vParamPtr() As Long

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant
   
    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If
                                                     
    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        CallFunction_COM = vRtn
    Else
        SetLastError pIndex
    End If

End Function

---

LATE EDIT
In fact,after testing on a different PC, the routine actually works as expected in 32-Bit but fails in 64-Bit which is where I was initially testing .

I have mutiplied by *2 all vtable offset constants but still no chance.

Will I have to declare a new LongLong aData() array in the second section for storing TYPEATTR LongLong values in 64-Bit?

I would think executing DispCallFunc within a 32bit process would use Long, not LongLong.

Or is Application a 64bit process? Maybe that's the problem? Calling this from VBA? If so, yes I think you will need to play with redefining parameters and even the returned TYPEATTR structure as it may contain LongLong elements?

Noticed I posed a lot of questions. Unfortunately, all I can say is good luck as I don't mess much with 64bit Office (assuming that's what this is).

Quote:

---

Originally Posted by LaVolpe

I would think executing DispCallFunc within a 32bit process would use Long, not LongLong.

Or is Application a 64bit process? Maybe that's the problem? Calling this from VBA? If so, yes I think you will need to play with redefining parameters and even the returned TYPEATTR structure as it may contain LongLong elements?

Noticed I posed a lot of questions. Unfortunately, all I can say is good luck as I don't mess much with 64bit Office (assuming that's what this is).

---

Ok - I"ll keep on trying and see if I can make this work for 64bit.

In the meantime, I hope somoene with knowledge of 64 memory alignment can answer this.

Thank you very much for your help with this LaVolpe.

Quote:

---

Originally Posted by LaVolpe

I would think executing DispCallFunc within a 32bit process would use Long, not LongLong.

Or is Application a 64bit process? Maybe that's the problem? Calling this from VBA? If so, yes I think you will need to play with redefining parameters and even the returned TYPEATTR structure as it may contain LongLong elements?

Noticed I posed a lot of questions. Unfortunately, all I can say is good luck as I don't mess much with 64bit Office (assuming that's what this is).

---

Hi LaVolpe,

I have managed to make this work for 64 bit (and 32bit as well). For this, I had to define two structures (TYPEATTR and FUNCDESC) from scratch so I can obtain from them the correct cFuncs and INVOKEKIND members (Functions count & Functions type).... Obviously, I also had to define two new arrays (aTYPEATTR and aFUNCDESC) with their respective byte sizes for 32bit and 64bit.


In case you or anybody want to test this VBA code , here is an Excel Workbook Sample

This is the entire code :

Code:

---

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type TTYPEDESC
    #If Win64 Then
        pTypeDesc As LongLong
    #Else
        pTypeDesc As Long
    #End If
    vt            As Integer
End Type

Private Type TPARAMDESC
    #If Win64 Then
        pPARAMDESCEX  As LongLong
    #Else
        pPARAMDESCEX  As Long
    #End If
    wParamFlags      As Integer
End Type

Private Type TELEMDESC
    tdesc  As TTYPEDESC
    pdesc  As TPARAMDESC
End Type

Type TYPEATTR
        aGUID As GUID
        LCID As Long
        dwReserved As Long
        memidConstructor As Long
        memidDestructor As Long
        #If Win64 Then
            lpstrSchema As LongLong
        #Else
            lpstrSchema As Long
        #End If
        cbSizeInstance As Integer
        typekind As Long
        cFuncs As Integer
        cVars As Integer
        cImplTypes As Integer
        cbSizeVft As Integer
        cbAlignment As Integer
        wTypeFlags As Integer
        wMajorVerNum As Integer
        wMinorVerNum As Integer
        tdescAlias As Long
        idldescType As Long
End Type


Type FUNCDESC
    memid As Long
    #If Win64 Then
        lReserved1 As LongLong
        lprgelemdescParam As LongLong
    #Else
        lReserved1 As Long
        lprgelemdescParam As Long
    #End If
    funckind As Long
    INVOKEKIND As Long
    CallConv As Long
    cParams As Integer
    cParamsOpt As Integer
    oVft As Integer
    cReserved2 As Integer
    elemdescFunc As TELEMDESC
    wFuncFlags As Integer
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As Long, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
#End If




Function GetObjectFunctions(ByVal TheObject As Object, Optional ByVal FuncType As VbCallType) As Collection


    Dim tTYPEATTR As TYPEATTR
    Dim tFUNCDESC As FUNCDESC

    Dim aGUID(0 To 11) As Long, lFuncsCount As Long
   
    #If Win64 Then
        Const vTblOffsetFac_32_64 = 2
        Dim aTYPEATTR() As LongLong, aFUNCDESC() As LongLong, farPtr As LongLong
    #Else
        Const vTblOffsetFac_32_64 = 1
        Dim aTYPEATTR() As Long, aFUNCDESC() As Long, farPtr As Long
    #End If
   
    Dim ITypeInfo As IUnknown
    Dim IDispatch As IUnknown
    Dim sName As String, oCol As New Collection
   
    Const CC_STDCALL As Long = 4
    Const IUNK_QueryInterface As Long = 0
    Const IDSP_GetTypeInfo As Long = 16 * vTblOffsetFac_32_64
    Const ITYP_GetTypeAttr As Long = 12 * vTblOffsetFac_32_64
    Const ITYP_GetFuncDesc As Long = 20 * vTblOffsetFac_32_64
    Const ITYP_GetDocument As Long = 48 * vTblOffsetFac_32_64

    Const ITYP_ReleaseTypeAttr As Long = 76 * vTblOffsetFac_32_64
    Const ITYP_ReleaseFuncDesc As Long = 80 * vTblOffsetFac_32_64


    aGUID(0) = &H20400: aGUID(2) = &HC0&: aGUID(3) = &H46000000
    CallFunction_COM ObjPtr(TheObject), IUNK_QueryInterface, vbLong, CC_STDCALL, VarPtr(aGUID(0)), VarPtr(IDispatch)
    If IDispatch Is Nothing Then MsgBox "error":  Exit Function

    CallFunction_COM ObjPtr(IDispatch), IDSP_GetTypeInfo, vbLong, CC_STDCALL, 0&, 0&, VarPtr(ITypeInfo)
    If ITypeInfo Is Nothing Then MsgBox "error": Exit Function
   
    CallFunction_COM ObjPtr(ITypeInfo), ITYP_GetTypeAttr, vbLong, CC_STDCALL, VarPtr(farPtr)
    If farPtr = 0& Then MsgBox "error": Exit Function

    CopyMemory ByVal VarPtr(tTYPEATTR), ByVal farPtr, LenB(tTYPEATTR)
    ReDim aTYPEATTR(LenB(tTYPEATTR))
    CopyMemory ByVal VarPtr(aTYPEATTR(0)), tTYPEATTR, UBound(aTYPEATTR)
    CallFunction_COM ObjPtr(ITypeInfo), ITYP_ReleaseTypeAttr, vbEmpty, CC_STDCALL, farPtr
   
    For lFuncsCount = 0 To tTYPEATTR.cFuncs - 1
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetFuncDesc, vbLong, CC_STDCALL, lFuncsCount, VarPtr(farPtr))
        If farPtr = 0 Then MsgBox "error": Exit For
        CopyMemory ByVal VarPtr(tFUNCDESC), ByVal farPtr, LenB(tFUNCDESC)
        ReDim aFUNCDESC(LenB(tFUNCDESC))
        CopyMemory ByVal VarPtr(aFUNCDESC(0)), tFUNCDESC, UBound(aFUNCDESC)
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_ReleaseFuncDesc, vbEmpty, CC_STDCALL, farPtr)
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)
        Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)

        With tFUNCDESC
            If FuncType Then
                If .INVOKEKIND = FuncType Then
                    'Debug.Print sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                    oCol.Add sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                End If
            Else
                'Debug.Print sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
                oCol.Add sName & vbTab & Switch(.INVOKEKIND = 1, "VbMethod", .INVOKEKIND = 2, "VbGet", .INVOKEKIND = 4, "VbLet", .INVOKEKIND = 8, "VbSet")
            End If
        End With
        sName = vbNullString
    Next
   
    Set GetObjectFunctions = oCol

End Function



#If Win64 Then
    Private Function CallFunction_COM(ByVal InterfacePointer As LongLong, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As LongLong
#Else
    Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant

    Dim vParamPtr() As Long
#End If

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        CallFunction_COM = vRtn
    Else
        SetLastError pIndex
    End If

End Function

---

Function Usage:

Code:

---

    'Example:
    ' List all Methods and Properties of the excel application Object.
Sub Test()

    Dim oFuncCol As New Collection, i As Long, oObject As Object, sObjName As String

   
    Set oObject = Application '<=== Choose here target object as required.
    Set oFuncCol = GetObjectFunctions(TheObject:=oObject, FuncType:=0)
   
    Cells.CurrentRegion.Offset(1).ClearContents
    For i = 1 To oFuncCol.Count
        Range("A" & i + 1) = Split(oFuncCol.Item(i), vbTab)(0): Range("B" & i + 1) = Split(oFuncCol.Item(i), vbTab)(1)
    Next
    Range("C2") = oFuncCol.Count
    Cells(1).Resize(, 2).EntireColumn.AutoFit
   
    On Error Resume Next
        sObjName = oObject.Name
        If Len(sObjName) Then
            MsgBox "(" & oFuncCol.Count & ")  functions found for:" & vbCrLf & vbCrLf & sObjName
        End If
    On Error GoTo 0
   
End Sub

---

Regards.

JFYI, this line

Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)

. . . has to become

Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0&, 0&, 0&)

. . . for the above snippet to work correctly (not AV) in 32-bit VB6. (Otherwise now it works fine only in x64 Office.)

The line in question is called twice for no apparent reason, so safe to remove second call too.

cheers,
</wqw>

Here is my cleanup effort and after I got rid of API UDT's the whole code is reduced to about 70 lines incl. proper error handling (no MsgBox'es).

Code:

---

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long

Public Function InterfaceInfoFromObject(ByVal oObj As Object, Optional ByVal InvokeKind As VbCallType) As Collection
    Const IDX_GetTypeInfo As Long = 4
    Const IDX_GetTypeAttr As Long = 3
    Const IDX_GetFuncDesc As Long = 5
    Const IDX_GetDocumentation As Long = 12
    Const IDX_ReleaseTypeAttr As Long = 19
    Const IDX_ReleaseFuncDesc As Long = 20
    Dim oCol            As Collection
    Dim pDispatch      As IUnknown
    Dim pTypeInfo      As IUnknown
    Dim lPtr            As Long
    Dim aTypeAttr(0 To 16) As Long
    Dim aFuncDesc(0 To 12) As Long
    Dim lIdx            As Long
    Dim sName          As String

    Set oCol = New Collection
    Call CopyMemory(pDispatch, oObj, 4)
    Call CopyMemory(oObj, 0&, 4)
    DispCallByVtbl pDispatch, IDX_GetTypeInfo, 0&, 0&, VarPtr(pTypeInfo)
    If pTypeInfo Is Nothing Then
        GoTo QH
    End If
    DispCallByVtbl pTypeInfo, IDX_GetTypeAttr, VarPtr(lPtr)
    If lPtr = 0 Then
        GoTo QH
    End If
    CopyMemory aTypeAttr(0), ByVal lPtr, (UBound(aTypeAttr) + 1) * 4
    DispCallByVtbl pTypeInfo, IDX_ReleaseTypeAttr, lPtr
    For lIdx = 0 To aTypeAttr(11) - 1 '--- [11] = TYPEATTR.cFuncs
        lPtr = 0
        DispCallByVtbl pTypeInfo, IDX_GetFuncDesc, lIdx, VarPtr(lPtr)
        If lPtr <> 0 Then
            CopyMemory aFuncDesc(0), ByVal lPtr, (UBound(aFuncDesc) + 1) * 4
            DispCallByVtbl pTypeInfo, IDX_ReleaseFuncDesc, lPtr
            sName = vbNullString
            DispCallByVtbl pTypeInfo, IDX_GetDocumentation, aFuncDesc(0), VarPtr(sName), 0&, 0&, 0&
            If LenB(sName) <> 0 And aFuncDesc(4) = InvokeKind Or InvokeKind = 0 Then '--- [4] = FUNCDESC.invkind
                oCol.Add Array(sName, aFuncDesc(4))
            End If
        End If
    Next
QH:
    Set InterfaceInfoFromObject = oCol
End Function

Public Function DispCallByVtbl(pUnk As IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
    Const CC_STDCALL    As Long = 4
    Dim lIdx            As Long
    Dim vParam()        As Variant
    Dim vType(0 To 63)  As Integer
    Dim vPtr(0 To 63)  As Long
    Dim hResult        As Long
   
    vParam = A
    For lIdx = 0 To UBound(vParam)
        vType(lIdx) = VarType(vParam(lIdx))
        vPtr(lIdx) = VarPtr(vParam(lIdx))
    Next
    hResult = DispCallFunc(ObjPtr(pUnk), lIndex * 4, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
    If hResult < 0 Then
        Err.Raise hResult, "DispCallFunc"
    End If
End Function

---

The InterfaceInfoFromObject function I plan to use in production as a replacement of CreateObject("TLI.TLIApplication").InterfaceInfoFromObject(oObj).Members so to *not* depend on TLBINF32.DLL any more.

It turns out TLBINF32.DLL is *not* present on recent Windows Servers (probably starting since 2012) so COM introspection using TLI is not safe for production and apparently has never been as this DLL is a 3-rd party one that MS shipped as a favor to VB/VBA developers but no more as apparently there is no x64 version of it (and all server editions are x64 only since long ago).

Any bugfixes I make in production will try to backport to the snippet in this post.

cheers,
</wqw>

Hello wqweto: it looks promising to get rid of TLBINF32.DLL, I can get the name but for the second parameter I always get the value of 2.

It would be more useful if we could get also other data like with TLBINF32.DLL: the ReturnType (Long, Integer, String, stdFont, stdPicture, Etc)

For TLI I have this function to convert the ReturnType into something more friendly:

Code:

---

Private Function GetTypeName(ByVal nVarTypeInfo As VarTypeInfo)
    Dim iVarType As Long
   
    iVarType = nVarTypeInfo.VarType
    If (iVarType And Not VT_ARRAY) <> 0 Then
        Select Case (iVarType And &HFF&)
            Case VT_BOOL
                GetTypeName = "Boolean"
            Case VT_BSTR, VT_LPSTR, VT_LPWSTR
                GetTypeName = "String"
            Case VT_DATE
                GetTypeName = "Date"
            Case VT_INT
                GetTypeName = "Integer"
            Case VT_VARIANT
                GetTypeName = "Variant"
            Case VT_DECIMAL
                GetTypeName = "Decimal"
            Case VT_I4
                GetTypeName = "Long"
            Case VT_I2
                GetTypeName = "Integer"
            Case VT_I8
                GetTypeName = "Unknown"
            Case VT_SAFEARRAY
                GetTypeName = "SafeArray"
            Case VT_CLSID
                GetTypeName = "CLSID"
            Case VT_UINT
                GetTypeName = "UInt"
            Case VT_UI4
'                GetTypeName = "ULong"
                GetTypeName = "Long"
            Case VT_UNKNOWN
                GetTypeName = "Unknown"
            Case VT_VECTOR
                GetTypeName = "Vector"
            Case VT_R4
                GetTypeName = "Single"
            Case VT_R8
                GetTypeName = "Double"
            Case VT_DISPATCH
                GetTypeName = "Object"
            Case VT_UI1
                GetTypeName = "Byte"
            Case VT_CY
                GetTypeName = "Currency"
            Case VT_HRESULT
                GetTypeName = "HRESULT" ' note if this was a function it should be a sub
            Case VT_VOID
                GetTypeName = "Any"
            Case VT_ERROR
                GetTypeName = "Long"
            Case Else
                GetTypeName = "<Unsupported Variant Type"
                Select Case (iVarType And &HFF&)
                    Case VT_UI1
                        GetTypeName = GetTypeName & "(VT_UI1)"
                    Case VT_UI2
                        GetTypeName = GetTypeName & "(VT_UI2)"
                    Case VT_UI4
                        GetTypeName = GetTypeName & "(VT_UI4)"
                    Case VT_UI8
                        GetTypeName = GetTypeName & "(VT_UI8)"
                    Case VT_USERDEFINED
                        GetTypeName = GetTypeName & "(VT_USERDEFINED)"
                End Select
                GetTypeName = GetTypeName & ">"
        End Select
    Else
        GetTypeName = nVarTypeInfo.TypeInfo.Name
        If Left(GetTypeName, 1) = "_" Then
            GetTypeName = Mid$(GetTypeName, 2)
        End If
    End If
    If (iVarType And VT_ARRAY) = VT_ARRAY Then
        GetTypeName = GetTypeName & "()"
    End If
End Function

---

Quote:

---

Originally Posted by wqweto

JFYI, this line

Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0, 0, 0)

. . . has to become

Call CallFunction_COM(ObjPtr(ITypeInfo), ITYP_GetDocument, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sName), 0&, 0&, 0&)

. . . for the above snippet to work correctly (not AV) in 32-bit VB6. (Otherwise now it works fine only in x64 Office.)

The line in question is called twice for no apparent reason, so safe to remove second call too.

cheers,
</wqw>

---

Using 0& instead of 0 crashes in x64 applications.

HRESULT GetDocumentation(
MEMBERID memid,
BSTR *pBstrName,
BSTR *pBstrDocString,
DWORD *pdwHelpContext,
BSTR *pBstrHelpFile
);

As per the above, the last 3 parameters expect pointers so they should be 8bits each in x64 envirenments and not 4bit Longs.

Quote:

---

The line in question is called twice for no apparent reason, so safe to remove second call too

---

Yes. That was a silly mistake.

Thanks.

> Using 0& instead of 0 crashes in x64 applications.

Strange. But using 0 in x64 is as wrong as using 0 on x86 i.e. it does not crash under x64 purely by chance. You have to use NULL (as in nullptr) in both cases which as a numeric literal is 0& in x86 and 0^ in x64 (the 64-bit LongLong suffix is ^).

This will probably need a separate Const NULL_PTR As Long/LongPtr = 0 with conditional compilation on Win64.

cheers,
</wqw>

Quote:

---

Originally Posted by wqweto

> Using 0& instead of 0 crashes in x64 applications.

Strange. But using 0 in x64 is as wrong as using 0 on x86 i.e. it does not crash under x64 purely by chance. You have to use NULL (as in nullptr) in both cases which as a numeric literal is 0& in x86 and 0^ in x64 (the 64-bit LongLong suffix is ^).

This will probably need a separate Const NULL_PTR As Long/LongPtr = 0 with conditional compilation on Win64.

cheers,
</wqw>

---

0^ definitely works in x64 when tested.
Yes. using a NULL_PTR constant with conditional compilation is the best generic method.

Wonder if it is possible to get info about Properties, Subs and Functions in bas modules using the same idea ? Something like the info displayed in the IDE object browser. Thanks.