PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197

PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197

PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197
[RESOLVED] Trying to implement IShellItem-VBForums
Results 1 to 20 of 20

Thread: [RESOLVED] Trying to implement IShellItem

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Resolved [RESOLVED] Trying to implement IShellItem

    Hi dear forum members.

    I am trying to load a file thumbnail hBmp without using a typelib so I use the CallFunction_COM written by LaVolpe

    I can't figure out the vtable offset of the IShellItemImageFactory::GetImage method.

    When I pass offset 8, CallFunction_COM returns S_OK but I get a null bmp handle.

    Can someone who knows tell me what the actual vtable offset is ?

    Regards.
    Last edited by JAAFAR; May 29th, 2019 at 08:59 AM.

  2. #2

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Ok - Here is the code that I have to extract the thumbnail from a file :

    When I run the following TEST routine , I fail to get a valid BMP handle - Can anybody test the code and tell me what is wrong ?

    BTW, the Windows cache is set just to make sure I get the thumbnail bmp.

    Code:
    Code:
    Option Explicit
    
    Type Size
        cx As Long
        cy As Long
    End Type
    
    
    Declare Function ILCreateFromPathW Lib "shell32" (ByVal pszPath As Long) As Long
    
    Declare Sub ILFree Lib "shell32" (ByVal pIDL As Long)
    
    Declare Function IIDFromString Lib "ole32.dll" _
        (ByVal lpsz As Long, ByVal lpiid As Long) As Long
    
    Declare Function SHCreateItemFromIDList Lib "shell32" _
        (ByVal pIDL As Long, ByVal rIID As Long, ppv As stdole.IUnknown) 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)
    
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
    
    Const CC_STDCALL As Long = 4
    Const SIIGBF_THUMBNAILONLY = &H8
    Const S_OK = 0
    
    
    Sub TEST()
    
        Dim uGUID(0 To 3) As Long
        Dim tSize As Size
        Dim lPid As Long
        Dim sFilePath As String
        Dim hBmp As Long
        Dim hr As Long
        Dim mUnk As stdole.IUnknown, pUnk As Long
        
        
        sFilePath = "D:\HHOLLAKKO\mygif.gif"
        
        lPid = ILCreateFromPathW(StrPtr(sFilePath))
        
        Debug.Print "PIDL : " & vbTab & lPid
        
        hr = IIDFromString(StrPtr("{BCC18B79-BA16-442F-80C4-8A59C30C463B}"), VarPtr(uGUID(0)))
        Debug.Print hr   '<== S_OK indicates success
        
        hr = SHCreateItemFromIDList(lPid, VarPtr(uGUID(0)), mUnk)
        Debug.Print hr '<== S_OK indicates success
        
        pUnk = ObjPtr(mUnk)
        
        tSize.cx = 100: tSize.cy = 100
        
        hr = CallFunction_COM(pUnk, 4 * 2, vbLong, CC_STDCALL, tSize.cx, tSize.cy, SIIGBF_THUMBNAILONLY, VarPtr(hBmp))
        Debug.Print hr  '<== S_OK indicates success
        
        Debug.Print hBmp '<== Failure returns null BMP handle
        
        ILFree lPid
    
    
    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
    
    
        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 vParamPtr() As Long, 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

  3. #3
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    Re: Trying to implement IShellItem

    Wouldn't it just be the standard ordinal for that interface, there's only that one call so 4, since while IShellItem implements IShellItemImageFactory, IShellItemImageFactory inherits directly from IUnknown, and you're creating your object with the GUID for ISIIF and not IShellItem.
    Code:
    [
    	odl,
    	uuid(bcc18b79-ba16-442f-80c4-8a59c30c463b)
    ]
    interface IShellItemImageFactory : stdole.IUnknown {
    	long GetImage(
    		//[in] SIZE* size,
    		[in] LONG cx,
    		[in] LONG cy,
    		[in] SIIGBF flags,
    		[out] HBITMAP *phbm);
    };
    Edit: PS- ILFree is deprecated since Win2000 and probably won't work on newer platforms because of differences in memory allocation, use CoTaskMemFree instead.

  4. #4

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Duplicate post deleted.
    Last edited by JAAFAR; May 29th, 2019 at 08:36 PM.

  5. #5

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Thanks fafalone

    So are you saying I should pass 4 as GetImage is the only method - right ?

    But with the code I posted, when I pass 4 or any offset other than 8 as vtble offset , the whole code crashes !

    and you're creating your object with the GUID for ISIIF and not IShellItem
    Yes- Is the GUID the correct way ?

    BTW, the mention of IShellItem is because my post was originally part of an old thread and some moderator later detached the post from that thread. ... So I never meant IShellItem

  6. #6
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,279

    Re: Trying to implement IShellItem

    Quote Originally Posted by JAAFAR View Post
    But with the code I posted, when I pass 4 or any offset other than 8 as vtble offset , the whole code crashes !
    You need to get your Offsets right - the way I do it (to make less mistakes, is shown below:
    - using an EnumDef (which defines the vtable-entries as "zerobased Index-Entries with a friendly name")
    - and a multiplier (in 32Bit VB6 you can hardwire it to 4) within the VtblCall-Helper-function
    This way, I can pass-in the Enum-Values directly into the vbtblCall-Helper

    Here the code you're after (needs an RC5-reference, but the only thing used from it is:
    New_c.vtblCall ... (which is basically the same as the Lavolpe-Helper - only that the Offsets are Indexes - and internally multiplied by 4).

    Code:
    Option Explicit
     
    Private Declare Function CLSIDFromString& Lib "ole32" (ByVal lpszProgID&, pCLSID As Any)
    Private Declare Function SHCreateItemFromParsingName& Lib "shell32" (ByVal pPath&, ByVal pBC&, rIID As Any, ppV As Any)
     
    Private Enum vtbl_IShellItemImageFactory 'define an enum for the VTbl-Indexes
      'IUnknown Entries:[3]
      °QueryInterface
      °AddRef
      °Release
        
      'IShellItemImageFactory Entries:[1]
      °GetImage 'HResult GetImage( [In] SIZE size, [In] SIIGBF flags, [Out] out IntPtr phbm);
    End Enum
    
    Function GetBmp(Path As String, Optional ByVal sz& = 32, Optional ByVal fl&) As Long
      Const sIID_IShellItemImageFactory$ = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"
      
      Dim HRes As Long, bIID(0 To 15) As Byte, Unk As stdole.IUnknown, pUnk As Long
      CLSIDFromString StrPtr(sIID_IShellItemImageFactory), bIID(0)
     
      HRes = SHCreateItemFromParsingName(StrPtr(Path), 0, bIID(0), Unk)
      If HRes Then Err.Raise HRes Else pUnk = ObjPtr(Unk)
      
      HRes = New_c.vtblCall(vbLong, pUnk, vtbl_IShellItemImageFactory.°GetImage, sz, sz, fl, VarPtr(GetBmp))
      If HRes Then Err.Raise HRes
      
      'we are done - the following two calls just to show, that the "upper" vtbl-entries work as well
      Debug.Print New_c.vtblCall(vbLong, pUnk, vtbl_IShellItemImageFactory.°AddRef)  'should return 2
      Debug.Print New_c.vtblCall(vbLong, pUnk, vtbl_IShellItemImageFactory.°Release) 'should return 1
    End Function '<- our local Unk-Variable will go out of scope here automatically
    The above is producing the following output (here tested on Win8.1):


    The Form-Code, which produced the ScreenShot was this one here:
    Code:
    Option Explicit
    
    Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
    Private Declare Function ReleaseDC& Lib "user32" (ByVal hWnd&, ByVal DC&)
    Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC&, ByVal hBM&, ByVal nStartSL&, ByVal nNumSL&, lpBits As Any, lpBI As Any, ByVal wUsage&)
    Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObj&)
      
    Private Sub Form_Load()
      Dim hBmp As Long
          hBmp = GetBmp("c:", 256)
      
      Dim Srf As cCairoSurface   'define a Cairo-Surface as "copy-over-target" from hBmp
      Set Srf = Hdl2Srf(hBmp, 1) '<- the optional 1 ensures, that hBmp is deleted within Hdl2Srf
      
      With Srf.CreateContext 'to draw something new *underneath* of something existing...
        .Operator = CAIRO_OPERATOR_DEST_OVER '<- we can use the Destination_Over-Operator
        .Paint 1, Cairo.CreateSolidPatternLng(vbWhite) '... otherwise the Alpha-content would render as black
      End With
      Set Picture = Srf.Picture
    End Sub
    
    Function Hdl2Srf(hBmp&, ByVal DelHdl&, Optional ByVal PreMul& = 1) As cCairoSurface
      Dim BI(0 To 9) As Long: BI(0) = 40
      Dim hDC As Long: hDC = GetDC(0)
      GetDIBits hDC, hBmp, 0, 0, ByVal 0&, BI(0), 0
      If BI(1) + BI(2) Then Set Hdl2Srf = Cairo.CreateSurface(BI(1), BI(2)) Else GoTo 1
     
      BI(2) = -BI(2) 'negate the Height-Member (addressing bottom-up behaviour)
      BI(3) = 1 + 65536 * 32 '1 Plane and 32BitsPerPixel
      BI(4) = 0 'enforce a zero (no compression) in this member (get rid of potential residues, as e.g. BI_BITFIELDS from the call above)
      BI(5) = Hdl2Srf.Stride * Hdl2Srf.Height 'tell GetDIBits the size we expect (in case the source-size differed)
      
      GetDIBits hDC, hBmp, 0, -BI(2), ByVal Hdl2Srf.DataPtr, BI(0), 0
      If PreMul Then Cairo.PreMultiplyAlpha Hdl2Srf.DataPtr, Hdl2Srf.Stride * Hdl2Srf.Height
      
    1 ReleaseDC 0, hDC
      If DelHdl Then DeleteObject hBmp
    End Function
    HTH

    Olaf
    Last edited by Schmidt; May 30th, 2019 at 10:24 AM. Reason: enhanced Hdl2Srf() to avoid problems - see comment on the BI(4) member

  7. #7

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Thanks for responding Schmidt

    needs an RC5-reference)
    For portability reasons, I can't use any third party libraries so I must make this work at runtime without any dependencies which is the reason I used LaVolpe's vtble helper function to begin with.


    , but the only thing used from it is:
    New_c.vtblCall ... (which is basically the same as the Lavolpe-Helper - only that the Offsets are Indexes - and internally multiplied by 4).
    Based on your above statement I should then be able to make this work with LaVolpe's helper function if I multiply the offset index by 4 (on 32Bit systems) without the need to use the RC5-reference.

    As shown on the code below, I have incorporated your idea of using vtbl_IShellItemImageFactory enum for better readibility and have used the SHCreateItemFromParsingName API just as you did in your example.

    So far, everything works fine .

    Then when I proceed to executing the GetImage method via the use of LaVolpe's helper function to which I pass your vtbl_IShellItemImageFactory.°GetImage multiplied by 4 as follows, the whole application crashes !!!!:

    Code:
        HRes = CallFunction_COM(pUnk, 4 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
        CC_STDCALL, 256, 256, SIIGBF_THUMBNAILONLY, VarPtr(hBmp))


    Here is the entire code I used so you can give it a test and verify the issue I am describing:
    Code:
    Option Explicit
       
    Declare Function CLSIDFromString Lib "ole32.dll" _
        (ByVal lpsz As Long, lpiid As Any) As Long
        
    Private Declare Function SHCreateItemFromParsingName Lib "shell32" _
        (ByVal pPath As Long, ByVal pBC As Long, rIID As Any, ppV As Any) 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)
    
    
    Enum vtbl_IShellItemImageFactory 'define an enum for the VTbl-Indexes
      'IUnknown Entries:[3]
      °QueryInterface
      °AddRef
      °Release
        
      'IShellItemImageFactory Entries:[1]
      °GetImage  'HResult GetImage( [In] SIZE size, [In] SIIGBF flags, [Out] out IntPtr phbm);
    End Enum
    
    
    Const CC_STDCALL As Long = 4
    Const S_OK = 0
    Const SIIGBF_THUMBNAILONLY = &H8
    
    
    Sub TEST()
    
        Dim sFilePath As String
        Dim hBmp As Long
        Dim pUnk As Long
        Dim HRes As Long, bIID(0 To 15) As Byte, Unk As stdole.IUnknown
        
        Const sIID_IShellItemImageFactory$ = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"
        sFilePath = "C:"
        
        HRes = CLSIDFromString(StrPtr(sIID_IShellItemImageFactory), bIID(0))
        Debug.Print HRes  '<== S_OK success
        
        HRes = SHCreateItemFromParsingName(StrPtr(sFilePath), 0, bIID(0), Unk)
        Debug.Print HRes  '<== S_OK success
        
        pUnk = ObjPtr(Unk)
        Debug.Print pUnk  '<== S_OK success
        
        'CRASHES HERE !!!!!
        HRes = CallFunction_COM(pUnk, 4 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
        CC_STDCALL, 256, 256, SIIGBF_THUMBNAILONLY, VarPtr(hBmp))
    
    End Sub
    
    
    
    'HELPER FUNCTION
    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
    
    
        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 vParamPtr() As Long, 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
    Any idea why this not working ?

    Regards.
    Last edited by JAAFAR; May 30th, 2019 at 12:24 AM.

  8. #8
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,408

    Re: Trying to implement IShellItem

    @JAAFAR: Your SHCreateItemFromParsingName API declares result As Any. When you pass a reference variable VB inserts in implicit cast to it's type. When you call it w/ Unk the result is implicitly cast to IUnknown which differs as address from IShellItemImageFactory impl of this particular coclass so you cannot call 4-th method (as there is no 4-th method in IUnknown vtbl).

    To stop this implicit cast just pass the numeric pUnk to SHCreateItemFromParsingName and directly use it in CallFunction_COM like this

    thinBasic Code:
    1. '
    2.     HRes = SHCreateItemFromParsingName(StrPtr(sFilePath), 0, bIID(0), pUnk) '--- uses pUnk
    3.     Debug.Print HRes, pUnk  '<== S_OK success, dumps pUnk
    4.    
    5. '    pUnk = ObjPtr(Unk)   '--- deleted
    6. '    Debug.Print pUnk  '<== S_OK success '--- deleted
    7.  
    8.     ' *doesn't* CRASHES HERE anymore !!!!!
    9.     HRes = CallFunction_COM(pUnk, 4 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
    10.         CC_STDCALL, 256, 256, SIIGBF_THUMBNAILONLY, VarPtr(hBmp))
    I still get error &H8004B200 in HRes but at least it's not bombing with AV.

    cheers,
    </wqw>

  9. #9

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Thanks for the explanation wqweto

    It still crashes at that line just like before ...even after I made the changes you suggested.

    And even if it didn't crash on my computer , I would still be getting the &H8004B200 error you are getting which is no good .

    Still looking for an answer ...

    Regards.

  10. #10
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,408

    Re: Trying to implement IShellItem

    Quote Originally Posted by JAAFAR View Post
    Thanks for the explanation wqweto

    It still crashes at that line just like before ...even after I made the changes you suggested.

    And even if it didn't crash on my computer , I would still be getting the &H8004B200 error you are getting which is no good .

    Still looking for an answer ...
    Error &H8004B200 is caused by SIIGBF_THUMBNAILONLY. Pass 0 or SIIGBF_ICONONLY and it returns image for C: drive just fine.

    Is it still crashing on your machine? Here is a full dump of my modifications that is working ok here

    thinBasic Code:
    1. Option Explicit
    2.    
    3. Declare Function CLSIDFromString Lib "ole32.dll" _
    4.     (ByVal lpsz As Long, lpiid As Any) As Long
    5.    
    6. Private Declare Function SHCreateItemFromParsingName Lib "shell32" _
    7.     (ByVal pPath As Long, ByVal pBC As Long, rIID As Any, ppV As Any) As Long
    8.    
    9.    
    10. Declare Function DispCallFunc Lib "oleAut32.dll" _
    11.     (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, _
    12.     ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, _
    13.     ByRef paValues As Long, ByRef retVAR As Variant) As Long
    14.    
    15. Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    16.  
    17.  
    18. Enum vtbl_IShellItemImageFactory 'define an enum for the VTbl-Indexes
    19.   'IUnknown Entries:[3]
    20.   °QueryInterface
    21.   °AddRef
    22.   °Release
    23.    
    24.   'IShellItemImageFactory Entries:[1]
    25.   °GetImage  'HResult GetImage( [In] SIZE size, [In] SIIGBF flags, [Out] out IntPtr phbm);
    26. End Enum
    27.  
    28.  
    29. Const CC_STDCALL As Long = 4
    30. Const S_OK = 0
    31. Const SIIGBF_THUMBNAILONLY = &H8
    32. Const SIIGBF_ICONONLY = 4
    33.  
    34.  
    35. Sub TEST()
    36.  
    37.     Dim sFilePath As String
    38.     Dim hBmp As Long
    39.     Dim pUnk As Long
    40.     Dim HRes As Long, bIID(0 To 15) As Byte, Unk As stdole.IUnknown
    41.    
    42.     Const sIID_IShellItemImageFactory$ = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"
    43.     sFilePath = "C:"
    44.    
    45.     HRes = CLSIDFromString(StrPtr(sIID_IShellItemImageFactory), bIID(0))
    46.     Debug.Print HRes  '<== S_OK success
    47.    
    48.     HRes = SHCreateItemFromParsingName(StrPtr(sFilePath), 0, bIID(0), pUnk)
    49.     Debug.Print HRes  '<== S_OK success
    50.    
    51. '    pUnk = ObjPtr(Unk)
    52. '    Debug.Print pUnk  '<== S_OK success
    53.    
    54.     'CRASHES HERE !!!!!
    55.     HRes = CallFunction_COM(pUnk, 4 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
    56.         CC_STDCALL, 256, 256, 0, VarPtr(hBmp))
    57.  
    58. End Sub
    59.  
    60.  
    61.  
    62. 'HELPER FUNCTION
    63. Private Function CallFunction_COM(ByVal InterfacePointer As Long, ByVal VTableOffset As Long, _
    64. ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
    65.  
    66.  
    67.     If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    68.     If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
    69.  
    70.  
    71.     Dim pIndex As Long, pCount As Long
    72.     Dim vParamPtr() As Long, vParamType() As Integer
    73.     Dim vRtn As Variant, vParams() As Variant
    74.    
    75.     vParams() = FunctionParameters()
    76.     pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    77.     If pCount = 0& Then
    78.         ReDim vParamPtr(0 To 0)
    79.         ReDim vParamType(0 To 0)
    80.     Else
    81.         ReDim vParamPtr(0 To pCount - 1&)
    82.         ReDim vParamType(0 To pCount - 1&)
    83.         For pIndex = 0& To pCount - 1&
    84.             vParamPtr(pIndex) = VarPtr(vParams(pIndex))
    85.             vParamType(pIndex) = VarType(vParams(pIndex))
    86.         Next
    87.     End If
    88.                                                        
    89.     pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0), vParamPtr(0), vRtn)
    90.        
    91.     If pIndex = 0& Then
    92.         CallFunction_COM = vRtn
    93.     Else
    94.         SetLastError pIndex
    95.     End If
    96.  
    97. End Function
    cheers,
    </wqw>

  11. #11

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Thanks wqweto for taking the trouble of posting the entire code.

    In reality, I can't test that code on my machine because i have windows 10 64 bit and I am using the code not in VB6 but in VBA 64bit .

    The actual 64 bit vba code that I am actually using (and which is faling so far) is the following one :

    (Below is your last code adapted to 64bit vba but still crashing !!!)

    Changes are in red to account for 64 bit handles & pointers
    Code:
    Option Explicit
       
    Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" _
        (ByVal lpsz As LongPtr, lpiid As Any) As Long
        
    Private Declare PtrSafe Function SHCreateItemFromParsingName Lib "shell32" _
        (ByVal pPath As LongPtr, ByVal pBC As Long, rIID As Any, ppV As Any) As Long
        
        
    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
        
        
    Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
     
     
    Enum vtbl_IShellItemImageFactory 'define an enum for the VTbl-Indexes
      'IUnknown Entries:[3]
      °QueryInterface
      °AddRef
      °Release
        
      'IShellItemImageFactory Entries:[1]
      °GetImage  'HResult GetImage( [In] SIZE size, [In] SIIGBF flags, [Out] out IntPtr phbm);
    End Enum
     
     
    Const CC_STDCALL As Long = 4
    Const S_OK = 0
    Const SIIGBF_THUMBNAILONLY = &H8
    Const SIIGBF_ICONONLY = 4
     
     
    Sub TEST()
     
        Dim sFilePath As String
        Dim hBmp As LongPtr
        Dim pUnk As LongPtr
        Dim HRes As Long, bIID(0 To 15) As Byte, Unk As stdole.IUnknown
        
        Const sIID_IShellItemImageFactory$ = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"
        sFilePath = "C:"
        
        HRes = CLSIDFromString(StrPtr(sIID_IShellItemImageFactory), bIID(0))
        Debug.Print HRes  '<== S_OK success
        
        HRes = SHCreateItemFromParsingName(StrPtr(sFilePath), 0, bIID(0), pUnk)
        Debug.Print HRes  '<== S_OK success
        
    '    pUnk = ObjPtr(Unk)
    '    Debug.Print pUnk  '<== S_OK success
        
        'CRASHES HERE !!!!!
        HRes = CallFunction_COM(pUnk, 8 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
            CC_STDCALL, 256, 256, 0, VarPtr(hBmp))
            
            
            Debug.Print HRes
     
    End Sub
     
     
     
    'HELPER FUNCTION
    Private Function CallFunction_COM(ByVal InterfacePointer As LongPtr, ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, ByVal CallConvention As Long, ParamArray FunctionParameters() As Variant) As Variant
     
     
        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 vParamPtr() As LongPtr, 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
    Something related to the memory layout in the 64bit process is likely to be causing the problem but I can't figure it out and the code just crashes without warning ... The 64bit code seems correct to me.

    Sorry about the inconvinience but I didn't want to add an extra layer of complexity so I prefered not to mention that I am using 64bit VBA.

    Regards.

    EDIT:
    I also changed the bIID(0 To 15) As Byte to .... bIID(0 To 30) As Byte just in case to account for the double number of bytes in the sIID_IShellItemImageFactory on a 64bit system but still no luck !

    BTW, LongPtr = LongLong = 8 Bytes
    Last edited by JAAFAR; May 30th, 2019 at 04:09 AM.

  12. #12
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,408

    Re: Trying to implement IShellItem

    @JAAFAR: Try this

    ThinBasic Code:
    1. ' Not CRASHES HERE anymore !!!!!
    2.     HRes = CallFunction_COM(pUnk, 8 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
    3.         CC_STDCALL, 256 * &H100000000^ + 256, 0, VarPtr(hBmp))
    You are suffering from the curious case of passing structs by value. In your case SIZE struct is declared as LONG cx, cy which in windows.h parlance means a pair of 32-bit values in *both* x86 and x64 versions.

    While in x86 you can pass cx and cy as separate 32-bit paramrters in x64 the parameters are widened to 64-bit and SIZE struct fits in a single parameter so it has to be encoded as cx + cy * 2^32 to be ABI compatible with windows API functions.

    For VB6 folks, the caret in &H100000000^ is LongLong type character. In x64 VBA numeric literals do not auto-promote to LongLong the way &H1000 is Integer but &H10000 is Long in VB6. In x64 &H100000000 w/o the type character fails as it does not fit Long range.

    Here is a table (from another SO popular site) with sizes in bits of popular windows.h data types

    Code:
    Type                        | S/U | x86    | x64
    ----------------------------+-----+--------+-------
    BYTE, BOOLEAN               | U   | 8 bit  | 8 bit
    ----------------------------+-----+--------+-------
    SHORT                       | S   | 16 bit | 16 bit
    USHORT, WORD                | U   | 16 bit | 16 bit
    ----------------------------+-----+--------+-------
    INT, LONG                   | S   | 32 bit | 32 bit
    UINT, ULONG, DWORD          | U   | 32 bit | 32 bit
    ----------------------------+-----+--------+-------
    INT_PTR, LONG_PTR, LPARAM   | S   | 32 bit | 64 bit
    UINT_PTR, ULONG_PTR, WPARAM | U   | 32 bit | 64 bit
    ----------------------------+-----+--------+-------
    LONGLONG                    | S   | 64 bit | 64 bit
    ULONGLONG, QWORD            | U   | 64 bit | 64 bit
    cheers,
    </wqw>

  13. #13

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    EXCELLENT !! Finally, It did return a valid BMP handle

    Always learning cool things here... Your explanation makes sense... In fact, APIs such as WindowFromPoint, PtInRect etc are declared differently in 64bit for that reason ... I should have remembered that !

    I owe you a very very big THANK-YOU, wqweto

    And thanks to fafalone and Schmidt for their valuable input as well.


    EDIT:

    Alternatively I could have used CopyMemory and pass the pointer of the UDT struct to the helper function ... something as follows worked as well :

    Code:
        Dim lPt As LongPtr
        Dim tSize As Size
                   
        tSize.cx = 256: tSize.cy = 256
        CopyMemory lPt, tSize, LenB(tSize)
         
         HRes = CallFunction_COM(pUnk, 8 * vtbl_IShellItemImageFactory.°GetImage, vbLong, _
            CC_STDCALL, lPt, 0, VarPtr(hBmp))
    Last edited by JAAFAR; May 30th, 2019 at 07:58 AM.

  14. #14
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,279

    Re: Trying to implement IShellItem

    Quote Originally Posted by wqweto View Post
    @JAAFAR: Your SHCreateItemFromParsingName API declares result As Any.
    When you pass a reference variable VB inserts in implicit cast to it's type.
    That's basically true - but "only half-way" ...
    VB performes an Object-cast (a QueryInterface-call on the Objects IUnknown-Interface) under two conditions:
    - when the Object-Types differ
    - when the passed Object is a living instance (when it's Not Nothing - since you cannot call QueryInterface on a non-existing instance of course).

    In the concrete example, none of the above two conditions is met (passing an "un-instantiated" Unk As IUnknown-Variable with a content of Zero is perfectly fine).

    Quote Originally Posted by wqweto View Post
    When you call it w/ Unk the result is implicitly cast to IUnknown
    which differs as address from IShellItemImageFactory impl of this particular coclass
    so you cannot call 4-th method (as there is no 4-th method in IUnknown vtbl).
    That's not true.
    All, the callee (SHCreateItemFromParsingName) will see "at the inside of its implementation" is:
    - a valid VarPtr (to our passed, but yet zeroed "Unk-slot")
    - and a GUID, which tells it - what kind of instance-pointer to place in that empty Unk-slot

    Quote Originally Posted by wqweto View Post
    To stop this implicit cast just pass the numeric pUnk to SHCreateItemFromParsingName and directly use it in CallFunction_COM ...
    That's not good advice IMO (or at least "incomplete advice"), because now one will become responsible oneself,
    to perform an explicit CallFunction_COM on the °Release member of the vtbl_Enum... (to destroy the Object-instance properly on routine-exit).
    Leaving this explicit Release-call (on pUnk) out, will otherwise cause mem-leakage due to the amounting Obj-instances which were left alive.

    The "Unk-passing + later pUnk = ObjPtr(Unk)" thingy has a reason...

    It will ensure, that (even in a "forced early exit" - as e.g. from calling Err.Raise with an HResult<>0) -
    that the RefCounter of the retrieved instance is properly decremented by the VB6-runtime (in the routine-epilogue which ensures proper freeing of routine-local Vars).

    @JAAFAR
    In your own adaption of the Test-Routine - you're currently leaving the created Factory-Instance(s) alive on routine-exit
    (due to reducing it to "pUnk only"-mode)...

    Since I'm at it - your now properly returned hBmp's usually contain "normal" (as in "un-premultiplied") Alpha.
    So you cannot directly use them in a call to GdiAlphaBlend (without premultiplying first).

    I've tried to demonstrate the Alpha-Handling and hBmp-usage in my Hdl2Srf(...) routine in prior post #4
    (which I've had to correct recently BTW, fixing a priorily missing "reset" of the biCompression-member of the BitmapInfoHeader-struct).

    Olaf
    Last edited by Schmidt; May 30th, 2019 at 12:33 PM.

  15. #15
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,408

    Re: [RESOLVED] Trying to implement IShellItem

    @Olaf: It seems you are right! I have no idea why OP's code in #7 was not working on his *and* my machine in IDE.

    On second testing it's working fine here and peeking at the generated assembly confirms that no QI is happening after SHCreateItemFromParsingName on the Unk parameter.

    Then adding a reference to oleexp.tlb confirmed that IUnknown and IShellItemImageFactory interface impl share the same address for this coclass.

    Code:
        Dim pFactory As IShellItemImageFactory
        Set pFactory = Unk
        MsgBox "&H" & Hex$(ObjPtr(Unk)) & " vs &H" & Hex$(ObjPtr(pFactory)), vbExclamation
    So both hypotheses are debunked :-))

    cheers,
    </wqw>

  16. #16

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    177

    Re: Trying to implement IShellItem

    Quote Originally Posted by Schmidt View Post
    @JAAFAR
    In your own adaption of the Test-Routine - you're currently leaving the created Factory-Instance(s) alive on routine-exit
    (due to reducing it to "pUnk only"-mode)...

    Since I'm at it - your now properly returned hBmp's usually contain "normal" (as in "un-premultiplied") Alpha.
    So you cannot directly use them in a call to GdiAlphaBlend (without premultiplying first).

    I've tried to demonstrate the Alpha-Handling and hBmp-usage in my Hdl2Srf(...) routine in prior post #4
    (which I've had to correct recently BTW, fixing a priorily missing "reset" of the biCompression-member of the BitmapInfoHeader-struct).

    Olaf
    @Olaf

    First point taken regarding the passing of unk in order to avoid the need for subsequent explicit releasing .

    As for the Alpha_Handling of the bmp, the routine that you provided uses an external library which I am trying to avoid ... Is there a purely runtime coding alternative approach ?

    Regards.

  17. #17
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,279

    Re: Trying to implement IShellItem

    Quote Originally Posted by JAAFAR View Post
    As for the Alpha_Handling of the bmp, the routine that you provided uses an external library which I am trying to avoid ...
    Is there a purely runtime coding alternative approach ?
    Well - "pure runtime-coding" is generally a good idea - because the purpose of a runtime-lib is not only to provide "more encapsulated functionality",
    but to decouple from the underlying Operating-system as well (to make your written UserCode portable + usable on other Systems without changing a single line).

    So, normally (with that purpose in mind) you should try to avoid any Declares into the Win32-API (or other MS-dependencies) as well.
    But I take it, that you meant - "external MS-libs, which come preinstalled on Windows, are allowed" (when talking about "purely runtime")...

    What I can give you "at short notice" is the code below, which is based on a derivation of the Hdl2Srf-routine
    (to get rid of the Bmp-Handle fast, and to have something in a "selfdescribing container width+height-wise" instead,
    which in a "pure runtime-approach" would mean: "a plain two-dimensional VB6-Long-Array-allocation":

    Code:
    Option Explicit
    
    Private Declare Function GetDC& Lib "user32" (ByVal hWnd&)
    Private Declare Function ReleaseDC& Lib "user32" (ByVal hWnd&, ByVal DC&)
    Private Declare Function GetDIBits& Lib "gdi32" (ByVal aHDC&, ByVal hBM&, ByVal nStartSL&, ByVal nNumSL&, lpBits As Any, lpBI As Any, ByVal wUsage&)
    Private Declare Function StretchDIBits& Lib "gdi32" (ByVal hDC&, ByVal x&, ByVal y&, ByVal dx&, ByVal dy&, ByVal SrcX&, ByVal SrcY&, ByVal Srcdx&, ByVal Srcdy&, lpBits As Any, lpBitsInfo As Any, ByVal wUsage&, ByVal dwRop&)
    Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObj&)
    
    Private Sub Form_Click()
      On Error Resume Next
      Dim hBmp As Long, P() As Long
          hBmp = GetBmp("c:\temp\EarthAnim.gif", 256) 'yes, this can load *.gif or *.png contents directly as well
      If Err Then MsgBox Err.Description: Err.Clear: Exit Sub
     
      P = Hdl2PxlArr32(hBmp) '<-the optional DelHdl-Param of Hdl2PxlArr32 is per default true...
      '... so after the above line is finished, the hBmp is properly destroyed and cleaned up...
      
      'What we got is a self-describing container, which holds the dimensions of the Alpha32-Bmp
      Caption = "hBmp=" & hBmp & " (" & UBound(P, 1) + 1 & "x" & UBound(P, 2) + 1 & ")"
      
      DrawArr hDC, P 'so "let's see it" (pre-multiplying remains to be done)
    End Sub
     
    Function Hdl2PxlArr32(hBmp&, Optional ByVal DelHdl& = 1) As Long()
      Dim BI(0 To 9) As Long: BI(0) = 40
      Dim hDC As Long: hDC = GetDC(0)
      Dim P() As Long: ReDim P(-1 To -1, -1 To -1) 'return -1 Bounds in case of an error-caused early exit
      
      GetDIBits hDC, hBmp, 0, 0, ByVal 0&, BI(0), 0 'first call will retrieve "infos only"
      If BI(1) + BI(2) Then ReDim P(0 To BI(1) - 1, 0 To BI(2) - 1) Else GoTo 1 'goto cleanup in case of no success
     
      BI(2) = -BI(2) 'negate the Height-Member (addressing bottom-up behaviour)
      BI(3) = 1 + 65536 * 32 '1 Plane and 32BitsPerPixel
      BI(4) = 0 'enforce a zero (no compression) in this member (get rid of potential residues, as e.g. BI_BITFIELDS from the call above)
      BI(5) = 4 * BI(1) * Abs(BI(2)) 'tell GetDIBits the size we expect (in case the source-size differed)
      
      GetDIBits hDC, hBmp, 0, -BI(2), P(0, 0), BI(0), 0
     
    1 ReleaseDC 0, hDC
      If DelHdl Then DeleteObject hBmp
      Hdl2PxlArr32 = P '<- being the last instruction, this will avoid a copy - returning the P()-Pointer directly
    End Function
    
    Sub DrawArr(hDC As Long, P() As Long) 'renders a 32Bit-2D-LongArray directly
      Dim W As Long, H As Long, BI(9) As Long
          W = UBound(P, 1) + 1: H = UBound(P, 2) + 1
       If W = 0 Or H = 0 Then Exit Sub
       BI(0) = 40: BI(1) = W: BI(2) = -H: BI(3) = 1 + 65536 * 32 '1 plane + 32bpp
      StretchDIBits hDC, 0, 0, W, H, 0, 0, W, H, P(0, 0), BI(0), 0, vbSrcCopy
    End Sub
    The above is already able, to render the raw, unmultiplied Alpha-Pixels.

    As for Alpha-Premultiplying (on a 32Bit-2D-LongArray via looping) - I will have to look around for a fast routine,
    which I know I've written some time ago - but cannot find at the moment...

    "External Libs, different from Cairo" (like GDI+ or WIA) should be able to deal with such "unmultiplied raw-Alpha32-allocations" as well though.

    Olaf

  18. #18
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,279

    Re: [RESOLVED] Trying to implement IShellItem

    Quote Originally Posted by wqweto View Post
    @Olaf: It seems you are right! I have no idea why OP's code in #7 was not working on his *and* my machine in IDE.
    Just a guess, but I'd think, it happened due to the way Lavolpe implemented the HResult-Error-Handling in the vTbl-Call-HelperRoutine (when DispCallFunc returns).

    Quote Originally Posted by wqweto View Post
    On second testing it's working fine here ...
    What will happen, when you pass parameters, which will make GetImage "choke" (in case you use LaVolpes vtbl-caller)?

    Quote Originally Posted by wqweto View Post
    ... peeking at the generated assembly confirms that no QI is happening after SHCreateItemFromParsingName on the Unk parameter.
    Thanks for confirming that.

    You were right to be concerned though ... the VB6-runtime sometimes does "weird extra-stuff under the covers"
    (as we know from String-Passing to Declared APIs - even declaring the Param-Slot for the String ' As Any' would not prevent ANSI-convs),
    but thankfully - in this case - the runtime did no extra-action on the filled Unk-param on return from the API-call.

    If it did (perform an IUnknown-cast on return), we would have gotten a Vtbl-Ptr similar to pUnk2 below
    (which is - as you said - "only good for calls on IUnknown itself").

    If you place additional Test-Code (the blue colored parts) into the routine I've originally posted further above...
    you can verify that...
    Code:
    Function GetBmp(Path As String, Optional ByVal sz& = 32, Optional ByVal fl&) As Long
      Const sIID_IShellItemImageFactory$ = "{BCC18B79-BA16-442F-80C4-8A59C30C463B}"
      
      Dim HRes As Long, bIID(0 To 15) As Byte, Unk As stdole.IUnknown, pUnk As Long
      CLSIDFromString StrPtr(sIID_IShellItemImageFactory), bIID(0)
     
      HRes = SHCreateItemFromParsingName(StrPtr(Path), 0, bIID(0), Unk)
      If HRes Then Err.Raise HRes Else pUnk = ObjPtr(Unk)
    
      Const sIID_IUnknown$ = "{00000000-0000-0000-C000-000000000046}"
      Dim bIID2(0 To 15) As Byte, pUnk2 As Long
      CLSIDFromString StrPtr(sIID_IUnknown), bIID2(0)
      HRes = New_c.vtblCall(vbLong, pUnk, vtbl_IShellItemImageFactory.°QueryInterface, VarPtr(bIID2(0)), VarPtr(pUnk2))
      Debug.Print HRes, pUnk, pUnk2
    
      'the "query-casted" ObjPtr in pUnk2 has an offset of 4 to the original VTbl-Pointer in pUnk - 
      'so it sits in the This-Struct of the Factory-instance directly below the main- vtbl-ptr member...
      'The following two calls via pUnk2 will work of course - but not the GetImage-call (since this pUnk2-vtbl has only the 3 IUnknown-members)
      Debug.Print New_c.vtblCall(vbLong, pUnk2, vtbl_IShellItemImageFactory.°AddRef)  'should return 3
      Debug.Print New_c.vtblCall(vbLong, pUnk2, vtbl_IShellItemImageFactory.°Release) 'should return the real instance count 2 (which is due to the additional ref in pUnk2)
    
    
      HRes = New_c.vtblCall(vbLong, pUnk, vtbl_IShellItemImageFactory.°GetImage, sz, sz, fl, VarPtr(GetBmp))
      If HRes Then Err.Raise HRes
    End Function
    Olaf

  19. #19
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,408

    Re: [RESOLVED] Trying to implement IShellItem

    Quote Originally Posted by Schmidt View Post
    If it did (perform an IUnknown-cast on return), we would have gotten a Vtbl-Ptr similar to pUnk2 below
    (which is - as you said - "only good for calls on IUnknown itself").
    Doh! Poor testing on my part again.

    I had to *explicitly* cast Unk to IUnknown before comparing to IShellItemImageFactory objptr. . . Without casting it is IShellItemImageFactory objptr in disguise (in an IUnknown variable) as requested by the rIID parameter :-))

    I think the compiler has to emit QI on As Any parameters as these are *not* typed as any interface so technically the actual arg's type always differs from As Any i.e. your points from above hold:

    VB performes an Object-cast (a QueryInterface-call on the Objects IUnknown-Interface) under two conditions:
    - when the Object-Types differ
    - when the passed Object is a living instance (when it's Not Nothing - since you cannot call QueryInterface on a non-existing instance of course).
    chees,
    </wqw>

  20. #20
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,245

    Re: [RESOLVED] Trying to implement IShellItem

    Just a heads up on SHCreateItemFromParsingName, as of Win10 it fails beyond the root path on device virtual paths (cell phones, cameras, etc). This caused me all manner of headaches after building navigation around it.

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