CodeItBetter Programming Another VB Programming Blog

'Network - How to get Network Information [current networks, domains, users, and user info] (for Windows NT/2000 only)
'This allows the user to display the current networks, domains, users, and user
'info. As written, all declarations and functions must be included within a 
'form, as opposed to a separate module or class. The code to display all the
'network information in the debug window.

'Notes:
'Only works on Windows NT.
'Takes a long time to query the server.
'So be patient and wait.
'You will have to change the form load to suit your-self

Option Explicit
' ---------------------------------------------
' General constants used
' ---------------------------------------------
Private Const MAX_RESOURCES As Long = 256
Private Const RESOURCE_GLOBALNET As Long = &H2&
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
 
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
 
Private Type JoinLong
    x As Long
    Dummy As Integer
End Type
 
Private Type JoinInt
    Bottom As Integer
    Top As Integer
    Dummy As Integer
End Type
 
Private Declare Function NetAPIBufferFree Lib "netapi32.dll" Alias "NetApiBufferFree" (ByVal Ptr As Long) As Long
Private Declare Function PtrToInt Lib "kernel32" Alias "lstrcpynW" (RetVal As Any, ByVal Ptr As Long, _
    ByVal nCharCount As Long) As Long
Private Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long
Private Declare Function StrLen Lib "kernel32" Alias "lstrlenW" (ByVal Ptr 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 Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
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
Private Declare Function NetGetDCName Lib "netapi32.dll" (ByRef servername As Byte, ByRef DomainName As Byte, _
    ByRef buffer As Long) As Long
Private Declare Function NetQueryDisplayInformation Lib "netapi32.dll" (ByRef servername As Byte, _
    ByVal level As Long, ByVal Index As Long, ByVal EntriesRequested As Long, ByVal PreferredMaximumLength As Long, _
    ByRef ReturnedEntryCount As Long, ByRef SortedBuffer As Long) As Long
Private Declare Function NetUserGetInfo Lib "NETAPI32" (ByRef servername As Byte, ByRef UserName As Byte, _
    ByVal level As Long, ByRef buffer As Long) As Long
 
Dim Users$(), typRootResourses() As NETRESOURCE, typDomainResourses() As NETRESOURCE
 
 
Public Function GetPDC(pdc As String) As Long
    Dim Result As Long, Server As String, domain As String
    Dim SNArray() As Byte
    Dim DArray() As Byte
    Dim DCNPtr As Long
    Dim StrArray(100) As Byte
    SNArray = Server & vbNullChar      ' Move to byte array
    DArray = domain & vbNullChar       ' Move to byte array
    Result = NetGetDCName(SNArray(0), DArray(0), DCNPtr)
    GetPDC = Result
    If Result = 0 Then
        Result = PtrToStr(StrArray(0), DCNPtr)
        pdc = Left(StrArray(), StrLen(DCNPtr))
    Else
        pdc = ""
    End If
    NetAPIBufferFree (DCNPtr)
End Function
 
Public Sub GetNetworks()
    Dim lngRtn&, lngEnumHwnd&, lngCount&, lngBufSize&
    lngEnumHwnd = 0&
    lngRtn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, lngEnumHwnd)
    lngCount = RESOURCE_ENUM_ALL
    ReDim typRootResourses(0 To MAX_RESOURCES) As NETRESOURCE
    lngBufSize = UBound(typRootResourses) * Len(typRootResourses(0))
    lngRtn = WNetEnumResource(lngEnumHwnd, lngCount, typRootResourses(0), lngBufSize)
    ReDim Preserve typRootResourses(0 To lngCount - 1) As NETRESOURCE
    Call WNetCloseEnum(lngEnumHwnd)
End Sub
 
Public Sub GetDomains(NetworkNo As Integer)
    Dim lngRtn&, lngEnumHwnd&, lngCount&, lngBufSize&
    lngEnumHwnd = 0&
    lngRtn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, typRootResourses(NetworkNo), _
        lngEnumHwnd)
    lngCount = RESOURCE_ENUM_ALL
    ReDim typDomainResourses(0 To MAX_RESOURCES) As NETRESOURCE
    lngBufSize = UBound(typDomainResourses) * Len(typDomainResourses(0))
    lngRtn = WNetEnumResource(lngEnumHwnd, lngCount, typDomainResourses(0), lngBufSize)
    ReDim Preserve typDomainResourses(0 To lngCount - 1) As NETRESOURCE
    Call WNetCloseEnum(lngEnumHwnd)
End Sub
 
Public Sub GetUsers(domain$)
    On Error Resume Next
    Dim SNArray() As Byte, level&, Index&, EntriesRequested&, _
        PreferredMaximumLength&, ReturnedEntryCount&, SortedBuffer&, _
        APIResult As Long, StrArray(500) As Byte, i&, TempPtr As JoinLong, _
        TempStr As JoinInt, data$(), Result&, Size%
    Let level = 1
    Let SNArray = domain & vbNullChar
    Let Index = 0
    Let EntriesRequested = 500
    Let PreferredMaximumLength = 6000
    Do
        DoEvents
        APIResult = NetQueryDisplayInformation(SNArray(0), level, Index, _
                                               EntriesRequested, PreferredMaximumLength, ReturnedEntryCount, _
                                               SortedBuffer)
        If ReturnedEntryCount = 0 Then Exit Do
        For i = 1 To ReturnedEntryCount
            Let Size = Size + 1
            APIResult = PtrToInt(TempStr.Bottom, SortedBuffer + (i - 1) * 24, 2)
            APIResult = PtrToInt(TempStr.Top, SortedBuffer + (i - 1) * 24 + 2, 2)
            LSet TempPtr = TempStr
            APIResult = PtrToStr(StrArray(0), TempPtr.x)
            ReDim Preserve Users$(1 To Size)
            Users(Size) = Left(StrArray, StrLen(TempPtr.x))
            APIResult = PtrToInt(TempStr.Bottom, SortedBuffer + (i - 1) * 24 + 20, 2)
            APIResult = PtrToInt(TempStr.Top, SortedBuffer + (i - 1) * 24 + 22, 2)
            LSet TempPtr = TempStr
            Index = TempPtr.x
            DoEvents
        Next i
        Result = NetAPIBufferFree(SortedBuffer)
    Loop Until APIResult = 0
End Sub
 
Public Sub GetUserInfo(User As String, UserName, Logged)
    On Error Resume Next
    Dim Result&, bufptr&, LOn As Long, LOff As Long
    Dim SNArray() As Byte, UNArray() As Byte, StrArray(500) As Byte
    Dim TempPtr As JoinLong, TempStr As JoinInt, x&, pdc$
    Let x = GetPDC(pdc)
    SNArray = pdc & vbNullChar
    UNArray = User & vbNullChar
    Result = NetUserGetInfo(SNArray(0), UNArray(0), 3, bufptr)
    DoEvents
    If Result = 0 Then
        Result = PtrToInt(TempStr.Bottom, bufptr + 36, 2)
        Result = PtrToInt(TempStr.Top, bufptr + 38, 2)
        LSet TempPtr = TempStr
        Result = PtrToStr(StrArray(0), TempPtr.x)
        UserName = Left(StrArray, StrLen(TempPtr.x))
        Result = PtrToInt(TempStr.Bottom, bufptr + 52, 2)
        Result = PtrToInt(TempStr.Top, bufptr + 54, 2)
        LSet TempPtr = TempStr
        LOn = TempPtr.x
        Result = PtrToInt(TempStr.Bottom, bufptr + 56, 2)
        Result = PtrToInt(TempStr.Top, bufptr + 58, 2)
        LSet TempPtr = TempStr
        LOff = TempPtr.x
        If LOn > LOff Then
            Logged = "On"
        Else
            Logged = "Off"
        End If
        Result = NetAPIBufferFree(bufptr)
    End If
End Sub
 
Private Sub Form_Load()
    Dim i As Integer, j As Long
 
    Dim x As Long
 
    Dim ans As String
    Dim UserName As String
    Dim Logged As String
 
    Dim pdc As String
 
    Call GetNetworks
    For i = 0 To UBound(typRootResourses)
        Let x = lstrlen(typRootResourses(i).lpRemoteName)
        Let ans = Space$(x)
        Let x = lstrcpy(ans, typRootResourses(i).lpRemoteName)
 
        ' Display ans
        Debug.Print ans
    Next i
    For i = 0 To UBound(typRootResourses)
        DoEvents
        Call GetDomains(i)
        For j = 0 To UBound(typDomainResourses)
            Let x = lstrlen(typDomainResourses(j).lpRemoteName)
            Let ans = Space$(x)
            Let x = lstrcpy(ans, typDomainResourses(j).lpRemoteName)
            Debug.Print ans
            ' Display ans
        Next j
        Call GetNetworks    ' Refresh list
    Next i
    Let x = GetPDC(pdc)
    'display pdc
    Debug.Print pdc
    Call GetUsers(pdc)
    For x = 1 To UBound(Users)
        DoEvents
        ' Display Users
        Call GetUserInfo(Users(x), UserName, Logged)
        ' Display User Info.
        Debug.Print "User: " & Users(x) & ","; UserName & ", Login Status = " & Logged
    Next x
End Sub