Тестирование полезных кодов и примеров

Option Explicit
 
Const MAX_PATH      As Long = 260&
 
Private Type ShellFolder_Info
    sIDL As String
    ObjName As String
    ObjPath As String
    isFolder As Boolean
End Type
 
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As Long, ByVal IBindCtx As Long, ppidl As Long, ByVal sfgaoIn As Long, psfgaoOut As Long) As Long
Private Declare Function SHGetDesktopFolder Lib "shell32.dll" (ISF As IShellFolder) As Long
Private Declare Function StrRetToStr Lib "shlwapi.dll" Alias "StrRetToStrA" (pstr As STRRET, ByVal pIDL As Long, ppsz As String) As Long
Private Declare Function SHBindToParent Lib "shell32.dll" (ByVal pIDL As Long, ByVal riid As Long, ppv As Any, ppidlLast As Any) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIDL As Long, ByVal pszPath As Any) As Long
Private Declare Function SHGetMalloc Lib "shell32" (ppMalloc As IMalloc) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (pDest As Any, ByVal dwLength As Long, ByVal bFill As Byte)
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function ILFree Lib "shell32" (ByVal pidlFree As Long) As Long
 
Dim SFInfo As ShellFolder_Info
 
Public Sub Test_PIDL()
 
    With SFInfo
        ' Яндекс.Диск
        .sIDL = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{19170A69-A883-40D5-AF97-F6DC41495F15}"
        
        GetShellFolderInfo SFInfo
        
        Debug.Print .ObjName; vbTab; .ObjPath; vbTab; "IsFolder="; .isFolder
    End With
      
End Sub
 
Public Sub GetShellFolderInfo(sfi As ShellFolder_Info)
    'in.  SFI.sIDL - путь к объекту пространства имен Shell, заданный как GUID
    'out. SFI.ObjName - имя объекта, как оно отображается для пользователя
    'out. SFI.folderPath - физический путь к объекту
    'out. SFI.isFolder - является ли объект каталогом ?
    Dim ISF        As IShellFolder
    Dim str        As STRRET
    Dim pIDL       As Long
    Dim pstr       As Long
    Dim lr         As Long
    Dim SFGAO_ret  As Long
 
    Const SFGAO_FOLDER As Long = &H20000000 ' является ли каталогом ?
 
    ' Создать Item ID List из строки и вернуть указатель на него
    ' SFGAO_ret -> возвращает сумму битов запрошенных для проверки атрибутов
    If SHParseDisplayName(StrPtr(sfi.sIDL), ByVal 0&, pIDL, SFGAO_FOLDER, SFGAO_ret) <> S_OK Then Exit Sub
    ' Получаем указатель на интерфейс IShellFolder корневого объекта - Desktop
    lr = SHGetDesktopFolder(ISF)
    ' Преобразуем IDL в имя, отображаемое по-умолчанию в Windows Explorer
    ISF.GetDisplayNameOf pIDL, ByVal 0&, str
    ' Структуру STRRET -> в строку
    sfi.ObjName = String$(MAX_PATH, Chr$(0))
    If StrRetToStr(str, pIDL, sfi.ObjName) = S_OK Then sfi.ObjName = Left$(sfi.ObjName, lstrlen(StrPtr(sfi.ObjName)))
    
    ' Проверяем, допускает ли объект перечисление (альтернативный вариант)
    'Dim attr As Long
    'attr = SFGAO_FOLDER
    'ISF.GetAttributesOf 1&, ppidl, attr
    'SFI.isFolder = (attr And SFGAO_FOLDER)
    
    sfi.isFolder = SFGAO_ret And SFGAO_FOLDER
    
    ' Пытаемся получить физический путь
    sfi.ObjPath = String$(MAX_PATH, Chr$(0&))
    If SHGetPathFromIDList(pIDL, sfi.ObjPath) <> 0 Then
        sfi.ObjPath = Left$(sfi.ObjPath, lstrlen(StrPtr(sfi.ObjPath)))
        ' Если получили нормальный путь -> на выход
        If StrComp(sfi.ObjPath, sfi.sIDL, 1) <> 0 Then
            Set ISF = Nothing
            ILFree pIDL
            Exit Sub
        Else    ' Если путь совпадает с переданным GUID (т.е. он не раскрылся)
            sfi.ObjPath = vbNullString
        End If
    End If
    
    ' Если ShellFolder виртуальная, она может не раскрыться в физический путь
    ' Попробуем получить путь через свойства одного из ее дочерних объектов
    If sfi.isFolder Then
        Dim IID_IShellFolder As GUID
    
        Dim ISFchild    As IShellFolder
        Dim IEnumIDL    As IEnumIDList
        Dim filePath    As String
        Dim pIDLcur     As Long
        Dim pIDLfull    As Long
        Dim pos         As Long
 
        IIDFromString StrPtr("{000214E6-0000-0000-C000-000000000046}"), IID_IShellFolder
        
        ' Подключимся интерфейсом IShellFolder к нашему каталогу
        If ISF.BindToObject(pIDL, 0&, IID_IShellFolder, ISFchild) = S_OK Then
        
            ' Получаем интерфейс IEnumIDList для перечисления дочерних объектов этого каталога
            If ISFchild.EnumObjects(0&, SHCONTF_FOLDERS Or SHCONTF_NONFOLDERS Or SHCONTF_INCLUDEHIDDEN, IEnumIDL) = S_OK Then
        
                ' получаем 1 любой дочерний объект
                If IEnumIDL.Next(1&, pIDLcur, 0&) = S_OK Then
                
                    ' строим полный путь к дочернему ID List
                    pIDLfull = CombinePIDLs(pIDL, pIDLcur)
                
                    If pIDLfull <> 0 Then
                
                        ' Получаем привычный путь файловой системы для дочернего объекта
                        filePath = String$(MAX_PATH, Chr$(0&))
                        
                        If SHGetPathFromIDList(pIDLfull, filePath) <> 0 Then
                            filePath = Left$(filePath, lstrlen(StrPtr(filePath)))
                        End If
                    
                        ' Урезаем до родительского каталога
                        If Len(filePath) <> 0 Then
                            pos = InStrRev(filePath, "\")
                            If pos <> 0 Then sfi.ObjPath = Left$(filePath, pos - 1)
                        End If
 
                        isMalloc.Free ByVal pIDLfull
                        ILFree pIDLcur
                    
                    End If
                
                End If
                
                Set IEnumIDL = Nothing
                
            End If
            
            Set ISFchild = Nothing
            
        End If
        
    End If
    
    Set ISF = Nothing
    ILFree pIDL
    
End Sub
 
' fFreePidl1, fFreePidl2 - очищать память, указанных IDL по завершению работы функции ?
Public Function CombinePIDLs(pidl1 As Long, _
                                                  pidl2 As Long, _
                                                  Optional fFreePidl1 As Boolean = False, _
                                                  Optional fFreePidl2 As Boolean = False) As Long
  Dim cb1 As Integer
  Dim cb2 As Integer
  Dim pidlNew As Long
 
  ' If pidl1 is non-zero...
  If pidl1 Then
    ' Get it's size
    cb1 = GetPIDLSize(pidl1)
    ' If pidl1 is valid (has a size), subtract the size of the zero terminator
    If cb1 Then cb1 = cb1 - 2
  End If
  
  ' If pidl2 is non-zero...
  If pidl2 Then
    ' Get it's size
    cb2 = GetPIDLSize(pidl2)
    ' If pidl2 is valid (has a size), subtract the size of the zero terminator
    If cb2 Then cb2 = cb2 - 2
  End If
 
  ' Create a new pidl sized to hold both pidl1, pidl2 and the zero terminator
  pidlNew = CreatePIDL(cb1 + cb2 + 2)
  If (pidlNew) Then
    
    ' If pidl1 is valid, put it's id list at the beginning of our new pidl
    If cb1 Then MoveMemory ByVal pidlNew, ByVal pidl1, cb1
    
    ' If pidl2 is valid, prepend it's id list to the end of the new pidl
    If cb2 Then MoveMemory ByVal pidlNew + cb1, ByVal pidl2, cb2
      
    ' Zero the terminating 2 bytes
    FillMemory ByVal pidlNew + cb1 + cb2, 2, 0
      
    ' Finally, free the pidls as specified
    If (pidl1 And fFreePidl1) Then isMalloc.Free ByVal pidl1
    If (pidl2 And fFreePidl2) Then isMalloc.Free ByVal pidl2
    
  End If
  
  CombinePIDLs = pidlNew
 
End Function
 
Public Function CreatePIDL(cb As Long) As Long
  Dim pIDL As Long
  pIDL = isMalloc.Alloc(cb)
  If pIDL Then
    FillMemory ByVal pIDL, cb, 0 ' initialize to zero, set by caller
    CreatePIDL = pIDL
  End If
End Function
 
Public Function isMalloc() As IMalloc
  Static im As IMalloc
  If (im Is Nothing) Then SHGetMalloc im
  Set isMalloc = im
End Function
 
Public Function GetPIDLSize(ByVal pIDL As Long) As Integer
  Dim cb As Integer
  ' Error handle in case we get a bad pidl and overflow cb.
  ' (most item IDs are roughly 20 bytes in size, and since an item ID represents
  ' a folder, a pidl can never exceed 260 folders, or 5200 bytes).
  On Error GoTo Out
  If pIDL Then
    Do While pIDL
      cb = cb + GetItemIDSize(pIDL)
      pIDL = GetNextItemID(pIDL)
    Loop
    ' Add 2 bytes for the zero terminating item ID
    GetPIDLSize = cb + 2
  End If
Out:
End Function
 
Public Function GetItemIDSize(ByVal pIDL As Long) As Integer
  ' If we try to access memory at address 0 (NULL), then it's bye-bye...
  If pIDL Then MoveMemory GetItemIDSize, ByVal pIDL, 2
End Function
 
Public Function GetNextItemID(ByVal pIDL As Long) As Long
  Dim cb As Integer   ' SHITEMID.cb, 2 bytes
  cb = GetItemIDSize(pIDL)
  ' Make sure it's not the zero value terminator.
  If cb Then GetNextItemID = pIDL + cb
End Function

Option Explicit
 
Private Sub Form_Load()
    Dim cc As New clsStringBuilder
    
    cc.Append "1234"
    cc.Append "12" & vbNullChar & "34"
    cc.Append "12" & vbNullChar & vbNullChar & "34"
    
    Debug.Print cc.ToString
    Debug.Print Len(cc.ToString)
    
    Set cc = Nothing
    End
End Sub