Private Const MAX_PATH As Long = 260
Private Const ERROR_NOT_CONNECTED As Long = 2250&
Private Const ERROR_MORE_DATA As Long = 234
Private Const ERROR_NO_NETWORK As Long = 1222&
Private Const ERROR_EXTENDED_ERROR As Long = 1208&
Private Const ERROR_NO_NET_OR_BAD_PATH As Long = 1203&
Private Const DRIVE_REMOTE As Long = 4

Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
  
Private Declare Function GetDriveType Lib "kernel32" _
   Alias "GetDriveTypeA" _
  (ByVal lpRootPathName As String) As Long

Private Declare Function WNetGetConnection Lib "mpr.dll" _
   Alias "WNetGetConnectionA" _
  (ByVal lpszLocalName As String, _
   ByVal lpszRemoteName As String, _
   cbRemoteName As Long) As Long

Private Declare Function GetUserName Lib "advapi32" _
   Alias "GetUserNameA" _
  (ByVal lpBuffer As String, _
   nSize 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 lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long



Private Sub Form_Load()

   Dim dx As Long
   
   dx = TextWidth("User Name (network connection)")
   
  'load the remote drives
   LoadRemoteDrives List1
   
   With Text1
      .Move dx + 360, 240, 3000, 285
      .Text = ""
   End With

   With Text2
      .Move dx + 360, Text1.Top + Text1.Height + 90, 3000, 285
      .Text = ""
   End With
   
   With List1
      .Move dx + 360, Text2.Top + Text2.Height + 90, 3000, 840
      .Text = ""
   End With
   
   With Text3
      .Move dx + 360, List1.Top + List1.Height + 90, 3000, 285
      .Text = ""
   End With

   With Text4
      .Move dx + 360, Text3.Top + Text3.Height + 90, 3000, 285
      .Text = ""
   End With
   
   With Label1
      .AutoSize = True
      .Caption = "User Name (network connection)"
      .Move 240, Text1.Top + (Text1.Height - .Height) \ 2
   End With

   With Label2
      .AutoSize = True
      .Caption = "User Name (current thread)"
      .Move 240, Text2.Top + (Text2.Height - .Height) \ 2
   End With
      
   With Label3
      .AutoSize = True
      .Caption = "Available Mapped Drives (" & List1.ListCount & ")"
      .Move 240, List1.Top + (List1.Height - .Height) \ 2
   End With
      
   With Label4
      .AutoSize = True
      .Caption = "Share Name"
      .Move 240, Text3.Top + (Text3.Height - .Height) \ 2
   End With
   
   With Label5
      .AutoSize = True
      .Caption = "Share User"
      .Move 240, Text4.Top + (Text4.Height - .Height) \ 2
   End With
   

End Sub


Private Sub List1_Click()

   Dim sDrive As String
   
   If List1.ListIndex > -1 Then
   
      If Len(List1.List(List1.ListIndex)) > 2 Then
      
         sDrive = Left$(List1.List(List1.ListIndex), 2)
      
         Text1.Text = GetNetworkUserName()
         Text2.Text = GetThreadUserName()
         Text3.Text = GetNetResourceName(sDrive)
         Text4.Text = GetNetResourceUserName(sDrive)
         
      End If
   
   End If
   
End Sub
  
         
Private Function GetNetworkUserName() As String

  'Retrieves the current default user name,
  'or the user name used to establish a
  'network connection.
   Dim buff As String
   Dim nSize As Long
   
   buff = Space$(MAX_PATH)
   nSize = Len(buff)
   
  'get the user name of the current machine
  'logged on to network by passing vbNullString
  'as lpName
   If WNetGetUser(vbNullString, buff, nSize) = 0 Then
    
     'Call succeeded. This does not necessarily
     'mean however that the user has logged on
     'to the network, as WNetGetUser should
     'return the current user's Windows name
     'even if not logged on.
      GetNetworkUserName = TrimNull(buff)
        
    End If

End Function


Private Function GetThreadUserName() As String

  'Retrieves the user name of the current
  'thread. This is the name of the user
  'currently logged onto the system. If
  'the current thread is impersonating
  'another client, GetUserName returns
  'the user name of the client that the
  'thread is impersonating.
   Dim buff As String
   Dim nSize As Long
   
   buff = Space$(MAX_PATH)
   nSize = Len(buff)

   If GetUserName(buff, nSize) = 1 Then

      GetThreadUserName = TrimNull(buff)
      Exit Function

   End If

End Function


Private Function GetNetResourceName(sShare As String) As String

  'Returns the UNC name of share passed if
  'the user has logged on to a network.
  'The default return value is an empty string,
  'meaning either the share didn't exist or
  'there was no net connection.
   Dim buff As String
   Dim nSize As Long

   buff = Space$(MAX_PATH)
   nSize = Len(buff)
   
  'get name of resource associated with
  'the passed drive. Returns 0 on success,
  'or the error code
   If WNetGetConnection(sShare, buff, nSize) = 0 Then
    
      GetNetResourceName = TrimNull(buff)
    
   End If
   
End Function


Private Function GetNetResourceUserName(sShare As String) As String

  'If the user is logged on to the network, the 
  'full name of the user (machine/username) who 
  'created the share is returned.

  'The default return value is an empty string,
  'meaning either the share didn't exist or
  'there was no net connection.
   Dim buff As String
   Dim nSize As Long

   buff = Space$(MAX_PATH)
   nSize = Len(buff)
   
  'get the user name of the current machine
  'logged on to network by passing vbNullString
  'as lpName
   If WNetGetUser(sShare, buff, nSize) = 0 Then
    
     'user owning the share
      GetNetResourceUserName = TrimNull(buff)
      Exit Function
        
    End If

End Function


Private Sub LoadRemoteDrives(lst As ListBox)

   Dim lpBuffer As String
   Dim currDrive As String

  'get list of available drives
   lpBuffer = GetDriveString()

  'Separate the drive strings
  'and add to the list. StripNulls
  'will continually shorten the
  'string, looping until a single
  'remaining terminating null is
  'encountered.
   Do Until lpBuffer = vbNullChar
  
     'strip off one drive item
     'and if its type is DRIVE_REMOTE,
     'add it to the list
      currDrive = StripNulls(lpBuffer)
   
      If GetDriveType(currDrive) = DRIVE_REMOTE Then
         lst.AddItem currDrive
      End If
    
   Loop
  
End Sub


Private Function GetDriveString() As String

  'returns of available drives each
  'separated by a null
   Dim sBuffer As String
   
  'possible 26 drives, three characters
  'each plus separating null
   sBuffer = Space$(26 * 4)
  
   If GetLogicalDriveStrings(Len(sBuffer), sBuffer) <> 0 Then

     'trim string but do not
     'remove trailing null
      GetDriveString = Trim$(sBuffer)
      
   End If

End Function


Private Function StripNulls(startstr As String) As String

  'Take a string separated by vbnullchar
  'and split off 1 item, shortening the
  'string so next item is ready for removal.
   Dim pos As Long

   pos = InStr(startstr, vbNullChar)
  
   If pos Then
   
      StripNulls = Mid$(startstr, 1, pos - 1)
      startstr = Mid$(startstr, pos + 1, Len(startstr))
   
   End If

End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function