Private Const WTS_CURRENT_SERVER_HANDLE As Long = 0&
 
Public Enum WTSInfoClass
    WTSInitialProgram
    WTSApplicationName
    WTSWorkingDirectory
    WTSOEMID
    WTSSessionId
    WTSUserName
    WTSWinStationName
    WTSDomainName
    WTSConnectState
    WTSClientBuilderNumber
    WTSClientName
    WTSClientDirectory
    WTSClientProductId
    WTSClientHardwareId
    WTSClientAddress
    WTSClientDisplay
    WTSClientProtocolType
End Enum
 
'WTS Sitzungsanfragen-Struktur
Public Type WTS_SESSION_QUERY
    SessionID As Long
    pWinStationName As Long
    senum As WTSInfoClass
End Type
 
'Funktionsdefinition API-Aufruf für Session-Daten auslesen
Private Declare Function WTSQuerySessionInformation Lib _
    "wtsapi32.dll" Alias "WTSQuerySessionInformationA" _
    (ByVal hServer As Long, ByVal SessionID As Long, _
    ByVal WTS_INFO_CLASS As WTSInfoClass, ByRef QSbuffer As Long, _
    ByRef pCount As Long) As Long
 
'Funktionsdefinition für API-Aufruf "Speicher freigeben"
Private Declare Sub WTSFreeMemory Lib "wtsapi32.dll" (ByVal pMemory As Long)
 
'String API's
Private Declare Function StrCopyA Lib "kernel32.dll" Alias "lstrcpyA" _
    (ByVal retval As String, ByVal Ptr As Long) As Long
 
Private Declare Function StrLenA Lib "kernel32.dll" Alias "lstrlenA" _
    (ByVal Ptr As Long) As Long
 
'Funktion für Auslesen des RDP-Hostnames
Public Function GetWTSQueryHost(ByVal SessionID As Long) As String
    Dim retval As Long, lpBuffer As Long
    Dim p As Long, Count As Long
    Dim lName As Long, sName As String
 
    'Remotesitzungsinformationen holen
    retval = WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE, _
        SessionID, WTSClientName, lpBuffer, Count)
 
    'Funktionsausschnitt
    ' Prozedur erfolgreich
    If retval Then
 
        'Stringlänge ermitteln
        lName = StrLenA(lpBuffer)
        If lName <> 0 Then
 
            'String initialisieren
            sName = String$(lName, 0)
 
            'String kopieren
            Call StrCopyA(sName, lpBuffer)
        End If
 
        ' Speicher wieder freigeben
        WTSFreeMemory lpBuffer
    Else
 
        'Prozedurfehler: Keine RDP, Keine DLL da oder sonstwas faul...
        MsgBox "Fehler beim Auslesen der RDP-Sitzungsdaten. Es konnten" & _
            "keine Informationen gewonnen werden. ", vbCritical, _
            "DLL-Zugriffsfehler " & Err.LastDllError
 
    End If
 
    'Returnwert
    GetWTSQueryHost = sName
End Function