Private Const MAX_PREFERRED_LENGTH As Long = -1
Private Const NERR_SUCCESS As Long = 0&
Private Const ERROR_MORE_DATA As Long = 234
Private Const FILTER_NORMAL_ACCOUNT  As Long = &H2
Private Const LB_SETTABSTOPS As Long = &H192

Private Const SV_TYPE_WORKSTATION As Long = &H1
Private Const SV_TYPE_SERVER As Long = &H2

Private Type SERVER_INFO_100
   sv100_platform_id As Long
   sv100_name As Long
End Type

Private Type USER_INFO_1
  usri1_name As Long
  usri1_password As Long
  usri1_password_age As Long
  usri1_priv As Long
  usri1_home_dir As Long
  usri1_comment As Long
  usri1_flags As Long
  usri1_script_path As Long
End Type

Private Declare Function NetServerEnum Lib "Netapi32" _
  (ByVal Servername As Long, _
   ByVal Level As Long, _
   buf As Any, _
   ByVal prefmaxlen As Long, _
   entriesread As Long, _
   totalentries As Long, _
   ByVal servertype As Long, _
   ByVal domain As Long, _
   resume_handle As Long) As Long

Private Declare Function NetUserEnum Lib "Netapi32" _
  (ByVal Servername As Long, _
   ByVal Level As Long, _
   ByVal Filter As Long, _
   bufptr As Long, _
   ByVal prefmaxlen As Long, _
   entriesread As Long, _
   totalentries As Long, _
   resumehandle As Long) As Long

Private Declare Function NetApiBufferFree Lib "Netapi32" _
   (ByVal Buffer As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (pTo As Any, uFrom As Any, _
   ByVal lSize As Long)
   
Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long

Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long



Private Sub Form_Load()

   With List1
      .Move 200, 600, 2000, 2300
   End With
   
   With List2
      .Move List1.Left + List1.Width + 100, 600, 4700, 2300
   End With
   
   Me.Width = List2.Left + List2.Width + 300
   Me.Height = List1.Top + List2.Height + 600
   
   With Label1
      .Caption = "Logged in machines"
      .Move 250, 300, 2000
      .WordWrap = True
      .AutoSize = True
   End With
   
   With Label2
      .Caption = "Users"
      .Move List2.Left + 50, 300, 2000
      .WordWrap = True
      .AutoSize = True
   End With
   
   With Label3
      .Caption = "Password Age"
      .Move List2.Left + 2060, 300, 2000
      .WordWrap = True
      .AutoSize = True
   End With
   
  'set up a tabstop in list2
   Dim TabStop(0 To 0) As Long
   TabStop(0) = 90
   Call SendMessage(List2.hwnd, LB_SETTABSTOPS, 0&, ByVal 0&)
   Call SendMessage(List2.hwnd, LB_SETTABSTOPS, 1, TabStop(0))
   
  'load the available machines
  '(both servers and workstations)
   Call GetServers

End Sub


Private Sub List1_Click()

   If List1.ListIndex > -1 Then
   
      With List2
         .Clear
         .AddItem "working ..."
         .Refresh
      End With
      
      GetUserEnumInfo List1.List(List1.ListIndex)
      
   End If
   
End Sub


Private Sub GetServers()

  'lists all servers of the specified type
  'that are visible in a domain

   Dim bufptr          As Long
   Dim dwEntriesread   As Long
   Dim dwTotalentries  As Long
   Dim dwResumehandle  As Long
   Dim se100           As SERVER_INFO_100
   Dim success         As Long
   Dim nStructSize     As Long
   Dim cnt             As Long

  'Call passing MAX_PREFERRED_LENGTH to have the
  'API allocate required memory for the return values.
  '
  'dwServerName must be Null. The level parameter
  '(100 here) specifies the data structure being
  'used (in this case a SERVER_INFO_100 structure).
  '
  'The domain member is passed as Null, indicating
  'machines on the primary domain are to be retrieved.
  'If you decide to use this member to specify a
  'specific domain, use or pass StrPtr("domain name"),
  'not the string itself.
   nStructSize = LenB(se100)
   
   success = NetServerEnum(0&, _
                           100, _
                           bufptr, _
                           MAX_PREFERRED_LENGTH, _
                           dwEntriesread, _
                           dwTotalentries, _
                           SV_TYPE_WORKSTATION Or SV_TYPE_SERVER, _
                           0&, _
                           dwResumehandle)

  'if all goes well
   If success = NERR_SUCCESS And _
      success <> ERROR_MORE_DATA Then

     'loop through the returned data, adding each
     'machine to the list
      For cnt = 0 To dwEntriesread - 1

        'get one chunk of data and cast
        'into an SERVER_INFO_100 type
        'in order to add the machine
        'name to the list
         CopyMemory se100, ByVal bufptr + (nStructSize * cnt), nStructSize
         List1.AddItem GetPointerToByteStringW(se100.sv100_name)

      Next

   End If

  'clean up, regardless of success
   Call NetApiBufferFree(bufptr)

End Sub


Private Sub GetUserEnumInfo(Optional sServer As String)

   Dim bufptr As Long
   Dim dwEntriesread As Long
   Dim dwTotalentries As Long
   Dim dwResumehandle As Long
   Dim success As Long
   Dim dwServer As Long
   Dim cnt As Long
   Dim nStructSize As Long
   Dim ui1 As USER_INFO_1

   sServer = QualifyServer(sServer)
   dwServer = StrPtr(sServer)
   
   success = NetUserEnum(dwServer, _
                         1, _
                         FILTER_NORMAL_ACCOUNT, _
                         bufptr, _
                         MAX_PREFERRED_LENGTH, _
                         dwEntriesread, _
                         dwTotalentries, _
                         dwResumehandle)
   
   List2.Clear
   
   If success = NERR_SUCCESS And _
      success <> ERROR_MORE_DATA Then
   
      nStructSize = LenB(ui1)
     
      For cnt = 0 To dwEntriesread - 1
         
         CopyMemory ui1, ByVal bufptr + (nStructSize * cnt), nStructSize

         List2.AddItem GetPointerToByteStringW(ui1.usri1_name) & _
                       vbTab & _
                       ConvertPwSeconds(ui1.usri1_password_age)
         
      Next
   
   End If
   
   NetApiBufferFree bufptr   
   
End Sub


Private Function ConvertPwSeconds(dwSeconds As Long) As String

   Dim buff As String

  'assume password has expired
   buff = "(password expired)"

   If dwSeconds > 0 Then
   
      Select Case dwSeconds
      
         Case Is >= 31449600:
            buff = FormatNumber(dwSeconds / 31449600, 2) & " years" & _
                  "  (" & FormatNumber(dwSeconds, 0) & " seconds)"

         Case Is >= 604800:
            buff = FormatNumber(dwSeconds / 604800, 2) & " weeks" & _
                  "  (" & FormatNumber(dwSeconds, 0) & " seconds)"
                  
         Case Is >= 86400:
            buff = FormatNumber(dwSeconds / 86400, 2) & " days" & _
                  "  (" & FormatNumber(dwSeconds, 0) & " seconds)"

         Case Is >= 3600:
            buff = FormatNumber(dwSeconds / 3600, 2) & " hours" & _
                  "  (" & FormatNumber(dwSeconds, 0) & " seconds)"

         Case Is >= 60:
            buff = FormatNumber(dwSeconds / 60, 2) & " minutes" & _
                  "  (" & FormatNumber(dwSeconds, 0) & " seconds)"

         Case Is < 60:
            buff = FormatNumber(dwSeconds, 2) & " seconds"
      
      End Select
      
   End If

   ConvertPwSeconds = buff

End Function


Private Function GetPointerToByteStringW(ByVal dwData As Long) As String

   Dim tmp() As Byte
   Dim tmplen As Long

   If dwData <> 0 Then
      tmplen = lstrlenW(dwData) * 2
      If tmplen <> 0 Then
         ReDim tmp(0 To (tmplen - 1)) As Byte
         CopyMemory tmp(0), ByVal dwData, tmplen
         GetPointerToByteStringW = tmp
     End If
   End If
    
End Function


Private Function QualifyServer(ByVal sServer As String) As String

  'see if there are already two slashes
  'preceeding the server name
   If Left$(sServer, 2) = "\\" Then
   
     'there are, so the server is already
     'qualified; return the passed string
      QualifyServer = sServer
   
   Else
   
     'there aren't two, but is there one?
      If Left$(sServer, 1) = "\" Then
      
        'yes, so add one more
         QualifyServer = "\" & sServer
      
      Else
      
        'the string needs both
         QualifyServer = "\\" & sServer
      
      End If  'If Left$(sServer, 1)
   End If  'If Left$(sServer, 2)
   
End Function