Option Explicit
 
Private Const NERR_SUCCESS As Long = 0&
Private Const MAX_PREFERRED_LENGTH As Long = -1
Private Const ERROR_MORE_DATA As Long = 234&
Private Const LB_SETTABSTOPS As Long = &H192
 
Private Type SESSION_INFO_502
    sesi502_cname As Long
    sesi502_username As Long
    sesi502_num_open As Long
    sesi502_time As Long
    sesi502_idle_time As Long
    sesi502_user_flags As Long
    sesi502_cltype_name As Long
    sesi502_transport As Long
End Type
 
Private Declare Function NetSessionEnum Lib "netapi32" _
   (ByVal servername As Long, _
    ByVal UncClientName As Long, _
    ByVal username As Long, _
    ByVal level As Long, _
    bufptr As Long, _
    ByVal prefmaxlen As Long, _
    entriesread As Long, _
    totalentries As Long, _
    resume_handle 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 Sub Command1_Click()
    If IsOnline("pro1", "schriever") Then
        MsgBox "schriever ist angemeldet an pro1", vbInformation
    Else
        MsgBox "schriever ist nicht angemeldet an pro1", vbInformation
    End If
End Sub
 
Private Function IsOnline(sServer As String, sUser As String) As Boolean
    Dim bufptr          As Long  'output
    Dim dwServer        As Long  'pointer to the server
    Dim dwEntriesread   As Long  'out
    Dim dwTotalentries  As Long  'out
    Dim dwResumehandle  As Long  'out
    Dim success         As Long
    Dim nStructSize     As Long
    Dim cnt             As Long
    Dim usrname         As String
    Dim bServer         As String
    Dim si502           As SESSION_INFO_502
 
    bServer = "\\" + sServer + vbNullString
    dwServer = StrPtr(bServer)
 
    success = NetSessionEnum(dwServer, _
                             0&, _
                             0&, _
                             502, _
                             bufptr, _
                             MAX_PREFERRED_LENGTH, _
                             dwEntriesread, _
                             dwTotalentries, _
                             dwResumehandle)
 
    If success = NERR_SUCCESS And success <> ERROR_MORE_DATA Then
        nStructSize = LenB(si502)
        For cnt = 0 To dwEntriesread - 1
            CopyMemory si502, ByVal bufptr + (nStructSize * cnt), nStructSize
            usrname = GetPointerToByteStringW(si502.sesi502_username)
            If Len(usrname) > 0 Then
                If UCase(usrname) = UCase(sUser) Then
                    IsOnline = True
                    Exit For
                End If
            End If
        Next
   End If
   Call NetApiBufferFree(bufptr)
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

Gru? Michi aus Hannover

1 + 1 = 3 f?r hinreichend gro?e 1