Imports System.Runtime.InteropServices
Imports System.IO
Imports System.IO.FileSystemInfo
Imports System.Text
Imports ExpTreeLib.ShellDll
Imports System.Windows.Forms 'only needed for some testing
Public Class CShItem
Implements IDisposable, IComparable
#Region " Private Fields"
'm_Folder and m_Pidl must be released/freed at Dispose time
Private m_Folder As IShellFolder 'if item is a folder, contains the Folder interface for this instance
Private m_Pidl As IntPtr 'The Absolute PIDL for this item (not retained for files)
Private m_DisplayName As String = ""
Private m_Path As String
Private m_TypeName As String
Private m_Parent As CShItem = Nothing
Private m_IconIndexNormal As Integer 'index into the System Image list for Normal icon
Private m_IconIndexOpen As Integer 'index into the SystemImage list for Open icon
Private m_IsBrowsable As Boolean
Private m_IsFileSystem As Boolean
Private m_IsFolder As Boolean
Private m_HasSubFolders As Boolean
Private m_IsLink As Boolean
Private m_IsDisk As Boolean
Private m_IsShared As Boolean
Private m_SortFlag As Integer = 0 'Used in comparisons
Private m_Directories As ArrayList
'The following elements are only filled in on demand
Private m_XtrInfo As Boolean = False
Private m_LastWriteTime As DateTime
Private m_CreationTime As DateTime
Private m_LastAccessTime As DateTime
Private m_Length As Long
Private Shared CreCount As Integer
Private Shared DesCount As Integer
'Flags for Dispose state
Private m_IsDisposing As Boolean
Private m_Disposed As Boolean
' The DesktopBase is set up via Sub New() (one time only) and
' disposed of only when DesktopBase is finally disposed of
Private Shared DesktopBase As CShItem
'On some systems,files with no extension are assigned the same
' icon as a Folder. The following is used instead
'Private Shared NoExtIconIndex As Integer
'We can avoid an extra SHGetFileInfo call once this is set up
Private Shared OpenFolderIconIndex As Integer = -1
'Private Shared SW As New StreamWriter("TmpLog.log")
#End Region
#Region " Destructor"
Public Overloads Sub Dispose() Implements IDisposable.Dispose
Dispose(True)
' Take yourself off of the finalization queue
' to prevent finalization code for this object
' from executing a second time.
GC.SuppressFinalize(Me)
End Sub
Protected Overridable Overloads Sub Dispose(ByVal disposing As Boolean)
' Allow your Dispose method to be called multiple times,
' but throw an exception if the object has been disposed.
' Whenever you do something with this class,
' check to see if it has been disposed.
If Not (m_Disposed) Then
' If disposing equals true, dispose all managed
' and unmanaged resources.
m_Disposed = True
If (disposing) Then
End If
' Release unmanaged resources. If disposing is false,
' only the following code is executed.
If Not IsNothing(m_Folder) Then
Marshal.ReleaseComObject(m_Folder)
End If
If Not m_Pidl.Equals(IntPtr.Zero) Then
Marshal.FreeCoTaskMem(m_Pidl)
End If
DesCount += 1
'Debug.WriteLine("Disposing of: " & m_DisplayName)
'Debug.WriteLine("CreCount = " & CreCount)
'Debug.WriteLine("DesCount = " & DesCount)
'If m_Path.Equals("Desktop") Then
' SW.Close()
'End If
Else
Throw New Exception("CShItem Disposed more than once")
End If
End Sub
' This Finalize method will run only if the
' Dispose method does not get called.
' By default, methods are NotOverridable.
' This prevents a derived class from overriding this method.
Protected Overrides Sub Finalize()
' Do not re-create Dispose clean-up code here.
' Calling Dispose(false) is optimal in terms of
' readability and maintainability.
Dispose(False)
End Sub
#End Region
#Region " Constructors"
Private Shared Sub Logit(ByVal who As CShItem)
CreCount += 1
'who.DebugDump()
End Sub
'<Summary>New(ByVal folder As IShellFolder, ByVal pidl As IntPtr, ByVal parent As CShitem)
'<param>folder -- the folder interface of the parent</param>
'<param>pidl -- the Relative PIDL of this item</param>
'<param>parent -- the CShitem of the parent</param>
'</Summary>
Private Sub New(ByVal folder As IShellFolder, ByVal pidl As IntPtr, ByVal parent As CShItem)
If IsNothing(DesktopBase) Then
DesktopBase = New CShItem() 'This initializes the Desktop folder
End If
m_Parent = parent
m_Pidl = concatPidls(parent.PIDL, pidl)
'Get some attributes
SetUpAttributes(folder, pidl)
'Fix TypeName
If m_IsFolder And m_TypeName.Equals("File") Then
m_TypeName = "File Folder"
End If
'Set unfetched value for IconIndex....
m_IconIndexNormal = -1
m_IconIndexOpen = -1
'finally, set up my Folder
If m_IsFolder Then
Dim HR As Integer
HR = folder.BindToObject(pidl, IntPtr.Zero, IID_IShellFolder, m_Folder)
If HR <> NOERROR Then
Marshal.ThrowExceptionForHR(HR)
End If
End If
m_SortFlag = ComputeSortFlag()
Logit(Me)
End Sub
Private Sub New() 'only used when desktopfolder has not been intialized
If Not IsNothing(DesktopBase) Then
Throw New Exception("Attempt to initialize CShItem for second time")
End If
Dim HR As Integer
m_DisplayName = "Desktop"
m_Path = "Desktop"
m_IsFolder = True
m_HasSubFolders = True
m_IsBrowsable = False
HR = SHGetDesktopFolder(m_Folder)
m_Pidl = GetSpecialFolderLocation(IntPtr.Zero, CSIDL.DESKTOP)
'Get Displayname, TypeName, and primary IconIndex
Dim shfi As New SHFILEINFO()
Dim dwflag As Integer = SHGFI.DISPLAYNAME Or _
SHGFI.TYPENAME Or _
SHGFI.SYSICONINDEX Or _
SHGFI.PIDL
Dim dwAttr As Integer = 0
Dim H As IntPtr = SHGetFileInfo(m_Pidl, dwAttr, shfi, cbFileInfo, dwflag)
m_DisplayName = shfi.szDisplayName
m_TypeName = "System Folder" 'not returned correctly by SHGetFileInfo
m_IconIndexNormal = shfi.iIcon
m_IconIndexOpen = shfi.iIcon
m_SortFlag = ComputeSortFlag()
Logit(Me)
End Sub
'<Summary> Create instance based on a non-desktop CSIDL
'</Summary>
Sub New(ByVal ID As CSIDL)
If IsNothing(DesktopBase) Then
DesktopBase = New CShItem() 'This initializes the Desktop folder
End If
Dim HR As Integer
HR = SHGetSpecialFolderLocation(0, ID, m_Pidl)
If HR = NOERROR Then
Dim pParent As IShellFolder
Dim relPidl As IntPtr = IntPtr.Zero
Dim itemCnt As Integer = PidlCount(m_Pidl)
If itemCnt = 1 Then 'parent is desktop
HR = SHGetDesktopFolder(pParent)
relPidl = m_Pidl
Else
Dim tmpPidl As IntPtr
tmpPidl = TrimPidl(m_Pidl, relPidl)
HR = DesktopBase.m_Folder.BindToObject(tmpPidl, IntPtr.Zero, IID_IShellFolder, pParent)
If Not HR = NOERROR Then Marshal.ThrowExceptionForHR(HR)
Marshal.FreeCoTaskMem(tmpPidl)
End If
'Get the Attributes
SetUpAttributes(pParent, relPidl)
'Set unfetched value for IconIndex....
m_IconIndexNormal = -1
m_IconIndexOpen = -1
'finally, set up my Folder
If m_IsFolder Then
HR = pParent.BindToObject(relPidl, IntPtr.Zero, IID_IShellFolder, m_Folder)
If HR <> NOERROR Then
Marshal.ThrowExceptionForHR(HR)
End If
End If
Marshal.ReleaseComObject(pParent)
'if itemCnt=1 then relPidl is same as m_Pidl, don't release
If itemCnt > 1 Then Marshal.FreeCoTaskMem(relPidl)
Else
Marshal.ThrowExceptionForHR(HR)
End If
m_SortFlag = ComputeSortFlag()
Logit(Me)
End Sub
Private Sub SetUpAttributes(ByVal folder As IShellFolder, ByVal pidl As IntPtr)
Dim attrFlag As SFGAO
attrFlag = SFGAO.BROWSABLE
attrFlag = attrFlag Or SFGAO.FILESYSTEM
attrFlag = attrFlag Or SFGAO.HASSUBFOLDER
attrFlag = attrFlag Or SFGAO.FOLDER
attrFlag = attrFlag Or SFGAO.LINK
attrFlag = attrFlag Or SFGAO.SHARE
'Note: for GetAttributesOf, we must provide an array, in almost all cases with 1 element
Dim aPidl(0) As IntPtr
aPidl(0) = pidl
folder.GetAttributesOf(1, aPidl, attrFlag)
m_IsBrowsable = CBool(attrFlag And SFGAO.BROWSABLE)
m_IsFileSystem = CBool(attrFlag And SFGAO.FILESYSTEM)
m_HasSubFolders = CBool(attrFlag And SFGAO.HASSUBFOLDER)
m_IsFolder = CBool(attrFlag And SFGAO.FOLDER)
m_IsLink = CBool(attrFlag And SFGAO.LINK)
m_IsShared = CBool(attrFlag And SFGAO.SHARE)
'Get the Path
Dim strr As New STRRET()
Dim buf As New StringBuilder(260)
Dim itemflags As SHGDN = SHGDN.FORPARSING
folder.GetDisplayNameOf(pidl, itemflags, strr)
Dim HR As Integer = StrRetToBuf(strr, pidl, buf, MAX_PATH)
If HR = NOERROR Then
m_Path = buf.ToString
'Get Displayname, TypeName, and primary IconIndex
Dim shfi As New SHFILEINFO()
Dim dwflag As Integer = SHGFI.DISPLAYNAME Or _
SHGFI.TYPENAME Or _
SHGFI.PIDL 'Or _
'SHGFI.SYSICONINDEX
Dim dwAttr As Integer = 0
If m_IsFileSystem And Not m_IsFolder Then
dwflag = dwflag Or SHGFI.USEFILEATTRIBUTES
dwAttr = FILE_ATTRIBUTE_NORMAL
End If
Dim H As IntPtr = SHGetFileInfo(m_Pidl, dwAttr, shfi, cbFileInfo, dwflag)
m_DisplayName = shfi.szDisplayName
m_TypeName = shfi.szTypeName
If m_TypeName.IndexOf("Disk") > -1 OrElse _
m_TypeName.IndexOf("Disc") > -1 Then
m_IsDisk = True
'Debug.WriteLine(m_Path & " is a Disk")
End If
Else
Marshal.ThrowExceptionForHR(HR)
End If
'fix DisplayName
If m_DisplayName.Equals("") Then
m_DisplayName = m_Path
End If
End Sub
#End Region
#Region " Properties"
#Region " Normal Properties"
Public ReadOnly Property PIDL() As IntPtr
Get
Return m_Pidl
End Get
End Property
Public ReadOnly Property DisplayName() As String
Get
Return m_DisplayName
End Get
End Property
Public ReadOnly Property Path() As String
Get
Return m_Path
End Get
End Property
Public ReadOnly Property TypeName() As String
Get
Return m_TypeName
End Get
End Property
Private ReadOnly Property Parent() As CShItem
Get
Return m_Parent
End Get
End Property
' IconIndexNormal is Filled on demand
Public ReadOnly Property IconIndexNormal() As Integer
Get
If m_IconIndexNormal < 0 Then
Dim shfi As New SHFILEINFO()
Dim dwflag As Integer = SHGFI.PIDL Or _
SHGFI.SYSICONINDEX
Dim dwAttr As Integer = 0
If m_IsFileSystem And Not m_IsFolder Then
dwflag = dwflag Or SHGFI.USEFILEATTRIBUTES
dwAttr = FILE_ATTRIBUTE_NORMAL
End If
Dim H As IntPtr = SHGetFileInfo(m_Pidl, dwAttr, shfi, cbFileInfo, dwflag)
m_IconIndexNormal = shfi.iIcon
End If
Return m_IconIndexNormal
End Get
End Property
' IconIndexOpen is Filled on demand
Public ReadOnly Property IconIndexOpen() As Integer
Get
If m_IconIndexOpen < 0 Then
If Not m_IsDisk And m_IsFileSystem And m_IsFolder Then
If OpenFolderIconIndex < 0 Then
Dim dwflag As Integer = SHGFI.SYSICONINDEX Or SHGFI.PIDL
Dim shfi As New SHFILEINFO()
Dim H As IntPtr = SHGetFileInfo(m_Pidl, 0, _
shfi, cbFileInfo, _
dwflag Or SHGFI.OPENICON)
m_IconIndexOpen = shfi.iIcon
If m_TypeName.Equals("File Folder") Then
OpenFolderIconIndex = shfi.iIcon
End If
Else
m_IconIndexOpen = OpenFolderIconIndex
End If
Else
m_IconIndexOpen = m_IconIndexNormal
End If
End If
Return m_IconIndexOpen
End Get
'Set(ByVal Value As Integer)
' m_IconIndexOpen = Value
'End Set
End Property
Public ReadOnly Property IsBrowsable() As Boolean
Get
Return m_IsBrowsable
End Get
End Property
Public ReadOnly Property IsFileSystem() As Boolean
Get
Return m_IsFileSystem
End Get
End Property
Public ReadOnly Property IsFolder() As Boolean
Get
Return m_IsFolder
End Get
End Property
Public ReadOnly Property HasSubFolders() As Boolean
Get
Return m_HasSubFolders
End Get
End Property
Public ReadOnly Property IsDisk() As Boolean
Get
Return m_IsDisk
End Get
End Property
Public ReadOnly Property IsLink() As Boolean
Get
Return m_IsLink
End Get
End Property
Public ReadOnly Property IsShared() As Boolean
Get
Return m_IsShared
End Get
End Property
Private ReadOnly Property SortFlag() As Integer
Get
Return m_SortFlag
End Get
End Property
#End Region
#Region " Filled on Demand Properties"
'Private m_XtrInfo As Boolean = False
'Private m_LastWriteTime As DateTime
'Private m_CreationTime As DateTime
'Private m_LastAccessTime As DateTime
'Private m_Length As Long
Private Sub FillDemandInfo()
If Not m_IsDisk And m_IsFileSystem And Not m_IsFolder Then
'in this case, it's a file
If File.Exists(m_Path) Then
Dim fi As New FileInfo(m_Path)
m_LastWriteTime = fi.LastWriteTime
m_LastAccessTime = fi.LastAccessTime
m_CreationTime = fi.CreationTime
m_Length = fi.Length
m_XtrInfo = True
End If
Else
If m_IsFileSystem And m_IsFolder Then
If Directory.Exists(m_Path) Then
Dim di As New DirectoryInfo(m_Path)
m_LastWriteTime = di.LastWriteTime
m_LastAccessTime = di.LastAccessTime
m_CreationTime = di.CreationTime
m_XtrInfo = True
End If
End If
End If
End Sub
Public ReadOnly Property LastWriteTime() As DateTime
Get
If Not m_XtrInfo Then
FillDemandInfo()
End If
Return m_LastWriteTime
End Get
End Property
Public ReadOnly Property LastAccessTime() As DateTime
Get
If Not m_XtrInfo Then
FillDemandInfo()
End If
Return m_LastAccessTime
End Get
End Property
Public ReadOnly Property CreationTime() As DateTime
Get
If Not m_XtrInfo Then
FillDemandInfo()
End If
Return m_CreationTime
End Get
End Property
Public ReadOnly Property Length() As Long
Get
If Not m_XtrInfo Then
FillDemandInfo()
End If
Return m_Length
End Get
End Property
#End Region
#End Region
#Region " Public Methods"
#Region " Shared Public Methods"
'<Summary> Public Shared Function GetDeskTop() as CShItem
' If not initialized, then build DesktoBase
' once done, or if initialized already,
'<Return> the DesktopBase CShItem representing the desktop</Return>
'</Summary>
Public Shared Function GetDeskTop() As CShItem
If IsNothing(DesktopBase) Then
DesktopBase = New CShItem()
End If
Return DesktopBase
End Function
#Region " AllFolderWalk"
'<Summary>
'The WalkAllCallBack delegate defines the signature of
'the routine to be passed to DirWalker
' Usage: dim d1 as new CshItem.WalkAllCallBack(addressof yourroutine)
' Callback function receives a CShItem for each file & Directory in
' Starting Directory and each sub-directory of this directory and
' each sub-dir of each sub-dir ....
'
'</Summary>
Public Delegate Function WalkAllCallBack(ByVal info As CShItem, _
ByVal UserLevel As Integer, _
ByVal Tag As Integer) _
As Boolean
'<Summary>
' AllFolderWalk recursively walks down directories from cStart, calling its
' callback routine, WalkAllCallBack, for each Directory and File encountered, including those in
' cStart. UserLevel is incremented by 1 for each level of dirs that DirWalker
' recurses thru. Tag in an Integer that is simply passed, unmodified to the
' callback, with each CShItem encountered, both File & Directory CShItems.
'</Summary>
Public Shared Function AllFolderWalk(ByVal cStart As CShItem, _
ByVal cback As WalkAllCallBack, _
ByVal UserLevel As Integer, _
ByVal Tag As Integer) _
As Boolean
If Not IsNothing(cStart) AndAlso cStart.IsFolder Then
Dim cItem As CShItem
'first processes all files in this directory
For Each cItem In cStart.GetFiles
If Not cback(cItem, UserLevel, Tag) Then
Return False 'user said stop
End If
Next
'then process all dirs in this directory, recursively
For Each cItem In cStart.GetDirectories
If Not cback(cItem, UserLevel + 1, Tag) Then
Return False 'user said stop
Else
If Not AllFolderWalk(cItem, cback, UserLevel + 1, Tag) Then
Return False
End If
End If
Next
Return True
Else 'Invalid call
Throw New ApplicationException("AllFolderWalk -- Invalid Start Directory")
End If
End Function
#End Region
''<Summary>
'' Returns the Directories of the Desktop as an
'' ArrayList of CShitems
''</Summary>
'Public Shared Function GetDeskTopDirectories() As ArrayList
' If IsNothing(DesktopBase) Then
' DesktopBase = New CShItem()
' End If
' Return DesktopBase.GetDirectories
'End Function
''<Summary>
''GetDesktopFiles() As ArrayList
'' Returns the Files of Desktopfolder as an
'' ArrayList of CShitems
'' Note: we do not keep the arraylist of files, Generate it each time
''</Summary>
'Public Shared Function GetDesktopFiles() As ArrayList
' If IsNothing(DesktopBase) Then
' DesktopBase = New CShItem()
' End If
' Return DesktopBase.GetFiles
'End Function
''<Summary>
''GetDesktopItems() As ArrayList
'' Returns the Files of Desktopfolder as an
'' ArrayList of CShitems
'' Note: we do not keep the arraylist of files, Generate it each time
''</Summary>
'Public Shared Function GetDesktopItems() As ArrayList
' If IsNothing(DesktopBase) Then
' DesktopBase = New CShItem()
' End If
' Return DesktopBase.GetItems
'End Function
'Public Shared Function GetDesktopIcon_Index(ByVal size As ShellIconStateConstants)
' If IsNothing(DesktopBase) Then
' DesktopBase = New CShItem()
' End If
' If size = ShellIconStateConstants.ShellIconStateNormal Then
' Return DesktopBase.IconIndexNormal
' Else
' Return DesktopBase.IconIndexOpen
' End If
'End Function
#End Region
#Region " Instance Methods"
'<Summary>
'GetDirectories() As ArrayList
' Returns the Directories of this sub-folder as an
' ArrayList of CShitems
'</Summary>
Public Function GetDirectories() As ArrayList
If m_IsFolder Then
If IsNothing(m_Directories) Then 'Build the list
m_Directories = GetContents(SHCONTF.FOLDERS Or SHCONTF.INCLUDEHIDDEN)
Return m_Directories
Else 'Built this once, just returned saved list
Return m_Directories
End If
Else 'if it is not a Folder, then return empty arraylist
Return New ArrayList()
End If
End Function
'<Summary>
'GetFiles() As ArrayList
' Returns the Files of this sub-folder as an
' ArrayList of CShitems
' Note: we do not keep the arraylist of files, Generate it each time
'</Summary>
Public Function GetFiles() As ArrayList
If m_IsFolder Then
Return GetContents(SHCONTF.NONFOLDERS Or SHCONTF.INCLUDEHIDDEN)
Else
Return New ArrayList()
End If
End Function
'<Summary>
'GetItems() As ArrayList
' Returns the Directories and Files of this sub-folder as an
' ArrayList of CShitems
' Note: we do not keep the arraylist of files, Generate it each time
'</Summary>
Public Function GetItems() As ArrayList
Dim rVal As New ArrayList()
If m_IsFolder Then
rVal.AddRange(Me.GetDirectories)
rVal.AddRange(Me.GetFiles)
Return rVal
Else
Return rVal
End If
End Function
Public Overrides Function ToString() As String
Return m_DisplayName
End Function
Public Sub DebugDump()
Debug.WriteLine("DisplayName = " & m_DisplayName)
Debug.WriteLine("PIDL = " & m_Pidl.ToString)
Debug.WriteLine(vbTab & "Path = " & m_Path)
Debug.WriteLine(vbTab & "TypeName = " & m_TypeName)
Debug.WriteLine(vbTab & "iIconNormal = " & m_IconIndexNormal)
Debug.WriteLine(vbTab & "iIconSelect = " & m_IconIndexOpen)
Debug.WriteLine(vbTab & "IsBrowsable = " & m_IsBrowsable)
Debug.WriteLine(vbTab & "IsFileSystem= " & m_IsFileSystem)
Debug.WriteLine(vbTab & "IsFolder = " & m_IsFolder)
Debug.WriteLine(vbTab & "IsLink = " & m_IsLink)
Debug.WriteLine(vbTab & "CreationCnt = " & CreCount)
Debug.WriteLine(vbTab & "DestroyCnt = " & DesCount)
If m_IsFolder Then
If Not IsNothing(m_Directories) Then
Debug.WriteLine(vbTab & "Directory Count = " & m_Directories.Count)
Else
Debug.WriteLine(vbTab & "Directory Count Not yet set")
End If
End If
End Sub
#End Region
#End Region
#Region " Private Methods"
'<Summary>
'GetContents(ByVal flags As SHCONTF)
' Returns the requested Items of this sub-folder as an
' ArrayList of CShitems
'<param>
' A set of one or more SHCONTF flags indicating which
' items to return
'</param>
'</Summary>
Private Function GetContents(ByVal flags As SHCONTF) As ArrayList
Dim rVal As New ArrayList()
Dim HR As Integer
Dim IEnum As IEnumIDList
HR = m_Folder.EnumObjects(0, flags, IEnum)
If HR = NOERROR Then
Dim item As IntPtr = IntPtr.Zero
Dim itemCnt As Integer
HR = IEnum.GetNext(1, item, itemCnt)
If HR = NOERROR Then
Do While itemCnt > 0 AndAlso Not item.Equals(IntPtr.Zero)
'there is no setting to exclude folders from enumeration,
' just one to include non-folders
' so we have to screen the results to return only
' non-folders if folders are not wanted
If Not CBool(flags And SHCONTF.FOLDERS) Then 'don't want folders. see if this is one
Dim attrFlag As SFGAO
attrFlag = attrFlag Or SFGAO.FOLDER
'Note: for GetAttributesOf, we must provide an array, in almost all cases with 1 element
Dim aPidl(0) As IntPtr
aPidl(0) = item
m_Folder.GetAttributesOf(1, aPidl, attrFlag)
If CBool(attrFlag And SFGAO.FOLDER) Then 'Don't need it
Marshal.FreeCoTaskMem(item)
GoTo SKIPONE
End If
End If
rVal.Add(New CShItem(m_Folder, item, Me))
Marshal.FreeCoTaskMem(item) 'if New kept it, it kept a copy
SKIPONE: item = IntPtr.Zero
itemCnt = 0
HR = IEnum.GetNext(1, item, itemCnt)
Loop
Else
If HR <> 1 Then GoTo HRError '1 means no more
End If
Else : GoTo HRError
End If
'Normal Exit
NORMAL: If Not IsNothing(IEnum) Then
Marshal.ReleaseComObject(IEnum)
End If
rVal.TrimToSize()
Return rVal
' Error Exit for all Com errors
HRError: 'not ready disks will return the following error
If HR = &HFFFFFFFF800704C7 Then
GoTo NORMAL
'unavailable net resources will return these
ElseIf HR = &HFFFFFFFF80040E96 Or HR = &HFFFFFFFF80040E19 Then
GoTo NORMAL
ElseIf HR = &HFFFFFFFF80004001 Then 'Certain "Not Implemented" features will return this
GoTo NORMAL
End If
If Not IsNothing(IEnum) Then Marshal.ReleaseComObject(IEnum)
Marshal.ThrowExceptionForHR(HR)
Return New ArrayList() 'sometimes it is a non-fatal error,ignored
End Function
#Region " Really nasty Pidl manipulation"
' Get Size in bytes of the first (possibly only)
' SHItem in an ID list. Note: the full size of
' the item is the sum of the sizes of all SHItems
' in the list!!
Private Shared Function ItemIDSize(ByVal pidl As IntPtr) As Integer
If Not pidl.Equals(IntPtr.Zero) Then
Dim b(1) As Byte
Marshal.Copy(pidl, b, 0, 2)
Return b(1) * 256 + b(0)
Else
Return 0
End If
End Function
'<Summary>Private Shared Function ItemIDListSize(ByVal pidl As IntPtr) As Integer
' computes the actual size of the ItemIDList pointed to by pidl
'<param>pidl -- the pidl pointing to an ItemIDList</param>
'<return> Returns actual size of the ItemIDList, less the terminating nulnul
'</return>
Private Shared Function ItemIDListSize(ByVal pidl As IntPtr) As Integer
If Not pidl.Equals(IntPtr.Zero) Then
Dim cnt As Integer = 1
Dim i As Integer = ItemIDSize(pidl)
Dim b As Byte
b = Marshal.ReadByte(pidl, i)
Do While b <> 0
i += b + (Marshal.ReadByte(pidl, i + 1) * 256)
b = Marshal.ReadByte(pidl, i)
If b <> 0 Then cnt += 1
Loop
Return i
Else : Return 0
End If
End Function
'<Summary>Private Shared Function PidlCount(ByVal pidl As IntPtr) As Integer
' counts the total number of SHItems in input pidl
'<param>pidl -- the pidl to obtain the count for</param>
'<return> Returns the count of SHItems pointed to by pidl</return>
Private Shared Function PidlCount(ByVal pidl As IntPtr) As Integer
If Not pidl.Equals(IntPtr.Zero) Then
Dim cnt As Integer = 1
Dim i As Integer = ItemIDSize(pidl)
Dim b As Byte
b = Marshal.ReadByte(pidl, i)
Do While b <> 0
i += b + (Marshal.ReadByte(pidl, i + 1) * 256)
b = Marshal.ReadByte(pidl, i)
If b <> 0 Then cnt += 1
Loop
Return cnt
Else : Return 0
End If
End Function
'<Summary> concatPidls(pidl1 as IntPtr, pidl2 as IntPtr) as IntPtr
' Concatenates the contents of two pidls into a new Pidl (ended by 00)
' allocating CoTaskMem to hold the result,
' placing the concatenation (followed by 00) into the
' allocated Memory,
' and returning an IntPtr pointing to the allocated mem
'<param> pidl1 -- ptr to a well formed SHItemIDList or IntPtr.Zero</param>
'<param> pidl2 -- ptr to a well formed SHItemIDList or IntPtr.Zero</param>
'<Return> Returns a ptr to an ItemIDList containing the
' concatenation of the two (followed by the req 2 zeros
' Caller must Free this pidl when done with it
'</Return>
Private Shared Function concatPidls(ByVal pidl1 As IntPtr, ByVal pidl2 As IntPtr) As IntPtr
Dim cb1 As Integer, cb2 As Integer
cb1 = ItemIDListSize(pidl1)
cb2 = ItemIDListSize(pidl2)
Dim rawCnt As Integer = cb1 + cb2
If (rawCnt) > 0 Then
Dim b(rawCnt + 1) As Byte
If cb1 > 0 Then
Marshal.Copy(pidl1, b, 0, cb1)
End If
If cb2 > 0 Then
Marshal.Copy(pidl2, b, cb1, cb2)
End If
Dim rVal As IntPtr = Marshal.AllocCoTaskMem(cb1 + cb2 + 2)
b(rawCnt) = 0 : b(rawCnt + 1) = 0
Marshal.Copy(b, 0, rVal, rawCnt + 2)
Return rVal
Else
Return IntPtr.Zero
End If
End Function
'<Summary>Private Shared Function TrimPidl(ByVal pidl As IntPtr) As IntPtr
' Returns an ItemIDList with the last ItemID trimed off
' This is necessary since I cannot get SHBindToParent to work
' It's purpose is to generate an ItemIDList for the Parent of a
' Special Folder which can then be processed with DesktopBase.BindToObject,
' yeilding a Folder for the parent of the Special Folder
' It also creates and passes back a RELATIVE pidl for this item
'<param>pidl -- A pointer to a well formed ItemIDList</param>
'<param>relPidl -- BYREF IntPtr which will point to a new relative pidl
' containing the contents of the last ItemID in the ItemIDList
' terminated by the required 2 nulls.
'<Returns> an ItemIDList with the last element removed.
' Caller must Free this item when through with it
' Also returns the new relative pidl in the 2nd parameter
' Caller must Free this pidl as well, when through with it
'</Returns>
'</Summary>
Private Shared Function TrimPidl(ByVal pidl As IntPtr, ByRef relPidl As IntPtr) As IntPtr
Dim cb As Integer = ItemIDListSize(pidl)
Dim b(cb + 1) As Byte
Marshal.Copy(pidl, b, 0, cb)
Dim prev As Integer = 0
Dim i As Integer = b(0) + (b(1) * 256)
Do While i < cb AndAlso b(i) <> 0
prev = i
i += b(i) + (b(i + 1) * 256)
Loop
If (prev + 1) < cb Then
'first set up the relative pidl
b(cb) = 0
b(cb + 1) = 0
Dim cb1 As Integer = b(prev) + (b(prev + 1) * 256)
relPidl = Marshal.AllocCoTaskMem(cb1 + 2)
Marshal.Copy(b, prev, relPidl, cb1 + 2)
b(prev) = 0 : b(prev + 1) = 0
Dim rVal As IntPtr = Marshal.AllocCoTaskMem(prev + 2)
Marshal.Copy(b, 0, rVal, prev + 2)
Return rVal
Else
Return IntPtr.Zero
End If
End Function
#End Region
#Region " Routines to test PIDL manipulation"
'Public Shared Function doPIDLTest() As ArrayList
' Dim lvi As New ListViewItem("Not Set")
' Dim aRet As New ArrayList()
' Dim xx As IntPtr
' xx = ShellDll.GetSpecialFolderLocation(IntPtr.Zero, CSIDL.HISTORY)
' Dim bb(299) As Byte
' Marshal.Copy(xx, bb, 0, 300)
' Dim sz As Integer = ItemIDSize(xx)
' sz = PidlCount(xx)
' 'Dim shfi1 As New SHFILEINFO()
' 'Dim uFlags1 As Integer = SHGFI.PIDL Or SHGFI.DISPLAYNAME Or SHGFI.TYPENAME
' 'uFlags1 = uFlags1 Or SHGFI.SYSICONINDEX
' 'Dim dwAttr1 As Integer = 0
' 'Dim resIP1 As IntPtr = SHGetFileInfo(xx, dwAttr1, shfi1, cbFileInfo, uFlags1)
' Dim ppshf As IShellFolder 'Desktop Folder
' Dim HR As Integer
' HR = ShellDll.SHGetDesktopFolder(ppshf)
' If HR = NOERROR Then
' Dim psf As IShellFolder 'History Folder
' HR = ppshf.BindToObject(xx, IntPtr.Zero, IID_IShellFolder, psf)
' Dim psfEnum As IEnumIDList
' HR = psf.EnumObjects(0, SHCONTF.INCLUDEHIDDEN Or SHCONTF.FOLDERS, psfEnum)
' Marshal.ReleaseComObject(ppshf)
' Dim item As IntPtr
' HR = psfEnum.GetNext(1, item, sz)
' 'ok, we now have a pidl relative to xx, see if we can concatenate with xx
' Dim itemAbsID As IntPtr
' itemAbsID = concatPidls(xx, item)
' 'with that, we should be able to get a SHFILEINFO
' Dim shfi As New SHFILEINFO()
' Dim uFlags As Integer = SHGFI.PIDL Or SHGFI.DISPLAYNAME Or SHGFI.TYPENAME
' uFlags = uFlags Or SHGFI.SYSICONINDEX
' Dim dwAttr As Integer = 0
' Dim resIP As IntPtr = SHGetFileInfo(itemAbsID, dwAttr, shfi, cbFileInfo, uFlags)
' lvi.Text = shfi.szDisplayName
' lvi.ImageIndex = shfi.iIcon
' aRet.Add(lvi)
' Dim lv2 As New ListViewItem("Not Set")
' Dim psfLv2 As IShellFolder
' HR = psf.BindToObject(item, IntPtr.Zero, IID_IShellFolder, psfLv2)
' Dim iEnum2 As IEnumIDList
' HR = psfLv2.EnumObjects(0, SHCONTF.INCLUDEHIDDEN Or SHCONTF.NONFOLDERS Or SHCONTF.FOLDERS, iEnum2)
' Dim item2 As IntPtr
' HR = iEnum2.GetNext(1, item2, sz)
' Dim item2AbsID As IntPtr
' item2AbsID = concatPidls(itemAbsID, item2)
' Dim shfi2 As New SHFILEINFO()
' resIP = SHGetFileInfo(item2AbsID, dwAttr, shfi2, cbFileInfo, uFlags)
' lv2.Text = shfi2.szDisplayName
' lv2.ImageIndex = shfi2.iIcon
' aRet.Add(lv2)
' Marshal.FreeCoTaskMem(item2)
' Marshal.FreeCoTaskMem(item2AbsID)
' Marshal.ReleaseComObject(iEnum2)
' Marshal.ReleaseComObject(psfLv2)
' Marshal.FreeCoTaskMem(item)
' Marshal.FreeCoTaskMem(itemAbsID)
' Marshal.ReleaseComObject(psfEnum)
' Marshal.ReleaseComObject(psf)
' End If
' Marshal.FreeCoTaskMem(xx)
' Return aRet
'End Function
#End Region
#End Region
#Region " Icomparable -- for default Sorting"
Private Function ComputeSortFlag() As Integer
Dim rVal As Integer = 0
If m_IsDisk Then rVal = &H100000
If m_TypeName.Equals("System Folder") Then
If Not m_IsBrowsable Then
rVal = rVal Or &H10000
Else
rVal = rVal Or &H1000
End If
End If
If m_IsFolder Then rVal = rVal Or &H100
Return rVal
End Function
'<Summary> CompareTo(obj as object)
' Compares obj to this instance -- obj must be as CShItem
'<SortOrder> (low)Disks,non-browsable System Folders,
' browsable System Folders,
' Directories, Files, Nothing (high)</SortOrder>
'</Summary>
Public Overridable Overloads Function CompareTo(ByVal obj As Object) As Integer _
Implements IComparable.CompareTo
If IsNothing(obj) Then Return 1 'non-existant is always low
Dim Other As CShItem = obj
'If m_IsDisk Then
' If Other.IsDisk Then
' Return String.Compare(m_Path, Other.Path)
' Else
' Return -1
' End If
'Else
' If Other.IsDisk Then Return 1
'End If
''Neither is a Disk
'If m_TypeName.Equals("System Folder") Then
' If Other.TypeName.Equals("System Folder") Then
' Return String.Compare(m_DisplayName, Other.DisplayName)
' Else
' Return -1
' End If
'Else
' If Other.TypeName.Equals("System Folder") Then Return 1
'End If
'If m_IsFolder Then
' If Other.IsFolder Then
' Return String.Compare(m_Path, Other.Path)
' Else
' Return -1
' End If
'Else
' If Other.IsFolder Then Return 1
'End If
Dim cmp As Integer = Other.SortFlag - m_SortFlag 'Note the reversal
If cmp <> 0 Then
Return cmp
Else
If m_IsDisk Then 'implies that both are
Return String.Compare(m_Path, Other.Path)
Else
Return String.Compare(m_DisplayName, Other.DisplayName)
End If
End If
End Function
#End Region
End Class
Submit an article or tip