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: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:
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: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:
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!
Mostrar Mensajes
