[RESOLVED] Regfree DirectX dx8vb.dll usage with DirectCOM.dll-VBForums
Results 1 to 16 of 16

Thread: [RESOLVED] Regfree DirectX dx8vb.dll usage with DirectCOM.dll

  1. #1

    Thread Starter
    New Member
    Join Date
    Oct 2017
    Posts
    8

    Resolved [RESOLVED] Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Hi all

    I have developed a couple of 3D applications using DirectX8 library, one in VB and another one in an excel book using VBA. Until Windows XP, I had no issues as the dx8vb.dll came already registered with Windows

    Since windows vista, 7, 8 and now 10, I had to go to an "administrator rights free" option of using this library. Until now A friend of mine gave the code I post at the end if this could be useful for somebody (sorry I tried to find the source but I could not get it). It worked fine until I suppose what is a security update don't
    let this code work anymore

    I wanted to go to the DirectCOM.dll Olaf Schmidt option as I wanted to introduce some nice features included in the RichClient5.

    Unfortunately due to my low programming skills I could not go further as a get a complete IDE crash when I try to use it, surely in a wrong way

    The original code would be

    Code:
    Dim dx As DirectX8
    Dim D3D As Direct3D8
    
    Sub Main()
        Set dx = New DirectX8
        Set D3D = dx.Direct3DCreate ' Active X cannot create the object bla bla bla, ....
    End Sub
    This is the code I use following the posts I could read in this forum trying to use DirectCOM

    Code:
    Option Explicit
    Private Declare Function GetInstance Lib "c:\Users\Public\directXTest\DirectCOM.dll" Alias "GETINSTANCE" (FName As String, ClassName As String) As Object
    Private Declare Function LoadLibraryW& Lib "kernel32" (ByVal lpLibFileName&)
    Dim dx 'As DirectX8
    
    
    Sub Main()
        Static hDirCOM As Long
        hDirCOM = LoadLibraryW&(StrPtr("c:\Users\Public\directXTest\DirectCOM.dll"))
        Set dx = GetInstance("c:\Users\Public\directXTest\dx8vb.dll", "DirectX8") ' Complete Crash
    End Sub

    I would welcome any help!

    Thanks in advance!

    Happy new VB6 - 2018 year

    ==============================================


    Admin wrights free registration in local user (sorry I did not find the source)
    Code:
    Option Explicit
    
    'All required Win32 SDK functions to register/unregister any ActiveX component
    
    Private Declare Function LoadLibraryRegister Lib "KERNEL32" Alias "LoadLibraryA" _
    (ByVal lpLibFileName As String) As Long
    
    Private Declare Function FreeLibraryRegister Lib "KERNEL32" Alias "FreeLibrary" _
    (ByVal hLibModule As Long) As Long
    
    Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
    
    
    Private Declare Function GetProcAddress Lib "KERNEL32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    
    Private Declare Function CreateThread Lib "KERNEL32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, _
    ByVal lpStartAddress As Long, ByVal lpparameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
    Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
        ByVal lpPrevWndFunc As Long, _
        ByVal hwnd As Long, _
        ByVal msg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
    
    
    Private Declare Function WaitForSingleObject Lib "KERNEL32" _
                                (ByVal hHandle As Long, _
                                ByVal dwMilliseconds As Long) As Long
    
    Private Declare Function GetExitCodeThread Lib "KERNEL32" _
    (ByVal hThread As Long, lpExitCode As Long) As Long
    
    Private Declare Sub ExitThread Lib "KERNEL32" (ByVal dwExitCode As Long)
    
    Private Const STATUS_WAIT_0 = &H0
    Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)
    
    
    
    
    Private Const ERROR_SUCCESS As Long = 0
    Private Const HKEY_CLASSES_ROOT As Long = &H80000000
    Private Const HKEY_CURRENT_USER As Long = &H80000001
    
    'Registry-Keys
    Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
        ByVal hKey As Long, _
        ByVal lpSubKey As String, _
        phkResult As Long) As Long
    Private Declare Function RegOverridePredefKey Lib "advapi32" ( _
        ByVal hKey As Long, _
        ByVal hNewHKey As Long) As Long
    Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
        ByVal hKey As Long) As Long
        
        Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" ( _
        ByVal lpLibFileName As String) As Long
    
    Private Declare Function FreeLibrary Lib "kernel32.dll" ( _
        ByVal hLibModule As Long) As Long
    
    Public Function Register_DLL(DLLName As String, Optional Unregister As Boolean = False) As Integer
    
        Dim lRet As Long
        Dim hKey As Long
        Dim hModule As Long
        Dim pAdr As Long
        Dim S As String
        Register_DLL = 0
        S = App.Path
        If Right(S, 1) <> "\" Then S = S & "\"
        S = DLLName
    
        
        'Override HKEY_CLASSES_ROOT:
        If RegOpenKey(HKEY_CURRENT_USER, "Software\\Classes", hKey) = ERROR_SUCCESS Then
            lRet = RegOverridePredefKey(HKEY_CLASSES_ROOT, hKey)
            RegCloseKey hKey
            If lRet = ERROR_SUCCESS Then
                'Call the normal registration entry:
                hModule = LoadLibrary(S)
                If hModule Then
                    If Unregister Then
                        pAdr = GetProcAddress(hModule, "DllUnregisterServer")
                    Else
                        pAdr = GetProcAddress(hModule, "DllRegisterServer")
                    End If
                    Shell DLLName & " /Register"
                    If pAdr Then
                        CallWindowProc pAdr, 0, 0, 0, ByVal 0
                    Else
                        Register_DLL = 4
                    End If
                Else
                    MsgBox "DLL-Error " + CStr(Err.LastDllError) + " beim Registrieren von " + DLLName
                    Register_DLL = 1
                End If
                FreeLibrary hModule
                'Restore Override of HKEY_CLASSES_ROOT:
                lRet = RegOverridePredefKey(HKEY_CLASSES_ROOT, 0&)
                If lRet <> ERROR_SUCCESS Then
                    Register_DLL = 6
                End If
            Else
                Register_DLL = 2
            End If
        Else
            Register_DLL = 3
        End If
    End Function

  2. #2
    Fanatic Member
    Join Date
    Sep 2012
    Posts
    534
    Last edited by dreammanor; Jan 3rd, 2018 at 11:28 AM. Reason: Error Links

  3. #3
    Frenzied Member
    Join Date
    Jun 2015
    Posts
    1,669

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Per your registration code - It doesn't make any sense to call DllRegisterServer / DllUnregisterServer using CallWindowProc.
    I would automatically think stack corruption. Use DispCallFunc instead.

    Better yet - why don't you just run regsvr32 from an elevated prompt?
    Imagine what it would be like to set breakpoints in, or step through subclassing code;
    and then being able to hit stop/end/debug or continue, without crashing the IDE.

    VB6.tlb | Bulletproof Subclassing in the IDE (no thunks/assembly/DEP issues)

  4. #4
    PowerPoster
    Join Date
    Feb 2006
    Posts
    18,036

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    See DX8VB.DLL, DX7VB.DLL, VB6 and Vista Compatibility

    These DLLs are not included in an OS after Windows XP and there is no legal way to install them.

    Thus this thread is about piracy and violates the Terms here.

  5. #5
    Frenzied Member
    Join Date
    Jun 2015
    Posts
    1,669

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    According to the license, a developer has the rights to everything in the DX8 redist folder which includes dx8vb.dll.
    You can obtain the license with the DX8 SDK.
    Imagine what it would be like to set breakpoints in, or step through subclassing code;
    and then being able to hit stop/end/debug or continue, without crashing the IDE.

    VB6.tlb | Bulletproof Subclassing in the IDE (no thunks/assembly/DEP issues)

  6. #6
    Super Moderator Shaggy Hiker's Avatar
    Join Date
    Aug 2002
    Location
    Idaho
    Posts
    31,292

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    That thread linked to is nearly 11 years old, is a discussion between people without any particular authority, and it seems like all the 'further reference' links are now dead. At least none of them worked for me.

    So, is this really the case? Was DirectX8 the last release of DirectX that worked for VB6 and no other solution has come forwards in the last decade? Has the EULA never changed in it's back-door denial of the right to install the dlls?
    My usual boring signature: Nothing

  7. #7
    Frenzied Member
    Join Date
    Jun 2015
    Posts
    1,669

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Quote Originally Posted by Shaggy Hiker View Post
    Was DirectX8 the last release of DirectX that worked for VB6 and no other solution has come forwards in the last decade?
    DX8 only worked in VB because MS made an ActiveX Shim for it. If one is inclined it's not difficult to make an ActiveX shim or Typelib for DX9, or use one someone else created. In the Codebank Trick has posted a typelib and replacement functions for the static lib (for those that don't know how to use static libs in VB) Someone else also created a shim DLL for VB - so there's at least 2 solutions for updated DX versions for VB. But that's for DX9.

    Quote Originally Posted by Shaggy Hiker View Post
    Has the EULA never changed in it's back-door denial of the right to install the dlls?
    I must be missing something. Is there some clause in the Developer license that denies the right to install the DLLs?

    edit:
    According to this.
    Code:
    DISTRIBUTION REQUIREMENTS.  You may reproduce and distribute an unlimited 
    number of copies of the Sample Code and/or Redistributable Code, (collectively "REDISTRIBUTABLE 
    COMPONENTS") as described above, provided that (a) you distribute the REDISTRIBUTABLE COMPONENTS only 
    as part of, or for use in conjunction with your Application; (b) your Application adds significant and primary 
    functionality to the REDISTRIBUTABLE COMPONENTS; (c) the REDISTRIBUTABLE COMPONENTS only operate in 
    conjunction with Microsoft Windows operating system products including Microsoft Windows 98, Millennium 
    Edition or Windows 2000 and subsequent versions thereof, (d) you distribute your Application containing the 
    REDISTRIBUTABLE COMPONENTS pursuant to an End-User License Agreement (which may be "break-the-seal", 
    "click-wrap", or signed), with terms no less protective than those contained herein; (e) you do not permit 
    further redistribution of the REDISTRIBUTABLE COMPONENTS by your end-user customers; (f) you must use 
    the setup utility included with the REDISTRIBUTABLE COMPONENTS to install the Redistributable Code; (g) you 
    do not use Microsoft's name, logo, or trademarks to market your Application; (h) you include all copyright and 
    trademark notices contained in the REDISTRIBUTABLE COMPONENTS; (i) you include a valid copyright notice 
    on your Application; and (j) you agree to indemnify, hold harmless, and defend Microsoft from any against any 
    claims or lawsuits, including attorneys' feeds, that arise or result from the use or distribution of your 
    Application. 
    
    If you distribute the Redistributable Code separately for use with your Application (such as on your web site or 
    as part of an update to your Application), you must include an end user license agreement in the install 
    program for the Redistributable Code in the form of DXF\DXSDK\license\directx end user eula.txt. Contact 
    Microsoft for the applicable royalties due and other licensing terms for all other uses and/or distribution of the 
    REDISTRIBUTABLE COMPONENTS.
    So technically I can get around clause (f) and redist the entire package separately (but still as part of my program). Whereby it's up to the End user to figure out how to install it on a modern OS. The EULA doesn't specify how the end user installs the package. Clause (f) only limits a developer from installing the DLLs separately in a custom installer.

    If it were me - I would just use DX9.
    Last edited by DEXWERX; Jan 3rd, 2018 at 02:38 PM.
    Imagine what it would be like to set breakpoints in, or step through subclassing code;
    and then being able to hit stop/end/debug or continue, without crashing the IDE.

    VB6.tlb | Bulletproof Subclassing in the IDE (no thunks/assembly/DEP issues)

  8. #8
    Super Moderator Shaggy Hiker's Avatar
    Join Date
    Aug 2002
    Location
    Idaho
    Posts
    31,292

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    That't the answer I was expecting to get. DX8 is OLD, so I'd be surprised if people hadn't found a way to move on....hmmm, I'm not going to say more on that.

    Still, I think that may be a good interpretation of the EULA. You can distribute DX8 as long as it stays together. Frankly, I would think that you could also come up with a solution that would install what was needed, as well.
    My usual boring signature: Nothing

  9. #9
    Frenzied Member
    Join Date
    Jun 2015
    Posts
    1,669

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Quote Originally Posted by Shaggy Hiker View Post
    Frankly, I would think that you could also come up with a solution that would install what was needed, as well.
    Like a utility that extracts the needed DLLs for newer OS. Considering it's no longer supported on newer O/S, there would be limited legal exposure to something like that.

    Eventually I'd like to put out a DX9 dll, but in the mean time the OP should really jump to DX9 using the Trick's typelib. http://www.vbforums.com/showthread.p...-VB6-Direct3D9
    Last edited by DEXWERX; Jan 3rd, 2018 at 03:12 PM.
    Imagine what it would be like to set breakpoints in, or step through subclassing code;
    and then being able to hit stop/end/debug or continue, without crashing the IDE.

    VB6.tlb | Bulletproof Subclassing in the IDE (no thunks/assembly/DEP issues)

  10. #10

    Thread Starter
    New Member
    Join Date
    Oct 2017
    Posts
    8

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    First of all thank you all for the help!!

    Quote Originally Posted by dreammanor View Post
    Sorry, I just posted some wrong links, the following links may be useful to you:
    Thanks a lot dreammanor!
    I had already read some of them
    I did not know one of them, the modTrickUnregCOM one
    Unfortunately it also crashed

    Quote Originally Posted by DEXWERX View Post
    Per your registration code - It doesn't make any sense to call DllRegisterServer / DllUnregisterServer using CallWindowProc.
    I would automatically think stack corruption. Use DispCallFunc instead.
    It just worked fine until now, I will try the DispCallFunc you tell me

    Quote Originally Posted by DEXWERX View Post
    Better yet - why don't you just run regsvr32 from an elevated prompt?
    Of course everithing works fine with regsvr32 form admin, the problems is the users do not have this rights



    Quote Originally Posted by dilettante View Post
    See DX8VB.DLL, DX7VB.DLL, VB6 and Vista Compatibility

    These DLLs are not included in an OS after Windows XP and there is no legal way to install them.

    Thus this thread is about piracy and violates the Terms here.
    I have read all the threat you mentioned, not a single answer from Microsoft. I have the same problem as a person that post there. I used 20 years ago a technology that worked fine, and still works fine today in W10, that is VB6 and DX8 for VB. I had the bad luck that Microsoft decided to kill both technologies. Thousands of lines of codes, bla bla bla, the same history as I suppose lots of you have.
    I don't sell the software, it is just for internal use. I don't know if I am being illegal, but I think ethically Microsoft are being the bad guys

    Quote Originally Posted by Shaggy Hiker View Post
    That thread linked to is nearly 11 years old, is a discussion between people without any particular authority, and it seems like all the 'further reference' links are now dead. At least none of them worked for me.

    So, is this really the case? Was DirectX8 the last release of DirectX that worked for VB6 and no other solution has come forwards in the last decade? Has the EULA never changed in it's back-door denial of the right to install the dlls?
    I believe it is the case, that is Microsoft, ...

    Quote Originally Posted by DEXWERX View Post
    DX8 only worked in VB because MS made an ActiveX Shim for it. If one is inclined it's not difficult to make an ActiveX shim or Typelib for DX9, or use one someone else created. In the Codebank Trick has posted a typelib and replacement functions for the static lib (for those that don't know how to use static libs in VB) Someone else also created a shim DLL for VB - so there's at least 2 solutions for updated DX versions for VB. But that's for DX9.

    If it were me - I would just use DX9.
    That would be the next solution, but for sure this will be more effort, If DirectCOM or any other admin free registry tool allows me to use directX8, that would be the quiker solution


    Quote Originally Posted by DEXWERX View Post
    Like a utility that extracts the needed DLLs for newer OS. Considering it's no longer supported on newer O/S, there would be limited legal exposure to something like that.

    Eventually I'd like to put out a DX9 dll, but in the mean time the OP should really jump to DX9 using the Trick's typelib. http://www.vbforums.com/showthread.p...-VB6-Direct3D9
    I will definitively have a try on it and I come to you back

    **** Edited -> I had a look, it looks great but there are several important missing features that we intensively use as Meshes, and support to sound and input (as joystick) that came with Dx8.

    Thank you all for you time!!
    Last edited by nicopeis; Jan 3rd, 2018 at 04:24 PM. Reason: Quoting and joining all responces

  11. #11
    Hyperactive Member
    Join Date
    Dec 2014
    Posts
    383

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    and if you want to use directx10/11, check this site: https://sites.google.com/site/dawoodoz/home

  12. #12
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    3,397

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Wow, I've got a DirectX8 VB6 application I hadn't played around with for a while.

    I just took a look at it, and found the DX81SDK_VB.exe and tried to install it. I couldn't get it to install on Win10-64 no matter what I tried. I tried several compatibility settings, and nothing I did would work.

    I guess DX8 is now officially dead.

    All The Best,
    Elroy
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  13. #13

    Thread Starter
    New Member
    Join Date
    Oct 2017
    Posts
    8

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Thanks again for your time

    Quote Originally Posted by baka View Post
    and if you want to use directx10/11, check this site: https://sites.google.com/site/dawoodoz/home
    It looks awesome I will for sure have a look at it

    I found another DirectX9 library that looks quite complete Here it is if somebody found it useful

    http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=59767&lngWId=1



    Quote Originally Posted by Elroy View Post

    I guess DX8 is now officially dead.

    Elroy
    Hi Elroy, of course it is not dead on W10, it is working absolutely fine just need to register a single file (regsvr32 dx8vb.dll) with admin rights, you don't need all the SDK to developp your code with VB6

    It looks that the newer versions of DirectX continue having what is needed for this library to work


    Apart on trying to move to a newer version of DirectX with unofficial libraries, I am still wondering why the DirectCOM crashes, does anybody has an explanation for that? Is the code that I have posted wrong??

  14. #14
    PowerPoster
    Join Date
    Jun 2013
    Posts
    3,301

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    Quote Originally Posted by nicopeis View Post
    Apart on trying to move to a newer version of DirectX with unofficial libraries, I am still wondering why the DirectCOM crashes, does anybody has an explanation for that?
    It crashes, because DirectCOM.dll can only create regfree instances, which "derive from IDispatch" (which is the case with all VB6-Dlls - and most other MS-ActiveX-Objects).

    The DX8-Interfaces all derive directly from IUnknown (no LateBound-mode possible) - so you will have to
    do what DirectCOM does internally, but avoid the final Cast to "As Object".

    Here is code, which works without problems (creating a DX8-Instance regfree) - but it requires Eduardo Morcillos olelib.tlb currently, to keep the example short:
    Code:
    Option Explicit
    
    Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lpLibFileName As Long) As Long
    Private Declare Function DllGetClassObject Lib "dx8vb" (REFCLSID As UUID, RefIID As UUID, CF As IClassFactory) As Long
     
    Public DX8 As DirectX8
     
    Sub Main()
      Set DX8 = LoadDX8RegFree(App.path & "\dx8vb.dll")
      Debug.Print DX8.GetDSEnum.GetCount 'just a short test-method-call against the retrieved instance
    End Sub
     
    Function LoadDX8RegFree(DX8DllPath As String) As DirectX8
    Static hLib As Long
        If hLib = 0 Then hLib = LoadLibraryW(StrPtr(DX8DllPath))
      
        Dim IIDCF As UUID, IIDDX8CoCls As UUID, IIDDX8 As olelib.UUID, CF As IClassFactory
            olelib.CLSIDFromString "{E7FF1300-96A5-11D3-AC85-00C04FC2C602}", IIDDX8CoCls
            olelib.CLSIDFromString "{E7FF1301-96A5-11D3-AC85-00C04FC2C602}", IIDDX8
            olelib.CLSIDFromString "{00000001-0000-0000-C000-000000000046}", IIDCF
        If DllGetClassObject(IIDDX8CoCls, IIDCF, CF) Then Err.Raise vbObjectError, , "Couldn't open ClassFactory"
        
        CF.CreateInstance Nothing, IIDDX8, LoadDX8RegFree
    End Function
    I've tested the above with an unregistered DX8VB.dll in the Projects App.Path on a Win8.1 machine, which does not have this Dll in SysWow64.

    HTH

    Olaf

  15. #15

    Thread Starter
    New Member
    Join Date
    Oct 2017
    Posts
    8

    Re: Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    YOU ARE ALL AWESOME!!!

    Thanks Olaf the code you wrote worked perfectly! But I needed to have access to another object in the library (D3DX8) and I had some troubles following your explanations due to my low level skills. I am not familiar with the "derive from IDispatch" and after googling some time I could not get where you got these numbers ("{E7FF1300-96A5-11D3-AC85-00C04FC2C602}") from. If you have a second I would be glad if you tell me where I can search information to learn about that

    BUT you code and structures used by Eduardo looked pretty similar to the one use in the post dreammanor provided me

    So I tried to rewrite a little code inspired from the one you provided and I worked fine, without the need of the Eduardo Morcillos olelib.tlb and placing the dx8vb.dll in any folder

    That is what I did
    First of all importing the modTrickUnregCOM.bas module coming from dreammanor post from Krivous Anatolii Anatolevich

    Code:
    ' The module modTrickUnregCOM.bas - for working with COM libraries without registration.
    ' © Krivous Anatolii Anatolevich (The trick), 2015
    
    Option Explicit
    
    Public Type GUID
        data1       As Long
        data2       As Integer
        data3       As Integer
        data4(7)    As Byte
    End Type
    
    Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
                             ByVal lpszCLSID As Long, _
                             ByRef clsid As GUID) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" ( _
                             ByRef src As Any, _
                             ByRef dst As Any) As Long
    Private Declare Function SysFreeString Lib "oleaut32" ( _
                             ByVal lpbstr As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" _
                             Alias "LoadLibraryW" ( _
                             ByVal lpLibFileName As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" _
                             Alias "GetModuleHandleW" ( _
                             ByVal lpModuleName As Long) As Long
    Private Declare Function FreeLibrary Lib "kernel32" ( _
                             ByVal hLibModule As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" ( _
                             ByVal hModule As Long, _
                             ByVal lpProcName As String) As Long
    Private Declare Function DispCallFunc Lib "oleaut32" ( _
                             ByVal pvInstance As Any, _
                             ByVal oVft As Long, _
                             ByVal cc As Integer, _
                             ByVal vtReturn As Integer, _
                             ByVal cActuals As Long, _
                             ByRef prgvt As Any, _
                             ByRef prgpvarg As Any, _
                             ByRef pvargResult As Variant) As Long
    Private Declare Function LoadTypeLibEx Lib "oleaut32" ( _
                             ByVal szFile As Long, _
                             ByVal regkind As Long, _
                             ByRef pptlib As IUnknown) As Long
    Private Declare Function memcpy Lib "kernel32" _
                             Alias "RtlMoveMemory" ( _
                             ByRef Destination As Any, _
                             ByRef Source As Any, _
                             ByVal Length As Long) As Long
    Private Declare Function CreateStdDispatch Lib "oleaut32" ( _
                             ByVal punkOuter As IUnknown, _
                             ByVal pvThis As IUnknown, _
                             ByVal ptinfo As IUnknown, _
                             ByRef ppunkStdDisp As IUnknown) As Long
                             
    Private Const IID_IClassFactory   As String = "{00000001-0000-0000-C000-000000000046}"
    Private Const IID_IUnknown        As String = "{00000000-0000-0000-C000-000000000046}"
    Private Const CC_STDCALL          As Long = 4
    Private Const REGKIND_NONE        As Long = 2
    Private Const TKIND_COCLASS       As Long = 5
    Private Const TKIND_DISPATCH      As Long = 4
    Private Const TKIND_INTERFACE     As Long = 3
    
    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
    Then writing this little piece of code

    Code:
    Function LoadObjectRegFree(DllPath As String, ObjName As String) As Object
        Dim listOfClsid() As GUID, listOfNames() As String, countCoClass As Long, countiIDs As Long
        GetAllCoclasses DllPath, listOfClsid, listOfNames, countCoClass
        Dim i As Integer
        For i = LBound(listOfNames) To UBound(listOfNames)
            If listOfNames(i) = ObjName Then
                Set LoadObjectRegFree = CreateObjectEx(DllPath, listOfClsid(i))
                Exit Function
            End If
        Next i
    End Function
    The code works perfect, no matter where the library is!! and the casting is done without bugging I can simply load my objects by

    Code:
    Private Sub Class_Initialize()
        Dim DX8 As DirectX8
        Dim DDX As D3DX8
        Set DX8 = LoadObjectRegFree("c:\Users\Public\dx8vb.dll", "DirectX8")
        Set DDX = LoadObjectRegFree("c:\Users\Public\dx8vb.dll", "D3DX8")
    End Sub
    I hope this wil be useful for somebody, for me it has been extremely useful!

    THANKS A LOT TO EVERYONE!!!
    Last edited by nicopeis; Jan 4th, 2018 at 08:47 AM.

  16. #16
    Frenzied Member
    Join Date
    Jun 2015
    Posts
    1,669

    Re: [RESOLVED] Regfree DirectX dx8vb.dll usage with DirectCOM.dll

    I've also used Trick's code with success in the past (as has Elroy). Very similar to Olaf's DirectCOM.
    Thanks for posting the code that worked for you!
    Imagine what it would be like to set breakpoints in, or step through subclassing code;
    and then being able to hit stop/end/debug or continue, without crashing the IDE.

    VB6.tlb | Bulletproof Subclassing in the IDE (no thunks/assembly/DEP issues)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.