frmNetwork.frm

 VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   5715
   ClientLeft      =   1650
   ClientTop       =   1545
   ClientWidth     =   6585
   LinkTopic       =   "Form1"
   ScaleHeight     =   5715
   ScaleWidth      =   6585
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'             Programmer:   BRIAN YULE
'             E-Mail:       AS1068@Hotmail.com
'             Date:         1/3/2000
'             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 constUserInfoLevel3      As Long = 3
Private Const TIMEQ_FOREVER            As Long = -1&
Private Const MAX_PATH                 As Long = 260&
Private Const DOMAIN_GROUP_RID_USERS   As Long = &H201&
Private Const USER_MAXSTORAGE_UNLIMITED   As Long = -1&
Private Const LocalGroupMembersInfo3   As Long = 3&
Private Const MAX_RESOURCES            As Long = 256
Private Const NOT_A_CONTAINER          As Long = -1
Private Const RESOURCE_GLOBALNET       As Long = &H2&
Private Const RESOURCETYPE_ANY         As Long = &H0&
Private Const RESOURCEUSAGE_ALL        As Long = &H0&
Private Const NO_ERROR                 As Long = 0&
Private Const RESOURCE_ENUM_ALL        As Long = &HFFFF
Private Const ERROR_BAD_PROVIDER = 1204&
Private Const WN_BAD_PROVIDER = ERROR_BAD_PROVIDER

Private Const RESOURCE_CONNECTED = &H1
Private Const RESOURCE_PrivateNET = &H2
Private Const RESOURCE_REMEMBERED = &H3

Private Const RESOURCEDISPLAYTYPE_DOMAIN = &H1
Private Const RESOURCEDISPLAYTYPE_FILE = &H4
Private Const RESOURCEDISPLAYTYPE_GENERIC = &H0
Private Const RESOURCEDISPLAYTYPE_GROUP = &H5
Private Const RESOURCEDISPLAYTYPE_SERVER = &H2
Private Const RESOURCEDISPLAYTYPE_SHARE = &H3
Private Const RESOURCETYPE_DISK = &H1
Private Const RESOURCETYPE_PRINT = &H2
Private Const RESOURCETYPE_UNKNOWN = &HFFFF
Private Const RESOURCEUSAGE_CONNECTABLE = &H1
Private Const RESOURCEUSAGE_CONTAINER = &H2
Private Const RESOURCEUSAGE_RESERVED = &H80000000

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 Const DateFormat As String = "dd/mm/yy hh:nn:ss"

Private Declare Function NetAPIBufferFree Lib "netapi32.dll" Alias "NetApiBufferFree" (ByVal Ptr As Long) As Long
Private Declare Function NetAPIBufferAllocate Lib "netapi32.dll" Alias "NetApiBufferAllocate" (ByVal ByteCount As Long, 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 StrToPtr Lib "kernel32" Alias "lstrcpyW" (ByVal Ptr As Long, Source As Byte) As Long
Private Declare Function StrLen Lib "kernel32" Alias "lstrlenW" (ByVal Ptr As Long) As Long
Private Declare Function NetUserEnum Lib "netapi32.dll" (ByRef servername As Byte, ByVal level As Long, ByVal lFilter As Long, ByRef buffer As Long, ByVal prefmaxlen As Long, ByRef entriesread As Long, ByRef totalentries As Long, ByRef ResumeHandle As Long) As Long
Private Declare Function WNetGetUser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength 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 WNetGetLastError Lib "mpr.dll" Alias "WNetGetLastErrorA" (lpError As Long, ByVal lpErrorBuf As String, ByVal nErrorBufSize As Long, ByVal lpNameBuf As String, ByVal nNameBufSize 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
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow 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 i%, 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 i%, 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

Project Homepage: