GFNetRes/GFNETRESmod.bas

Attribute VB_Name = "GFNETRESmod"
Option Explicit
'(c)2000‑2003 by Louis. Use this plug‑in function to get network resources available on local machine.
'The source of the original (confusing) code was at creation time www.ActiveVB.de.
'See also: http://www.mvps.org/vbnet/index.html?code/network/wnetenumresource.htm.
'
'THIS MODULE IS PLUG‑IN CODE, DO NOT CHANGE!
'
'NetworkGetNetworkResources
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE_LONG, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As NETRESOURCE_LONG, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'Network_GetNetworkDriveInfo
'Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
'NetworkGetLongPath
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
'NetworkLocalToRemoteName
Private Declare Function WNetGetUniversalName Lib "mpr" Alias "WNetGetUniversalNameA" (ByVal lpLocalPath As String, ByVal dwInfoLevel As Long, lpBuffer As Any, lpBufferSize As Long) As Long
'NetworkGetNetworkResources
Private Type NETRESOURCE_LONG
    dwScope As Long
    dwType As Long
    dwDisplayType As Long
    dwUsage As Long
    pLocalName As Long
    pRemoteName As Long
    pComment As Long
    pProvider As Long
End Type
'NetworkGetNetworkResources
Private Type NETRESOURCE_LONG_STRING
    dwScope As Long
    dwType As Long
    dwDisplayType As Long
    dwUsage As Long
    sLocalName As String
    sRemoteName As String
    sComment As String
    sProvider As String
End Type
'NetworkGetNetworkResources
Public Type NetworkGetNetworkResourcesResultStruct 'returned by interface sub
    ResultNumber As Integer
    Result_NetResourceTypeID() As Long
    Result_NetResourceLocalName() As String
    Result_NetResourceRemoteName() As String
    Result_NetResourceComment() As String
    Result_NetResourceProviderName() As String
End Type
'Network_GetNetworkDriveInfo
Public Type NetworkDriveInfoStruct
    DriveLocalName As String 'e.g. H:\
    DriveRemoteName As String 'e.g. \\SERVER\C\
End Type
'NetworkLocalToRemoteName
'typedef struct  _UNIVERSAL_NAME_INFOA {
'    LPSTR    lpUniversalName;
'}UNIVERSAL_NAME_INFOA, *LPUNIVERSAL_NAME_INFOA; [=>]
Private Type UNIVERSAL_NAME_INFO
    UniversalName As String
End Type
'NetworkGetNetworkResources
Private Const RESOURCE_CONNECTED As Long = &H1&
Private Const RESOURCE_GLOBALNET As Long = &H2&
Private Const RESOURCE_REMEMBERED As Long = &H3&
'NetworkGetNetworkResources
Private Const RESDTYPE_DIRECTORY& = &H9
Private Const RESDTYPE_DOMAIN& = &H1
Private Const RESDTYPE_FILE& = &H4
Private Const RESDTYPE_GENERIC& = &H0
Private Const RESDTYPE_GROUP& = &H5
Private Const RESDTYPE_NETWORK& = &H6
Private Const RESDTYPE_ROOT& = &H7
Private Const RESDTYPE_SERVER& = &H2
Private Const RESDTYPE_SHARE& = &H3
Private Const RESDTYPE_SHAREADMIN& = &H8
'NetworkGetNetworkResources
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCETYPE_PRINT As Long = &H2&
Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
'NetworkGetNetworkResources
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000
'NetworkGetNetworkResources
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
Private Const MAX_RESOURCES = 256
Private Const NOT_A_CONTAINER = (‑1)
'Network_GetNetworkDriveInfo
Private Const NERR_SUCCESS As Long = 0&
Private Const MAX_PREFERRED_LENGTH As Long = ‑1
'Private Const RESOURCETYPE_ANY = &H0
'Private Const RESOURCE_CONNECTED = &H1
'NetworkLocalToRemoteName
Private Const UNIVERSAL_NAME_INFO_LEVEL   As Long = &H1 'Winnetwk.h
Private Const REMOTE_NAME_INFO_LEVEL      As Long = &H2 'Winnetwk.h

'***
'NOTE:
'NetworkGetNetworkResource can be used to obtain 'general' network data, like name of the user groups, comments, etc.;
'Network_GetNetworkDriveInfo() should be used to obtain information about connected network drives.
'***

Public Function NetworkGetNetworkResources() As NetworkGetNetworkResourcesResultStruct
    'On Error Resume Next 'returns 'network resources', i.e. shared network drives, etc.
    Dim NetResourceHandle As Long
    Dim NetResourceNumberTotal As Long 'number of non‑null strings totally returned by WNetEnumResource()
    Dim NetResourceNumberTemp As Long 'number of non‑null strings currently returned by WNetEnumResource()
    Dim NetResourceVarTempLength As Long
    Dim NetResourceVarTemp(0 To MAX_RESOURCES) As NETRESOURCE_LONG
    Dim NetResourceNumber As Long
    Dim NetResourceArray() As NETRESOURCE_LONG_STRING
    Dim EnumStartUpFlag As Boolean
    Dim EnumReturnValue As Long
    Dim Temp1 As Long
    Dim Temp2 As Long
    'preset
    EnumStartUpFlag = True 'preset
    'reset
    NetworkGetNetworkResources.ResultNumber = 0 'reset
    'begin
    Do
        If EnumStartUpFlag = False Then 'no idea why the guy I stole the code from used such a flag!
            If Not (NetResourceArray(NetResourceNumber).dwUsage And RESOURCEUSAGE_CONTAINER) = 0 Then
                EnumReturnValue = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, NetResourceArray(NetResourceNumber), NetResourceHandle)
            Else
                EnumReturnValue = NOT_A_CONTAINER
                NetResourceHandle = 0 'reset (error)
            End If
            NetResourceNumber = NetResourceNumber + 1 'important: increase also in case of an error
        Else
            EnumStartUpFlag = False 'reset
            EnumReturnValue = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, NetResourceHandle)
        End If
        If EnumReturnValue = NO_ERROR Then 'verify
            NetResourceNumberTemp = RESOURCE_ENUM_ALL 'preset
            Do
                NetResourceVarTempLength = (UBound(NetResourceVarTemp) * Len(NetResourceVarTemp(0))) / 2
                EnumReturnValue = WNetEnumResource(NetResourceHandle, NetResourceNumberTemp, NetResourceVarTemp(0), NetResourceVarTempLength)
                If NetResourceNumberTemp > 0 Then 'verify
                    ReDim Preserve NetResourceArray(0 To NetResourceNumberTotal + NetResourceNumberTemp ‑ 1) As NETRESOURCE_LONG_STRING
                    For Temp1 = 0 To (NetResourceNumberTemp ‑ 1)
                        'copy memory into strings using memory addresses of NetResourceVarTemp()
                        NetResourceArray(NetResourceNumberTotal + Temp1).dwScope = NetResourceVarTemp(Temp1).dwScope
                        NetResourceArray(NetResourceNumberTotal + Temp1).dwType = NetResourceVarTemp(Temp1).dwType
                        NetResourceArray(NetResourceNumberTotal + Temp1).dwDisplayType = NetResourceVarTemp(Temp1).dwDisplayType
                        NetResourceArray(NetResourceNumberTotal + Temp1).dwUsage = NetResourceVarTemp(Temp1).dwUsage
                        If (NetResourceVarTemp(Temp1).pLocalName) Then
                            Temp2 = lstrlen(NetResourceVarTemp(Temp1).pLocalName)
                            NetResourceArray(NetResourceNumberTotal + Temp1).sLocalName = String$(Temp2, Chr$(0))
                            Call CopyMemory(ByVal NetResourceArray(NetResourceNumberTotal + Temp1).sLocalName, ByVal NetResourceVarTemp(Temp1).pLocalName, Temp2)
                        End If
                        If (NetResourceVarTemp(Temp1).pRemoteName) Then
                            Temp2 = lstrlen(NetResourceVarTemp(Temp1).pRemoteName)
                            NetResourceArray(NetResourceNumberTotal + Temp1).sRemoteName = String$(Temp2, Chr$(0))
                            Call CopyMemory(ByVal NetResourceArray(NetResourceNumberTotal + Temp1).sRemoteName, ByVal NetResourceVarTemp(Temp1).pRemoteName, Temp2)
                        End If
                        If (NetResourceVarTemp(Temp1).pComment) Then
                            Temp2 = lstrlen(NetResourceVarTemp(Temp1).pComment)
                            NetResourceArray(NetResourceNumberTotal + Temp1).sComment = String$(Temp2, Chr$(0))
                            Call CopyMemory(ByVal NetResourceArray(NetResourceNumberTotal + Temp1).sComment, ByVal NetResourceVarTemp(Temp1).pComment, Temp2)
                        End If
                        If (NetResourceVarTemp(Temp1).pProvider) Then
                            Temp2 = lstrlen(NetResourceVarTemp(Temp1).pProvider)
                            NetResourceArray(NetResourceNumberTotal + Temp1).sProvider = String$(Temp2, Chr$(0))
                            Call CopyMemory(ByVal NetResourceArray(NetResourceNumberTotal + Temp1).sProvider, ByVal NetResourceVarTemp(Temp1).pProvider, Temp2)
                        End If
                    Next Temp1
                End If
                NetResourceNumberTotal = NetResourceNumberTotal + NetResourceNumberTemp 'NetResourceNumberTotal ressource number
            Loop While EnumReturnValue = ERROR_MORE_DATA 'do not use 'Do While'
        End If
        If Not (NetResourceHandle = 0) Then 'verify
            EnumReturnValue = WNetCloseEnum(NetResourceHandle)
        End If
    Loop While NetResourceNumber < NetResourceNumberTotal 'do not use 'Do While'
    'transfer values
    For Temp1 = 1 To NetResourceNumber
        With NetworkGetNetworkResources
            .ResultNumber = Temp1
            ReDim Preserve .Result_NetResourceTypeID(1 To Temp1) As Long
            ReDim Preserve .Result_NetResourceComment(1 To Temp1) As String
            ReDim Preserve .Result_NetResourceLocalName(1 To Temp1) As String
            ReDim Preserve .Result_NetResourceRemoteName(1 To Temp1) As String
            ReDim Preserve .Result_NetResourceProviderName(1 To Temp1) As String
            .Result_NetResourceTypeID(Temp1) = NetResourceArray(Temp1 ‑ 1).dwDisplayType
            .Result_NetResourceComment(Temp1) = NetResourceArray(Temp1 ‑ 1).sComment
            .Result_NetResourceLocalName(Temp1) = NetResourceArray(Temp1 ‑ 1).sLocalName
            .Result_NetResourceRemoteName(Temp1) = NetResourceArray(Temp1 ‑ 1).sRemoteName
            .Result_NetResourceProviderName(Temp1) = NetResourceArray(Temp1 ‑ 1).sProvider
        End With
    Next Temp1
End Function

Public Function Network_GetNetworkDriveInfo(ByRef NetworkDriveInfoStructNumber As Integer, ByRef NetworkDriveInfoStructArray() As NetworkDriveInfoStruct) As Boolean 'stolen from http://www.mvps.org/vbnet/index.html?code/network/wnetenumresource.htm
    'on error resume next 'initializes passed array with local and remote name of all available network drives; returns True if the info for at least one drive was received, False if not
    Dim EnumHandle As Long
    Dim EnumBufferSize As Long
    Dim EnumLocalName As String
    Dim EnumRemoteName As String
    Dim EnumFor As Long
    Dim NETRESOURCE_LONGNumber As Long
    Dim NETRESOURCE_LONGArray() As NETRESOURCE_LONG
    Dim Temp As Long
    'reset
    NetworkDriveInfoStructNumber = 0 'reset
    ReDim NetworkDriveInfoStructArray(1 To 1) As NetworkDriveInfoStruct 'reset
    'begin
    Temp = WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0&, ByVal 0&, EnumHandle)
    If (Temp = NERR_SUCCESS) And (Not (EnumHandle = 0)) Then 'verify
        'size array passed to API function
        NETRESOURCE_LONGNumber = 1024
        ReDim NETRESOURCE_LONGArray(1 To NETRESOURCE_LONGNumber) As NETRESOURCE_LONG
        EnumBufferSize = NETRESOURCE_LONGNumber * Len(NETRESOURCE_LONGArray(1))
        'read buffer data
        Temp = WNetEnumResource(EnumHandle, NETRESOURCE_LONGNumber, NETRESOURCE_LONGArray(1), EnumBufferSize)
        'allocate buffer data
        If Temp = 0 Then 'verify
             For EnumFor = 1 To NETRESOURCE_LONGNumber
                '
                EnumLocalName = "" 'reset
                EnumRemoteName = "" 'reset
                '
                If (NETRESOURCE_LONGArray(EnumFor).pLocalName) Then
                    EnumLocalName = TrimNull(GetStrFromPtrA(NETRESOURCE_LONGArray(EnumFor).pLocalName))
                End If
                '
                If (NETRESOURCE_LONGArray(EnumFor).pRemoteName) Then
                    EnumRemoteName = TrimNull(GetStrFromPtrA(NETRESOURCE_LONGArray(EnumFor).pRemoteName))
                End If
                '
                NetworkDriveInfoStructNumber = NetworkDriveInfoStructNumber + 1
                ReDim Preserve NetworkDriveInfoStructArray(1 To NetworkDriveInfoStructNumber) As NetworkDriveInfoStruct
                NetworkDriveInfoStructArray(NetworkDriveInfoStructNumber).DriveLocalName = EnumLocalName
                NetworkDriveInfoStructArray(NetworkDriveInfoStructNumber).DriveRemoteName = EnumRemoteName
            Next EnumFor
        Else
            Network_GetNetworkDriveInfo = False 'error
            Exit Function
        End If
    End If
    Call WNetCloseEnum(EnumHandle)
    Network_GetNetworkDriveInfo = True 'ok
    Exit Function
End Function

Public Function NetworkGetLongPath(ByVal ShortPath As String) As String
    'on error resume next
    Dim ShortDriveName As String
    Dim ShortSubDirs As String
    Dim LongDriveName As String
    Dim LongDriveNameLength As Long
    Dim Tempstr$
    '
    'NOTE: given: a drive '\\SERVER\C\' is connected as Z:\.
    'NetworkGetLongPath("\\SERVER\C\") returns \\SERVER\C\,
    'NetworkGetLongPath("Z:\") returns \\SERVER\C\.
    'ShortPath can be a drive name, directory or a full path including a file name.
    '
    'NOTE: this function is to be used when copying a file.
    'If UCase$(NetworkGetLongPath(GetRootDir(CopySourceName))) = _
    '   UCase$(NetworkGetLongPath(GetRootDir(CopyTargetName))) Then
    '   MsgBox "Source and Target is equal !", vbOkOnly + vbExclamation
    'End If
    '
    'preset
    ShortDriveName = GetRootDir(ShortPath)
    ShortSubDirs = Right$(ShortPath, Len(ShortPath) ‑ Len(ShortDriveName))
    If Right$(ShortDriveName, 1) = "\" Then ShortDriveName = Left$(ShortDriveName, Len(ShortDriveName) ‑ 1)
    'NOTE: WNetGetConnection() requires ShortDriveName to be not backslash terminated.
    LongDriveNameLength = 260 'MAX_PATH
    LongDriveName = String$(LongDriveNameLength, Chr$(0))
    'begin
    If WNetGetConnection(ShortDriveName, LongDriveName, LongDriveNameLength) = 0 Then
        If InStr(1, LongDriveName, Chr$(0), vbBinaryCompare) > 0 Then
            Tempstr$ = Left$(LongDriveName, InStr(1, LongDriveName, Chr$(0), vbBinaryCompare) ‑ 1)
        Else
            Tempstr$ = LongDriveName
        End If
    Else 'API function failed, return value passed to function
        Tempstr$ = ShortDriveName
    End If
    'verify
    If Not (Right$(Tempstr$, 1) = "\") Then Tempstr$ = Tempstr$ + "\"
    NetworkGetLongPath = Tempstr$ + ShortSubDirs
End Function

Public Function NetworkGetShortPath(ByVal LongPath As String) As String
    'on error resume next 'don't call too often, slow!
    Dim LongDriveName As String
    Dim LongSubDirs As String
    Dim NetworkDriveInfoStructNumber As Integer
    Dim NetworkDriveInfoStructArray() As NetworkDriveInfoStruct
    Dim Temp As Long
    Dim Tempstr$
    '
    'NOTE: given: a drive '\\SERVER\C\' is connected as Z:\.
    'NetworkGetShortPath("Z:\") returns Z:\,
    'NetworkGetShortPath("\\SERVER\C\") returns Z:\.
    'LongPath can be a drive name, directory or a full path including a file name.
    'The returned root directory will be backslash‑terminated (like dirs always are).
    '
    'preset
    LongDriveName = GetRootDir(LongPath)
    LongSubDirs = Right$(LongPath, MAX(Len(LongPath) ‑ Len(LongDriveName), 0)) 'use MAX() as LongPath could be '\\SERVER\C' and LongDriveName '\\SERVER\C\'
    If Right$(LongDriveName, 1) = "\" Then LongDriveName = Left$(LongDriveName, Len(LongDriveName) ‑ 1)
    Tempstr$ = LongDriveName 'preset (if API function failed then return value passed to function)
    'begin
    Call Network_GetNetworkDriveInfo(NetworkDriveInfoStructNumber, NetworkDriveInfoStructArray())
    For Temp = 1 To NetworkDriveInfoStructNumber
        If Not (Right$(NetworkDriveInfoStructArray(Temp).DriveRemoteName, 1) = "\") Then NetworkDriveInfoStructArray(Temp).DriveRemoteName = NetworkDriveInfoStructArray(Temp).DriveRemoteName + "\" 'verify
        If UCase$(NetworkDriveInfoStructArray(Temp).DriveRemoteName) = _
            UCase$(LongDriveName + "\") Then
            Tempstr$ = NetworkDriveInfoStructArray(Temp).DriveLocalName
            Exit For
        End If
    Next Temp
    If Not (Right$(Tempstr$, 1) = "\") Then Tempstr$ = Tempstr$ + "\" 'verify
    NetworkGetShortPath = Tempstr$ + LongSubDirs
End Function

Public Function NetworkLocalToRemoteName(ByVal LocalName As String) As String
    'on error resume next 'returns 'universal name' or nothing ("")
    Dim UNIVERSAL_NAME_INFOVar As UNIVERSAL_NAME_INFO
    '
    'NOTE: converts any local to a remote name if possible
    '(also if passed stuff (drive [+ directory [+ file]] name) is not located
    'on a network drive, but shared in the network).
    '
    'begin
    UNIVERSAL_NAME_INFOVar.UniversalName = String$(1024, Chr$(0)) 'preset; exceeds MAX_PATH
    Debug.Print WNetGetUniversalName(LocalName + Chr$(0), UNIVERSAL_NAME_INFO_LEVEL, UNIVERSAL_NAME_INFOVar, Len(UNIVERSAL_NAME_INFOVar)) '= 0& Then
        NetworkLocalToRemoteName = TrimNull(UNIVERSAL_NAME_INFOVar.UniversalName) 'ok
        Exit Function
    'Else
    '    NetworkLocalToRemoteName = "" 'error
    '    Exit Function
    'End If
End Function

'***HELP FUNCTIONS***

Private Function GetRootDir(ByVal GetRootDirPath As String) As String
    'On Error Resume Next 'returns root dir of passed path, even if located on a network machine
    Dim GetRootDirLoop As Integer
    '
    'NOTE: v1.1, first backslash in GetRootDirPath is searched for,
    'not expected to be located at a fixed position.
    '
    'verify
    GetRootDirPath = Left$(GetRootDirPath, 32767)
    'begin
    If Not (Left$(GetRootDirPath, 2) = "\\") Then
        For GetRootDirLoop = 1 To Len(GetRootDirPath)
            If Mid$(GetRootDirPath, GetRootDirLoop, 1) = "\" Then Exit For
        Next GetRootDirLoop
        GetRootDir = Left$(GetRootDirPath, GetRootDirLoop) 'i.e. c:\
    Else
        GetRootDir = Chr$(0) 'preset (error)
        GetRootDirPath = GetRootDirPath + "\" 'add end sign (testing is not required, increase speed)
        For GetRootDirLoop = 3 To Len(GetRootDirPath)
            If Mid$(GetRootDirPath, GetRootDirLoop, 1) = "\" Then
                Select Case GetRootDir
                Case Chr$(0)
                    GetRootDir = ""
                Case ""
                    GetRootDir = Left$(GetRootDirPath, GetRootDirLoop) 'i.e. \\SERVER\C\
                    Exit For
                End Select
            End If
        Next GetRootDirLoop
        If GetRootDir = Chr$(0) Then GetRootDir = "" 'reset (error)
    End If
End Function

Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
    'on error resume next
    If Value1 < Value2 Then
        MAX = Value2
    Else
        MAX = Value1
    End If
End Function

Public Function GetStrFromPtrA(ByVal lpszA As Long) As String
    'on error resume next
   GetStrFromPtrA = String$(lstrlen(ByVal lpszA), 0)
   Call lstrcpy(ByVal GetStrFromPtrA, ByVal lpszA)
End Function

Private Function TrimNull(ByVal TrimString As String) As String
    'on error resume next
    Dim Temp As Integer
    Temp = InStr(TrimString, Chr$(0))
    If (Temp) Then
        TrimNull = Left$(TrimString, Temp ‑ 1)
    Else
        TrimNull = TrimString
    End If
End Function

'***END OF HELP FUNCTIONS***


[END OF FILE]