[VB6] - Module for working with COM-Dll without registration.

Hello. I give my module for working with COM-DLL without registration in the registry.
The module has several functions:

1. GetAllCoclasses - returns to the list of classes and unique identifiers are extracted from a type library.
2. CreateIDispatch - creates IDispatch implementation by reference to the object and the name of the interface.
3. CreateObjectEx2 - creates an object by name from a type library.
4. CreateObjectEx - creates an object by CLSID.
5. UnloadLibrary - unloads the DLL if it is not used.

vb Code:

' The module modTrickUnregCOM.bas - for working with COM libraries without registration.
' © Krivous Anatolii Anatolevich (The trick), 2015
 
Option Explicit
 
. . . 
D E C L A R A T I O N
. . .
 
Dim iidClsFctr      As GUID
Dim iidUnk          As GUID
Dim isInit          As Boolean
 
' // Get all co-classes described in type library.
Public Function GetAllCoclasses( _
                ByRef path As String, _
                ByRef listOfClsid() As GUID, _
                ByRef listOfNames() As String, _
                ByRef countCoClass As Long) As Boolean
                
    Dim typeLib As IUnknown
    Dim typeInf As IUnknown
    Dim ret     As Long
    Dim count   As Long
    Dim index   As Long
    Dim pAttr   As Long
    Dim tKind   As Long
    
    ret = LoadTypeLibEx(StrPtr(path), REGKIND_NONE, typeLib)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    count = ITypeLib_GetTypeInfoCount(typeLib)
    countCoClass = 0
    
    If count > 0 Then
    
        ReDim listOfClsid(count - 1)
        ReDim listOfNames(count - 1)
        
        For index = 0 To count - 1
        
            ret = ITypeLib_GetTypeInfo(typeLib, index, typeInf)
                        
            If ret Then
                Err.Raise ret
                Exit Function
            End If
            
            ITypeInfo_GetTypeAttr typeInf, pAttr
            
            GetMem4 ByVal pAttr + &H28, tKind
            
            If tKind = TKIND_COCLASS Then
            
                memcpy listOfClsid(countCoClass), ByVal pAttr, Len(listOfClsid(countCoClass))
                ret = ITypeInfo_GetDocumentation(typeInf, -1, listOfNames(countCoClass), vbNullString, 0, vbNullString)
                
                If ret Then
                    ITypeInfo_ReleaseTypeAttr typeInf, pAttr
                    Err.Raise ret
                    Exit Function
                End If
                
                countCoClass = countCoClass + 1
                
            End If
            
            ITypeInfo_ReleaseTypeAttr typeInf, pAttr
            
            Set typeInf = Nothing
            
        Next
        
    End If
    
    If countCoClass Then
        
        ReDim Preserve listOfClsid(countCoClass - 1)
        ReDim Preserve listOfNames(countCoClass - 1)
    
    Else
    
        Erase listOfClsid()
        Erase listOfNames()
        
    End If
    
    GetAllCoclasses = True
    
End Function
 
' // Create IDispach implementation described in type library.
Public Function CreateIDispatch( _
                ByRef obj As IUnknown, _
                ByRef typeLibPath As String, _
                ByRef interfaceName As String) As Object
                
    Dim typeLib As IUnknown
    Dim typeInf As IUnknown
    Dim ret     As Long
    Dim retObj  As IUnknown
    Dim pAttr   As Long
    Dim tKind   As Long
    
    ret = LoadTypeLibEx(StrPtr(typeLibPath), REGKIND_NONE, typeLib)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    ret = ITypeLib_FindName(typeLib, interfaceName, 0, typeInf, 0, 1)
    
    If typeInf Is Nothing Then
        Err.Raise &H80004002, , "Interface not found"
        Exit Function
    End If
    
    ITypeInfo_GetTypeAttr typeInf, pAttr
    GetMem4 ByVal pAttr + &H28, tKind
    ITypeInfo_ReleaseTypeAttr typeInf, pAttr
    
    If tKind = TKIND_DISPATCH Then
        Set CreateIDispatch = obj
        Exit Function
    ElseIf tKind <> TKIND_INTERFACE Then
        Err.Raise &H80004002, , "Interface not found"
        Exit Function
    End If
  
    ret = CreateStdDispatch(Nothing, obj, typeInf, retObj)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    Set CreateIDispatch = retObj
 
End Function
 
' // Create object by Name.
Public Function CreateObjectEx2( _
                ByRef pathToDll As String, _
                ByRef pathToTLB As String, _
                ByRef className As String) As IUnknown
                
    Dim typeLib As IUnknown
    Dim typeInf As IUnknown
    Dim ret     As Long
    Dim pAttr   As Long
    Dim tKind   As Long
    Dim clsid   As GUID
    
    ret = LoadTypeLibEx(StrPtr(pathToTLB), REGKIND_NONE, typeLib)
    
    If ret Then
        Err.Raise ret
        Exit Function
    End If
    
    ret = ITypeLib_FindName(typeLib, className, 0, typeInf, 0, 1)
    
    If typeInf Is Nothing Then
        Err.Raise &H80040111, , "Class not found in type library"
        Exit Function
    End If
 
    ITypeInfo_GetTypeAttr typeInf, pAttr
    
    GetMem4 ByVal pAttr + &H28, tKind
    
    If tKind = TKIND_COCLASS Then
        memcpy clsid, ByVal pAttr, Len(clsid)
    Else
        Err.Raise &H80040111, , "Class not found in type library"
        Exit Function
    End If
    
    ITypeInfo_ReleaseTypeAttr typeInf, pAttr
            
    Set CreateObjectEx2 = CreateObjectEx(pathToDll, clsid)
    
End Function
                
' // Create object by CLSID and path.
Public Function CreateObjectEx( _
                ByRef path As String, _
                ByRef clsid As GUID) As IUnknown
                
    Dim hLib    As Long
    Dim lpAddr  As Long
    Dim isLoad  As Boolean
    
    hLib = GetModuleHandle(StrPtr(path))
    
    If hLib = 0 Then
    
        hLib = LoadLibrary(StrPtr(path))
        If hLib = 0 Then
            Err.Raise 53, , Error(53) & " " & Chr$(34) & path & Chr$(34)
            Exit Function
        End If
        
        isLoad = True
        
    End If
    
    lpAddr = GetProcAddress(hLib, "DllGetClassObject")
    
    If lpAddr = 0 Then
        If isLoad Then FreeLibrary hLib
        Err.Raise 453, , "Can't find dll entry point DllGetClasesObject in " & Chr$(34) & path & Chr$(34)
        Exit Function
    End If
 
    If Not isInit Then
        CLSIDFromString StrPtr(IID_IClassFactory), iidClsFctr
        CLSIDFromString StrPtr(IID_IUnknown), iidUnk
        isInit = True
    End If
    
    Dim ret     As Long
    Dim out     As IUnknown
    
    ret = DllGetClassObject(lpAddr, clsid, iidClsFctr, out)
    
    If ret = 0 Then
 
        ret = IClassFactory_CreateInstance(out, 0, iidUnk, CreateObjectEx)
    
    Else
    
        If isLoad Then FreeLibrary hLib
        Err.Raise ret
        Exit Function
        
    End If
    
    Set out = Nothing
    
    If ret Then
    
        If isLoad Then FreeLibrary hLib
        Err.Raise ret
 
    End If
    
End Function
 
' // Unload DLL if not used.
Public Function UnloadLibrary( _
                ByRef path As String) As Boolean
                
    Dim hLib    As Long
    Dim lpAddr  As Long
    Dim ret     As Long
    
    If Not isInit Then Exit Function
    
    hLib = GetModuleHandle(StrPtr(path))
    If hLib = 0 Then Exit Function
    
    lpAddr = GetProcAddress(hLib, "DllCanUnloadNow")
    If lpAddr = 0 Then Exit Function
    
    ret = DllCanUnloadNow(lpAddr)
    
    If ret = 0 Then
        FreeLibrary hLib
        UnloadLibrary = True
    End If
    
End Function
 
' // Call "DllGetClassObject" function using a pointer.
Private Function DllGetClassObject( _
                 ByVal funcAddr As Long, _
                 ByRef clsid As GUID, _
                 ByRef iid As GUID, _
                 ByRef out As IUnknown) As Long
                 
    Dim params(2)   As Variant
    Dim types(2)    As Integer
    Dim list(2)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = VarPtr(clsid)
    params(1) = VarPtr(iid)
    params(2) = VarPtr(out)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(0&, funcAddr, CC_STDCALL, vbLong, 3, types(0), list(0), pReturn)
             
    If resultCall Then Err.Raise 5: Exit Function
    
    DllGetClassObject = pReturn
    
End Function
 
' // Call "DllCanUnloadNow" function using a pointer.
Private Function DllCanUnloadNow( _
                 ByVal funcAddr As Long) As Long
                 
    Dim resultCall  As Long
    Dim pReturn     As Variant
    
    resultCall = DispCallFunc(0&, funcAddr, CC_STDCALL, vbLong, 0, ByVal 0&, ByVal 0&, pReturn)
             
    If resultCall Then Err.Raise 5: Exit Function
    
    DllCanUnloadNow = pReturn
    
End Function
 
' // Call "IClassFactory:CreateInstance" method.
Private Function IClassFactory_CreateInstance( _
                 ByVal obj As IUnknown, _
                 ByVal punkOuter As Long, _
                 ByRef riid As GUID, _
                 ByRef out As IUnknown) As Long
    
    Dim params(2)   As Variant
    Dim types(2)    As Integer
    Dim list(2)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = punkOuter
    params(1) = VarPtr(riid)
    params(2) = VarPtr(out)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbLong, 3, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    IClassFactory_CreateInstance = pReturn
    
End Function
 
' // Call "ITypeLib:GetTypeInfoCount" method.
Private Function ITypeLib_GetTypeInfoCount( _
                 ByVal obj As IUnknown) As Long
    
    Dim resultCall  As Long
    Dim pReturn     As Variant
 
    resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbLong, 0, ByVal 0&, ByVal 0&, pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeLib_GetTypeInfoCount = pReturn
    
End Function
 
' // Call "ITypeLib:GetTypeInfo" method.
Private Function ITypeLib_GetTypeInfo( _
                 ByVal obj As IUnknown, _
                 ByVal index As Long, _
                 ByRef ppTInfo As IUnknown) As Long
    
    Dim params(1)   As Variant
    Dim types(1)    As Integer
    Dim list(1)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = index
    params(1) = VarPtr(ppTInfo)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &H10, CC_STDCALL, vbLong, 2, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeLib_GetTypeInfo = pReturn
    
End Function
 
' // Call "ITypeLib:FindName" method.
Private Function ITypeLib_FindName( _
                 ByVal obj As IUnknown, _
                 ByRef szNameBuf As String, _
                 ByVal lHashVal As Long, _
                 ByRef ppTInfo As IUnknown, _
                 ByRef rgMemId As Long, _
                 ByRef pcFound As Integer) As Long
    
    Dim params(4)   As Variant
    Dim types(4)    As Integer
    Dim list(4)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = StrPtr(szNameBuf)
    params(1) = lHashVal
    params(2) = VarPtr(ppTInfo)
    params(3) = VarPtr(rgMemId)
    params(4) = VarPtr(pcFound)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &H2C, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeLib_FindName = pReturn
    
End Function
 
' // Call "ITypeInfo:GetTypeAttr" method.
Private Sub ITypeInfo_GetTypeAttr( _
            ByVal obj As IUnknown, _
            ByRef ppTypeAttr As Long)
    
    Dim resultCall  As Long
    Dim pReturn     As Variant
    
    pReturn = VarPtr(ppTypeAttr)
    
    resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(pReturn), 0)
          
    If resultCall Then Err.Raise resultCall: Exit Sub
 
End Sub
 
' // Call "ITypeInfo:GetDocumentation" method.
Private Function ITypeInfo_GetDocumentation( _
                 ByVal obj As IUnknown, _
                 ByVal memid As Long, _
                 ByRef pBstrName As String, _
                 ByRef pBstrDocString As String, _
                 ByRef pdwHelpContext As Long, _
                 ByRef pBstrHelpFile As String) As Long
    
    Dim params(4)   As Variant
    Dim types(4)    As Integer
    Dim list(4)     As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn     As Variant
    
    params(0) = memid
    params(1) = VarPtr(pBstrName)
    params(2) = VarPtr(pBstrDocString)
    params(3) = VarPtr(pdwHelpContext)
    params(4) = VarPtr(pBstrHelpFile)
    
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
    Next
    
    resultCall = DispCallFunc(obj, &H30, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
          
    If resultCall Then Err.Raise resultCall: Exit Function
     
    ITypeInfo_GetDocumentation = pReturn
    
End Function
 
' // Call "ITypeInfo:ReleaseTypeAttr" method.
Private Sub ITypeInfo_ReleaseTypeAttr( _
            ByVal obj As IUnknown, _
            ByVal ppTypeAttr As Long)
    
    Dim resultCall  As Long
    
    resultCall = DispCallFunc(obj, &H4C, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(ppTypeAttr)), 0)
          
    If resultCall Then Err.Raise resultCall: Exit Sub
 
End Sub

Download.

the download isn't working for me. What references are needed?
And do you have any examples ?

Quote:

---

What references are needed?

---

Nothing.

Quote:

---

And do you have any examples ?

---

It very simple. Show your nonworking code.

New project, paste your code into a new class file, and run...

CC_STDCALL is not defined, etc. I'm assuming you have a reference to a type library or DLL

In the VB6 IDE It's under Project-> References...

You must download module by link from main post. In code that i publish here i skip declarations.
Attachment 128275

That makes sense now. Corporate firewall doesn't like the link. Can someone attach it here?

Go Advanced, and then Manage attachments.

Quote:

---

That makes sense now. Corporate firewall doesn't like the link. Can someone attach it here?

Go Advanced, and then Manage attachments.

---

Of course just this source code publish in many resources and if someone find bugs then i should replace in all resources.
Attachment 128733

Thanks! This works without using ActCtx. Brilliant.

I've modified dilettante's Regfee COM demo / Pine Plugins Form_Load()
with the following lines

Code:

---

        Set Plugins(Plugin) = CreateObjectEx2( _
            path & FileName & "dll", _
            path & FileName & "dll", _
            FileName & "PluginClass")

---

Is there an easy way to generate the TLB file without installing VS/VC++?

or do I need to use CreateObjectEx and use the CLSID out of the manifest?


**UPDATE**
This seemed to work well:

Code:

---

        Set Plugins(Plugin) = CreateObjectEx2( _
            path & FileName & "dll", _
            path & FileName & "dll", _
            "PluginClass")

---

Unless anyone can find any issues, this seems like a great way to load and use COM dll's REGFREE without manifests or TLBs etc. at least in this case.

Quote:

---

Is there an easy way to generate the TLB file without installing VS/VC++?

---

Usually tlb contained inside dll into resource, therefore you can pass same value for dll and tlb.

Quote:

---

or do I need to use CreateObjectEx and use the CLSID out of the manifest?

---

If you know CLSID you can use just CreateObjectEx without tlb. For example zipfldr.dll (standart library for working with zip-files) don't contained tlb, therefore you can use CLSID for create com-objects from this DLL. If you can CLSID then it fastet than using of CreateObjectEx2.
This module contained useful function CreateIDispatch, it allow create dynamicli interfaces from TLB. For example, if you want use a ITypeLib interface you can pass this name to CreateIDispatch function and path to tlb that contained a description of ITypeLib interface. This function return pointer to IDispatch interface and further you can call any ITypeLib methods use this IDispatch interface (or CallByName etc).

Hi, can i use this bas to get cls members for a dll.

Quote:

---

Originally Posted by loquat

Hi, can i use this bas to get cls members for a dll.

---

Hi, you can use ITypeInfo interface to get information about a member.

Thank u, I wanna use Muti-Threading in vba-based environment, like ms-office word/Excel
but there is no such demo. I have find some dlls used in vb6
Here are some dll or codes for vb6, but i can't use them in vba
Can Thread Factory used in vba? or is there any solution?

Quote:

---

Originally Posted by loquat

Thank u, I wanna use Muti-Threading in vba-based environment, like ms-office word/Excel
but there is no such demo. I have find some dlls used in vb6
Here are some dll or codes for vb6, but i can't use them in vba

Can Thread Factory used in vba? or is there any solution?

---

I think you confuse the thread. This thread is not about multithreading.

Loquat, I've removed your attachment because we have a rule against posting closed code (exes, zips etc.) on the forum. The only place it's acceptable is in the Utilities sub-forums and then only if the associated source is included. Please refrain from doing that in the future. Thanks.

Regards
FD

>FD and The trick
my English is not that good, and I have learn in this forum only yesterday.
sorry to bother you.

i have used your UnRegCom module for long time, and have tested your unreg control project you publish in other website.
and i have two questions.
1.how can we get the event trigger of the object created by "CreateObjectEx"?
2.many of the controls from 3rd party, can not be loaded by ControlsAdd Function, shows "need license" as such.
can we make bypass of it?
or how should i compile the usercontrol to be used in this situation?

System multiple Excel Application，only get the first 。
how using process id get Excel Application object ?
or
Get a Collection of All Running Excel Instances？

Quote:

---

Originally Posted by ln_0

System multiple Excel Application，only get the first 。
how using process id get Excel Application object ?
or
Get a Collection of All Running Excel Instances？

---

Google is your friend, this is the wrong thread, but googling WM_GETOBJECT Excel, will help get you on the right track

Google = 404
china.

Quote:

---

Originally Posted by loquat

1.how can we get the event trigger of the object created by "CreateObjectEx"?

---

WithEvents.

Quote:

---

Originally Posted by loquat

2.many of the controls from 3rd party, can not be loaded by ControlsAdd Function, shows "need license" as such.
can we make bypass of it?

---

What you tell about?

Quote:

---

System multiple Excel Application，only get the first 。
how using process id get Excel Application object ?
or
Get a Collection of All Running Excel Instances？

---

This question isn't related to this thread. The answer is Running Object Table.

rot can get all object,
so you can get hwnd by object

Another way is to use the following function... it seems to be similar to New_c.RegFree.GetInstanceEx in Olaf's vbRichClient5.dll
Below is a part of its many association functions
The following function was not written by me, but copied from unknown Internet by someone else

Code:

---

Public Function getInstance(ByVal LibraryString As String, ByVal ProgIdString As String) As stdole.IUnknown
    Dim newobj As stdole.IUnknown
    Dim TFactory As IClassFactory
    Dim classid As GUID
    Dim IID_ClassFactory As GUID
    Dim IID_IUnknown As GUID
    Dim lib As String
    Dim obj As Long
    Dim vtbl As Long
    Dim hModule As Long
    Dim pFunc As Long
    Dim arrTCoClass() As CoClass
    Dim i As Long, n As Long
    Dim flag As Boolean
    Dim strClassname As String
    n = InStr(1, ProgIdString, ".")
    If n > 0 Then
        strClassname = Mid(ProgIdString, n + 1)
        n = InStr(1, strClassname, ".")
        If n > 0 Then strClassname = Left(ProgIdString, n - 1)
    Else
        strClassname = ProgIdString
    End If
    With IID_ClassFactory
        .Data1 = &H1
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With IID_IUnknown
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    ' get all CoClasses from the type lib of the file, and find the GUID of the Prog ID
    If Not getCoClasses(LibraryString, arrTCoClass) Then
        Exit Function
    End If
    For i = 0 To UBound(arrTCoClass)
        #If DEBUGMODE = 1 Then
            Debug.Print arrTCoClass(i).prgid, arrTCoClass(i).Name, StringFromGUID(arrTCoClass(i).GUID)
            #End If
            If Len(arrTCoClass(i).prgid) > 0 Then
                If StrComp(arrTCoClass(i).prgid, ProgIdString, vbTextCompare) = 0 Then
                    flag = True
                Else
                    If StrComp(arrTCoClass(i).Name, strClassname, vbTextCompare) = 0 Then flag = True
                End If
            Else
                If StrComp(arrTCoClass(i).Name, strClassname, vbTextCompare) = 0 Then flag = True
            End If
            If flag Then
                CpyMem classid, arrTCoClass(i).GUID(0), Len(classid)
                Exit For
            End If
        Next i
        If i = UBound(arrTCoClass) + 1 Then Exit Function
        ' load the file, if it isn't yet
        hModule = GetModuleHandle(LibraryString)
        If hModule = 0 Then
            hModule = LoadLibrary(LibraryString)
            If hModule = 0 Then Exit Function
        End If
        pFunc = GetProcAddress(hModule, "DllGetClassObject")
        If pFunc = 0 Then Exit Function
        ' call DllGetClassObject to get a class factory for the class ID
        If 0 <> callPointer(pFunc, VarPtr(classid), VarPtr(IID_ClassFactory), VarPtr(obj)) Then Exit Function
        ' IClassFactory VTable
        CpyMem vtbl, ByVal obj, 4
        CpyMem TFactory, ByVal vtbl, Len(TFactory)
        ' create an instance of the object
        If 0 <> callPointer(TFactory.CreateInstance, obj, 0, VarPtr(IID_IUnknown), VarPtr(newobj)) Then
            ' Set IClassFactory = Nothing
            callPointer TFactory.IUnk.Release, obj
            Exit Function
        End If
        ' Set IClassFactory = Nothing
        callPointer TFactory.IUnk.Release, obj
        Set getInstance = newobj
    End Function

---

how can we use the tlb in dll other than id=1?
such as CreateObjectEx2("c:\windows\syswow64\vbscript.dll\3", "regexp")

i have found how to do it, both work

method #1
Dim reg As Object 'RegExp
Set reg = CreateObjectEx("c:\windows\syswow64\vbscript.dll", ApiStringtoGUID("{3F4DACA4-160D-11D2-A8E9-00104B365C9F}"))

method #2
Set reg = CreateObjectEx2("c:\windows\syswow64\vbscript.dll", _
"c:\windows\syswow64\vbscript.dll\3", _
"RegExp")

Let me answer later. We have storm here and no electricity for more than week already. As far as I remember you should specify / (slash) for a resource identifier.

Quote:

---

Originally Posted by PhuongNam

Another way is to use the following function... it seems to be similar to New_c.RegFree.GetInstanceEx in Olaf's vbRichClient5.dll
Below is a part of its many association functions
The following function was not written by me, but copied from unknown Internet by someone else

---

the code you share seems not complete.
1.IClassFactory and CoClass Type not claimed
2.getCoClasses and callPointer function not claimed
3.as well as some api such as cpymem etc.

Does it work if you use a slash for a resource identifier?

both method work as show in #25

Quote:

---

Originally Posted by The trick

This module contained useful function CreateIDispatch, it allow create dynamicli interfaces from TLB. For example, if you want use a ITypeLib interface you can pass this name to CreateIDispatch function and path to tlb that contained a description of ITypeLib interface. This function return pointer to IDispatch interface and further you can call any ITypeLib methods use this IDispatch interface (or CallByName etc).

---

I have tried to replicate your "CreateIDispatch" example to create an IDispatch interface for ITypeLib. I used "oleexp.tlb" as an example because it contains a description for ITypeLib of type TKIND_INTERFACE.

CreateStdDispatch was executed successfully and I got an ITypeLib object but when I tried to call the "FindName" method, it produced run-time error 458 "Variable uses an Automation type not supported in Visual Basic"...

Please attach a small project.

Ok, here's a working copy-paste BAS module for testing with a "Sub Main". It needs to have "oleexp.tlb" in the same folder for loading the "ITypeLib" interface (no references):

Code:

---

Option Explicit

Private Enum ConstantsEnum
    MEMBERID_NIL = -1
    S_OK
    S_FALSE
    REGKIND_NONE
    TKIND_INTERFACE
    CC_STDCALL
    PTR_SIZE = 4
End Enum

Private Enum vtbInterfaceOffsets
    ITypeLib_FindName = 11 * PTR_SIZE
    ITypeInfo_GetTypeAttr = 3 * PTR_SIZE
    ITypeInfo_ReleaseTypeAttr = 19 * PTR_SIZE
End Enum

Private Declare Function CreateStdDispatch Lib "oleaut32" (ByVal punkOuter As IUnknown, ByVal pvThis As IUnknown, ByVal ptinfo As IUnknown, ppunkStdDisp As IUnknown) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgvt As Any, prgpvarg As Any, pvargResult As Variant) As Long
Private Declare Function LoadTypeLibEx Lib "oleaut32" (ByVal lpszFile As Long, ByVal RegKind As Long, pptLib As IUnknown) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (Ptr As Any, RetVal As Long)

Private ParamTypes(0 To 10) As Integer, ParamValues(0 To 10) As Long, lParamCount As Long, lpInterface As Long, vParams As Variant

Public Sub Main()
On Error Resume Next
    TestIDispatch
    Debug.Print Err, Err.Description
End Sub

Private Sub TestIDispatch()
Dim TypeLibIUnknown As IUnknown, TypeLibIDispatch As Object, typeInfo As IUnknown, rgMemId As Long, pcFound As Integer
    If LoadTypeLibEx(StrPtr("C:\Windows\SysWOW64\scrrun.dll"), REGKIND_NONE, TypeLibIUnknown) = S_OK Then
        Set TypeLibIDispatch = CreateIDispatch(TypeLibIUnknown, App.Path & "\oleexp.tlb", "ITypeLib")
        If Not (TypeLibIDispatch Is Nothing) Then
            pcFound = 1
            TypeLibIDispatch.FindName "Dictionary", 0&, typeInfo, rgMemId, pcFound
        End If
    End If
End Sub

Private Function CreateIDispatch(obj As IUnknown, typeLibPath As String, interfaceName As String) As Object
Dim typeLib As IUnknown, typeInfo As IUnknown, retObj As IUnknown, lpAttr As Long, tKind As Long, rgMemId As Long, pcFound As Long
    If LoadTypeLibEx(StrPtr(typeLibPath), REGKIND_NONE, typeLib) = S_OK Then
        pcFound = 1
        InvokeObj typeLib, ITypeLib_FindName, StrPtr(interfaceName), 0&, VarPtr(typeInfo), VarPtr(rgMemId), VarPtr(pcFound)
        If rgMemId = MEMBERID_NIL Then
            InvokeObj typeInfo, ITypeInfo_GetTypeAttr, VarPtr(lpAttr)
            If lpAttr Then GetMem4 ByVal lpAttr + &H28, tKind
            InvokeObj typeInfo, ITypeInfo_ReleaseTypeAttr, lpAttr
            If tKind = TKIND_INTERFACE Then
                If CreateStdDispatch(Nothing, obj, typeInfo, retObj) = S_OK Then Set CreateIDispatch = retObj
            End If
        End If
    End If
End Function
   
Private Function InvokeObj(Interface As IUnknown, vtbOffset As Long, ParamArray ParamsArray() As Variant) As Variant
Dim lRet As Long
    InvokeObj = S_FALSE: lpInterface = ObjPtr(Interface): vParams = ParamsArray
    For lParamCount = 0 To UBound(vParams): ParamTypes(lParamCount) = VarType(vParams(lParamCount)): ParamValues(lParamCount) = VarPtr(vParams(lParamCount)): Next lParamCount
    If lpInterface Then
        lRet = DispCallFunc(lpInterface, vtbOffset, CC_STDCALL, vbLong, lParamCount, ParamTypes(0), ParamValues(0), InvokeObj)
    ElseIf vtbOffset > 1024 Then
        lRet = DispCallFunc(lpInterface, vtbOffset, CC_STDCALL, vbLong, lParamCount, ParamTypes(0), ParamValues(0), InvokeObj)
    End If
    If lRet Then Debug.Print Hex$(lRet)
End Function

---

Output: 458 Variable uses an Automation type not supported in Visual Basic

Quote:

---

Originally Posted by VanGoghGaming

Ok, here's a working copy-paste BAS module for testing with a "Sub Main". It needs to have "oleexp.tlb" in the same folder for loading the "ITypeLib" interface (no references):

Code:

---

Option Explicit

Private Enum ConstantsEnum
    MEMBERID_NIL = -1
    S_OK
    S_FALSE
    REGKIND_NONE
    TKIND_INTERFACE
    CC_STDCALL
    PTR_SIZE = 4
End Enum

Private Enum vtbInterfaceOffsets
    ITypeLib_FindName = 11 * PTR_SIZE
    ITypeInfo_GetTypeAttr = 3 * PTR_SIZE
    ITypeInfo_ReleaseTypeAttr = 19 * PTR_SIZE
End Enum

Private Declare Function CreateStdDispatch Lib "oleaut32" (ByVal punkOuter As IUnknown, ByVal pvThis As IUnknown, ByVal ptinfo As IUnknown, ppunkStdDisp As IUnknown) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgvt As Any, prgpvarg As Any, pvargResult As Variant) As Long
Private Declare Function LoadTypeLibEx Lib "oleaut32" (ByVal lpszFile As Long, ByVal RegKind As Long, pptLib As IUnknown) As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (Ptr As Any, RetVal As Long)

Private ParamTypes(0 To 10) As Integer, ParamValues(0 To 10) As Long, lParamCount As Long, lpInterface As Long, vParams As Variant

Public Sub Main()
On Error Resume Next
    TestIDispatch
    Debug.Print Err, Err.Description
End Sub

Private Sub TestIDispatch()
Dim TypeLibIUnknown As IUnknown, TypeLibIDispatch As Object, typeInfo As IUnknown, rgMemId As Long, pcFound As Integer
    If LoadTypeLibEx(StrPtr("C:\Windows\SysWOW64\scrrun.dll"), REGKIND_NONE, TypeLibIUnknown) = S_OK Then
        Set TypeLibIDispatch = CreateIDispatch(TypeLibIUnknown, App.Path & "\oleexp.tlb", "ITypeLib")
        If Not (TypeLibIDispatch Is Nothing) Then
            pcFound = 1
            TypeLibIDispatch.FindName "Dictionary", 0&, typeInfo, rgMemId, pcFound
        End If
    End If
End Sub

Private Function CreateIDispatch(obj As IUnknown, typeLibPath As String, interfaceName As String) As Object
Dim typeLib As IUnknown, typeInfo As IUnknown, retObj As IUnknown, lpAttr As Long, tKind As Long, rgMemId As Long, pcFound As Long
    If LoadTypeLibEx(StrPtr(typeLibPath), REGKIND_NONE, typeLib) = S_OK Then
        pcFound = 1
        InvokeObj typeLib, ITypeLib_FindName, StrPtr(interfaceName), 0&, VarPtr(typeInfo), VarPtr(rgMemId), VarPtr(pcFound)
        If rgMemId = MEMBERID_NIL Then
            InvokeObj typeInfo, ITypeInfo_GetTypeAttr, VarPtr(lpAttr)
            If lpAttr Then GetMem4 ByVal lpAttr + &H28, tKind
            InvokeObj typeInfo, ITypeInfo_ReleaseTypeAttr, lpAttr
            If tKind = TKIND_INTERFACE Then
                If CreateStdDispatch(Nothing, obj, typeInfo, retObj) = S_OK Then Set CreateIDispatch = retObj
            End If
        End If
    End If
End Function
   
Private Function InvokeObj(Interface As IUnknown, vtbOffset As Long, ParamArray ParamsArray() As Variant) As Variant
Dim lRet As Long
    InvokeObj = S_FALSE: lpInterface = ObjPtr(Interface): vParams = ParamsArray
    For lParamCount = 0 To UBound(vParams): ParamTypes(lParamCount) = VarType(vParams(lParamCount)): ParamValues(lParamCount) = VarPtr(vParams(lParamCount)): Next lParamCount
    If lpInterface Then
        lRet = DispCallFunc(lpInterface, vtbOffset, CC_STDCALL, vbLong, lParamCount, ParamTypes(0), ParamValues(0), InvokeObj)
    ElseIf vtbOffset > 1024 Then
        lRet = DispCallFunc(lpInterface, vtbOffset, CC_STDCALL, vbLong, lParamCount, ParamTypes(0), ParamValues(0), InvokeObj)
    End If
    If lRet Then Debug.Print Hex$(lRet)
End Function

---

Output: 458 Variable uses an Automation type not supported in Visual Basic

---

how to createobject new object by oleexp.tlb?

it's not itypelib ,so only can call by api

can't use: TypeLibIDispatch.FindName "Dictionary", 0&, typeInfo, rgMemId, pcFound

Code:

---

Private Function ITypeLib_FindName( _
                ByVal obj As IUnknown, _
                ByRef szNameBuf As String, _
                ByVal lHashVal As Long, _
                ByRef ppTInfo As IUnknown, _
                ByRef rgMemId As Long, _
                ByRef pcFound As Integer) As Long
   
    Dim params(4)  As Variant
    Dim types(4)    As Integer
    Dim list(4)    As Long
    Dim resultCall  As Long
    Dim pIndex      As Long
    Dim pReturn    As Variant
   
    params(0) = StrPtr(szNameBuf)
    params(1) = lHashVal
    params(2) = VarPtr(ppTInfo)
    params(3) = VarPtr(rgMemId)
    params(4) = VarPtr(pcFound)
   
    For pIndex = 0 To UBound(params)
        list(pIndex) = VarPtr(params(pIndex))
        types(pIndex) = VarType(params(pIndex))
    Next
   
    resultCall = DispCallFunc2(obj, &H2C, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
         
    If resultCall Then err.Raise resultCall: Exit Function
   
    ITypeLib_FindName = pReturn
   
End Function

---

Quote:

---

Originally Posted by xiaoyao

it's not itypelib ,so only can call by api

---

It's definitely ITypeLib because you can simply declare it "As oleexp.ITypeLib" and then you can call the methods directly without any API. The purpose of the "CreateStdDispatch" function is to accomplish the same thing without referencing the TLB but it's not so simple as it seems.

if you can't use oletlb.tlb file
Then you can't directly use the method of late binding to call directly.If we can do this, we don't need it at all. The TLB type library

We can construct a simple one ourselves. callbynameOr operate directly with the API.Because it's not a real object, you can't even use.callbyname.

You can use oleexp.tlb just fine but that's not the point of this exercise. The whole idea behind TheTrick's function was to take an existing object, add some TypeInfo information to it describing its methods and properties and then use "CreateStdDispatch" (read the documentation) to add the "IDispatch" interface that allows you to call the object's methods by name instead of by pointer. That's all there is to it, just an exercise.

does it support x64?
COM-Dll without registration ,How many different ways can it be achieved?