[SRC] getShareSubFolders

[Psyke1]

Bueno, estos códigos los he sacado para un proyecto en curso.
Devuelven un array con las subcarpetas de un servidor local.

OPCIÓN 1:

Código (vb) [Seleccionar] Expandir


Option Explicit
'===========================================================================
' º Name        : GetSharedSubFolders
' º Author      : Psyke1
' º Mail        : vbpsyke1@mixmail.com
' º Explanation : Returns an array with the subfolders of a shared folder.
' º Date        : 26/11/12
' º Reference   : http://goo.gl/sgDVX
' º Greets      : LeandroA
' º Visit       :
'    * http://foro.h-sec.org
'    * http://infrangelux.sytes.net
'===========================================================================

Public Function getSharedSubFolders(ByVal sServer As String) As Collection
Dim oShell                  As Object
Dim oItem                   As Variant
   
   If PathIsNetworkPath(sServer) Then
      Set oShell = CreateObject("Shell.Application")
   
      If Not oShell.NameSpace(CVar(sServer)) Is Nothing Then
         Set getSharedSubFolders = New Collection
       
         For Each oItem In oShell.NameSpace(CVar(sServer)).Items
             getSharedSubFolders.Add oItem.Path
         Next oItem
      End If
   End If
End Function


Ejemplo de uso:

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
Dim vFolder                 As Variant
Dim cTmp                    As Collection

   Set cTmp = getSharedSubFolders("\\CARLOS-PC")
   If cTmp Is Nothing Then
       MsgBox "El servidor local no existe"
   Else
       For Each vFolder In cTmp
           Debug.Print vFolder
       Next
   End If
End Sub



OPCIÓN 2:

Código (vb) [Seleccionar] Expandir


Option Explicit
'===========================================================================
' º Name        : mGetSharedSubFolders.bas
' º Author      : Psyke1
' º Mail        : vbpsyke1@mixmail.com
' º Explanation : Returns an array with the subfolders of a shared folder.
' º Date        : 26/11/12
' º Visit       :
'    * http://foro.h-sec.org
'    * http://infrangelux.sytes.net
'===========================================================================

'Type
Private Type NETRESOURCE
 dwScope       As Long
 dwType        As Long
 dwDisplayType As Long
 dwUsage       As Long
 lpLocalName   As Long
 lpRemoteName  As Long
 lpComment     As Long
 lpProvider    As Long
End Type

'kernel32.dll
Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal pString As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32.dll" (ByVal lpString1 As String, ByVal pString As Long) As Long

'mpr.dll
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As NETRESOURCE, lphEnum As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As NETRESOURCE, lpBufferSize As Long) As Long

'shlwapi.dll
Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" Alias "PathIsNetworkPathA" (ByVal pszPath As String) As Long

'Consts
Private Const RESOURCE_GLOBALNET        As Long = &H2
Private Const RESOURCETYPE_DISK         As Long = &H1
Private Const MAX_RESOURCES             As Long = &H100

'Function
Public Function getShareSubFolders(ByVal sNameServer As String) As String()
Dim hEnum                               As Long
Dim lLen                                As Long
Dim lTotal                              As Long
Dim lpRName                             As Long
Dim sRet()                              As String
Dim tNet(0 To MAX_RESOURCES)            As NETRESOURCE

   If PathIsNetworkPath(sNameServer) Then
       lTotal = -1
       lLen = &H1000 '(UBound(tNet) * Len(tNet(0))) / 2
       
       tNet(0).lpRemoteName = StrPtr(StrConv(sNameServer, vbFromUnicode))
       
       If Not WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, tNet(0), hEnum) Then
           If Not WNetEnumResource(hEnum, lTotal, tNet(0), lLen) Then
               If lTotal > 0 Then
                   lTotal = lTotal - 1
                   ReDim sRet(0 To lTotal) As String
                   
                   For lLen = 0 To lTotal
                       lpRName = tNet(lLen).lpRemoteName
                       
                       sRet(lLen) = Space(lstrlenA(lpRName))
                       lstrcpyA sRet(lLen), lpRName
                   Next lLen
               End If
           End If
           
           WNetCloseEnum hEnum
       End If
   End If
   
   getShareSubFolders = sRet()
End Function

Ejemplo de uso:

Código (vb) [Seleccionar] Expandir

Private Sub Form_Load()
Dim vSubFolder                          As Variant
Dim sSF()                               As String

   sSF = getShareSubFolders("\\CARLOS-PC")

   If Not Not sSF Then

       For Each vSubFolder In sSF
           Debug.Print vSubFolder
       Next vSubFolder
   End If
   
   'fix NotNot hack :)
   Debug.Assert App.hInstance
End Sub

DoEvents!

[Danyfirex]

Gracias Psyke1 por el código esta muy bueno.
saludos

[Psyke1]

Me ha dado dolores de cabeza porque hay muy poca documentación.
La idea de la primera función fue de LeandroA... (tiene solución para todo)

DoEvents!