'Into a Class, named: cShellItem
Public Enum enmSIGDN
SIGDN_NORMALDISPLAY = &H0
SIGDN_PARENTRELATIVEPARSING = &H80018001
SIGDN_DESKTOPABSOLUTEPARSING = &H80028000
SIGDN_PARENTRELATIVEEDITING = &H80031001
SIGDN_DESKTOPABSOLUTEEDITING = &H8004C000
SIGDN_FILESYSPATH = &H80058000
SIGDN_URL = &H80068000
SIGDN_PARENTRELATIVEFORADDRESSBAR = &H8007C001
SIGDN_PARENTRELATIVE = &H80080001
SIGDN_PARENTRELATIVEFORUI = &H80094001
End Enum
Public Enum enmSICHINTF
SICHINT_DISPLAY = &H0
SICHINT_ALLFIELDS = &H80000000
SICHINT_CANONICAL = &H10000000
SICHINT_TEST_FILESYSPATH_IF_NOT_EQUAL = &H20000000
End Enum
Public Enum enmSFGAO
SFGAO_CANCOPY = &H1
SFGAO_CANMOVE = &H2
SFGAO_CANLINK = &H4
SFGAO_STORAGE = &H8
SFGAO_CANRENAME = &H10
SFGAO_CANDELETE = &H20
SFGAO_HASPROPSHEET = &H40
SFGAO_DROPTARGET = &H100
SFGAO_CAPABILITYMASK = &H177
SFGAO_SYSTEM = &H1000
SFGAO_ENCRYPTED = &H2000
SFGAO_ISSLOW = &H4000
SFGAO_LINK = &H10000
SFGAO_SHARE = &H20000
SFGAO_READONLY = &H40000
SFGAO_GHOSTED = &H8000
SFGAO_HIDDEN = &H80000
SFGAO_DISPLAYATTRMASK = &HFC000
SFGAO_NONENUMERATED = &H100000
SFGAO_NEWCONTENT = &H200000
SFGAO_STREAM = &H400000
SFGAO_VALIDATE = &H1000000
SFGAO_REMOVABLE = &H2000000
SFGAO_COMPRESSED = &H4000000
SFGAO_BROWSABLE = &H8000000
SFGAO_FILESYSANCESTOR = &H10000000
SFGAO_STORAGEANCESTOR = &H800000
SFGAO_FOLDER = &H20000000
SFGAO_FILESYSTEM = &H40000000
SFGAO_HASSUBFOLDER = &H80000000
SFGAO_CONTENTSMASK = &H80000000
SFGAO_STORAGECAPMASK = &H70C50008
SFGAO_PKEYSFGAOMASK = &H81044000
End Enum
Private Enum enmIShellItem 'this is the VTbl-Idx-Enum, used in the Private Helper-Func vtblcall, further below
'IUnknown
isi_QueryInterface
isi_AddRef
isi_Release
'IShellItem ...definitions and vtable-order from here: [url]http://fossies.org/dox/wine-1.4.1/interfaceIShellItem.html[/url]
isi_BindToHandler '([in] IBindCtx *pbc,[in] REFGUID rbhid,[in] REFIID riid,[out, iid_is(riid)] void **ppvOut)
isi_GetParent '([out] IShellItem **ppsi)
isi_GetDisplayName '([in] SIGDN sigdnName,[out] LPWSTR *ppszName)
isi_GetAttributes '([in] SFGAOF sfgaoMask,[out] SFGAOF *psfgaoAttribs)
isi_Compare '([in] IShellItem *psi,[in] SICHINTF hint,[out] int *piOrder)
End Enum
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR&, ByVal lpWStr&) As Long
Private Declare Function DispCallFunc& Lib "oleaut32" (ByVal ppv&, ByVal oVft&, _
ByVal CC&, ByVal rtTYP%, ByVal paCount&, paTypes%, paValues&, fuReturn)
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function ILCreateFromPathW Lib "shell32" (ByVal pszPath As Long) As Long
Private Declare Sub ILFree Lib "shell32" (ByVal pIDL As Long)
Private Declare Function SHCreateShellItem Lib "shell32" (ByVal pidlParent As Long, _
ByVal psfParent As Long, ByVal pIDL As Long, ppsi As stdole.IUnknown) As Long
Private mUnk As stdole.IUnknown, pUnk As Long, mPathName As String, pIDLAbs As Long, HRes As Long
Public Function InitFromPath(PathName As String)
Cleanup
mPathName = PathName
pIDLAbs = ILCreateFromPathW(ByVal StrPtr(mPathName))
HRes = SHCreateShellItem(0, 0, pIDLAbs, mUnk)
pUnk = ObjPtr(mUnk)
If HRes Then Err.Raise HRes
End Function
Friend Sub InitFromParentItem(ParentShellItem As stdole.IUnknown)
Cleanup
Set mUnk = ParentShellItem
pUnk = ObjPtr(mUnk)
End Sub
Public Property Get PathName() As String
PathName = mPathName
End Property
Public Property Get ShellItemUnk() As stdole.IUnknown
Set ShellItemUnk = mUnk
End Property
'after the few additional Public Props above,
'now the real IShellItem interface-implementation
'
'Public Function BindToHandler(...) '<- not yet implemented
Public Function GetParent() As cShellItem
Dim ParentUnk As stdole.IUnknown
HRes = vtblCall(isi_GetParent, VarPtr(ParentUnk))
If HRes Then Err.Raise HRes
If ParentUnk Is Nothing Then Exit Function
Set GetParent = New cShellItem
GetParent.InitFromParentItem ParentUnk
End Function
Public Function GetDisplayName(Optional ByVal SIGDN As enmSIGDN) As String
Dim pS As Long
HRes = vtblCall(isi_GetDisplayName, SIGDN, VarPtr(pS))
If HRes Then Err.Raise HRes
SysReAllocString VarPtr(GetDisplayName), pS
If pS Then CoTaskMemFree pS
End Function
Public Function GetAttributes(ByVal SFGAO As enmSFGAO) As Long
HRes = vtblCall(isi_GetAttributes, SFGAO, VarPtr(GetAttributes))
If HRes Then Err.Raise HRes
End Function
Public Function Compare(OtherItem As cShellItem, Optional ByVal SICHINTF As enmSICHINTF) As Long
HRes = vtblCall(isi_Compare, ObjPtr(OtherItem.ShellItemUnk), SICHINTF, VarPtr(Compare))
If HRes <> 0 And HRes <> 1 Then Err.Raise HRes
End Function
'vtblcall-by-index-> Helper-function
Private Function vtblCall(ByVal vtblIdx As enmIShellItem, ParamArray P())
Static VType(0 To 5) As Integer, VPtr(0 To 5) As Long
Const CC_CDECL& = 1, CC_STDCALL& = 4
Dim i As Long, V(), HResDisp As Long
If pUnk = 0 Then Exit Function
V = P 'make a copy of the params, to prevent problems with VT_ByRef-Members in the ParamArray
For i = 0 To UBound(V)
VType(i) = VarType(V(i))
VPtr(i) = VarPtr(V(i))
Next i
HResDisp = DispCallFunc(pUnk, vtblIdx * 4, CC_STDCALL, vbLong, i, VType(0), VPtr(0), vtblCall)
If HResDisp Then Err.Raise HResDisp, , "Error in DispCallFunc"
End Function
Private Sub Cleanup()
Set mUnk = Nothing: pUnk = 0
If pIDLAbs Then ILFree pIDLAbs: pIDLAbs = 0
End Sub
Private Sub Class_Terminate()
Cleanup
End Sub
