Startseite / Tipps / VB 5/6-Tipp 0578: Angemeldete Benutzer auslesen

VB 5/6-Tipp 0578: Angemeldete Benutzer auslesen

 von Kai Liebenau

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

Private Sub Form_Load()
Label1 = "Servername ohne \\ eingeben und [ENTER] drücken"
Label2 = "Liste der angemeldeten Benutzer, die auch Service und Batch Anmeldungen sein können!!!"
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim x As Long
If Len(Text1) And KeyAscii = 13 Then
    LoggedOnUser "\\" & Text1
    List1.Clear
    For x = 0 To UBound(Users) - 1
        List1.AddItem Users(x).wkui1_logon_domain & "\" & Users(x).wkui1_username
    Next
End If
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------
Option Explicit

'API Deklarierungen
Private Declare Function NetWkstaUserEnum Lib "netapi32" _
            (ByVal ServerName 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.dll" (ByVal Ptr As Long) As Long

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

Private Declare Function StrLenW Lib "kernel32.dll" Alias "lstrlenW" (ByVal Ptr As Long) As Long

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
            (ByVal dwFlags As Long, _
            lpSource As Any, _
            ByVal dwMessageId As Long, _
            ByVal dwLanguageId As Long, _
            ByVal lpBuffer As String, _
            ByVal nSize As Long, _
            Arguments As Long) As Long

'Benutzerdefinierte Typen
Private Type WKSTA_USER_INFO_1
  wkui1_username As Long
  wkui1_logon_domain As Long
  wkui1_oth_domains As Long
  wkui1_logon_server As Long
End Type

Public Type WKSTA_USER_INFO_1_STR
  wkui1_username As String
  wkui1_logon_domain As String
  wkui1_oth_domains As String
  wkui1_logon_server As String
End Type

'Konstanten
Public Const MAX_PREFERRED_LENGTH As Long = -1
Public Const ERROR_SUCCESS As Long = 0&
Public Const ERROR_ACCESS_DENIED As Long = 5
Public Const ERROR_MORE_DATA As Long = 234
Public Const NERR_BASE As Long = 2100
Public Const NERR_GroupExists As Long = NERR_BASE + 123
Public Const NERR_GroupNotFound = 2220
Public Const NERR_UserNotFound = 2221
Public Const NERR_NotPrimary As Long = NERR_BASE + 126
Public Const NERR_UserExists As Long = NERR_BASE + 124
Public Const NERR_UserInGroup As Long = 1378
Public Const NERR_PasswordTooShort As Long = NERR_BASE + 145
Public Const NERR_InvalidComputer As Long = NERR_BASE + 251
Public Const NERR_SUCCESS As Long = 0&

'Variablen
Public Users() As WKSTA_USER_INFO_1_STR

Function LoggedOnUser(strServer As String) As Long
    
  Dim bufptr          As Long
  Dim dwServer        As Long
  Dim dwEntriesread   As Long
  Dim dwTotalentries  As Long
  Dim dwResumehandle  As Long
  Dim nStatus         As Long
  Dim nStructSize     As Long
  Dim cnt             As Long
  Dim bServer         As String
  Dim wui1            As WKSTA_USER_INFO_1
  
  'strServer muß mit "\\" beginnen
  'bServer = strServer & vbNullString
  dwServer = StrPtr(strServer)
  Do
    'PC Connecten und Liste der angemeldeten User abfragen
    'MAX_PREFERRED_LENGTH bewirkt das die NetApi32 den BufferSize
    'selber bestimmt und den Buffer Allociert
    'Dieser Aufruf erzwingt die Struktur Level 1, alternativ kann
    'auch Level 0 genutzt werden der nur den Benutzernamen ermittelt
    nStatus = NetWkstaUserEnum(dwServer, 1, bufptr, MAX_PREFERRED_LENGTH, _
      dwEntriesread, dwTotalentries, dwResumehandle)
    
    ReDim Users(dwTotalentries)
    
    'wieviel insgesamt
    If nStatus = NERR_SUCCESS Or nStatus = ERROR_MORE_DATA Then
      If dwEntriesread > 0 Then
        ' Länge ermitteln damit die richtige Anzahl Bytes aus dem Speicher kopiert wird
        nStructSize = LenB(wui1)
        For cnt = 0 To dwEntriesread - 1
          'Alle gelesenen User in die Struktur kopieren
           CopyMemory wui1, ByVal bufptr + (nStructSize * cnt), nStructSize
           'Alle Stringpointer als Strings in die neue Struktur kpoieren
           Users(cnt).wkui1_username = PtrStr(wui1.wkui1_username)
           Users(cnt).wkui1_logon_domain = PtrStr(wui1.wkui1_logon_domain)
           Users(cnt).wkui1_logon_server = PtrStr(wui1.wkui1_logon_server)
           Users(cnt).wkui1_oth_domains = PtrStr(wui1.wkui1_oth_domains)
        Next cnt
      End If
    Else
      'ist ein Fehler passiert dann den User davon informieren
      MsgBox "Fehler:" & vbCrLf & PrintMSG(nStatus), vbCritical, "Fehler"
      LoggedOnUser = nStatus
    End If
  Loop While nStatus = ERROR_MORE_DATA
  
  'Be a good Programmer and give the Memory free, dont leak!!!!
  NetApiBufferFree bufptr
End Function

Private Function PtrStr(lpString As Long) As String
  Dim buff() As Byte
  Dim nSize As Long
  
  'Pointer benutzen um Strings aus Speicher zu kopieren
  If lpString Then
    
    'its Unicode, so mult. by 2
    nSize = StrLenW(lpString) * 2
    If nSize Then
      ReDim buff(0 To (nSize - 1)) As Byte
      CopyMemory buff(0), ByVal lpString, nSize
      PtrStr = buff
    End If
  End If
End Function

Public Function PrintMSG(ErrNR As Long)
  Dim Message As String
  
  Message = Space(256)
  FormatMessage &H1000, ByVal 0&, ErrNR, 0&, Message, _
    Len(Message), ByVal 0&
  
  If InStr(Message, vbNullChar) Then
    Message = Left(Message, InStr(Message, vbNullChar) - 1)
  End If
  
  PrintMSG = Message
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 7 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.