Devuelven un array con las subcarpetas de un servidor local.
OPCIÓN 1:
Código
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
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
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
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!