[pctechdr]

Λοιπόν εγώ θα αφήσω εδώ αυτόν τον κώδικα που επιστρέφει το όνομα και την διεύθυνση του Τοπικού υπολογιστή πίσω απο μία απομακρυσμένη σύνδεση να υπάρχει για τυχών ενδιαφερόμενους. Επίσης να πώ ότι δουλεύει και σε περιβάλλον Citrix (Windows 8 και μετά)

Private Const WTS_CURRENT_SERVER_HANDLE = 0&
Public Enum WTS_CONNECTSTATE_CLASS
WTSActive
WTSConnected
WTSConnectQuery
WTSShadow
WTSDisconnected
WTSIdle
WTSListen
WTSReset
WTSDown
WTSInit
End Enum
Public Type WTS_CLIENT_ADDRESS
ADDRESSFAMILY As Long
ADDRESS(20) As Byte
End Type

Public Type WTS_CLIENT_NAME
TNAME As String * 11
End Type

Public Type WTS_CLIENT_INFO
CINFO As String * 20
End Type

Public Enum WTSInfoClass
WTSInitialProgram
WTSApplicationName
WTSWorkingDirectory
WTSOEMID
WTSSessionId
WTSUserName
WTSWinStationName
WTSDomainName
WTSConnectState
WTSClientBuilderNumber
WTSClientName
WTSClientDirectory
WTSClientProductId
WTSClientHardwareId
WTSClientAddress
WTSClientDisplay
WTSClientProtocolType
End Enum

Public Type WTS_SESSION_QUERY
SessionId As Long
pWinStationName As Long
senum As WTSInfoClass
End Type

Private lngPID As Long
Private WTS_CURRENT_SESSION As Long
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
Private Declare Function GetCurrentProcessId Lib "Kernel32.dll" () As Long
Private Declare Function WFGetActiveProtocol Lib "wfapi.dll" (ByVal SessionId As Long) As Long
Private Declare Sub WTSFreeMemory Lib "wtsapi32.dll" (ByVal pMemory As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ProcessIdToSessionId Lib "Kernel32.dll" (ByVal lngPID As Long, ByRef lngSID 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, Count As Long
Dim p As Long, i As Integer
Dim lName As Long, sName As String
Dim WTSQueryInfo() As WTS_SESSION_QUERY
Dim WTSQueryName As WTS_CLIENT_NAME

RetVal = WTSQuerySessionInformation(WTS_CURRENT_SERVER_HAND LE, _
SessionId, WTSClientName, lpBuffer, Count)
If RetVal Then
' Prozedur erfolgreich

p = lpBuffer
CopyMemory WTSQueryName, ByVal p, Len(WTSQueryName)
' 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 = Trim$(WTSQueryName.TNAME)
End Function
Public Function GetClientIPAddress() As String
Dim RetVal As Long
Dim TmpAddress As WTS_CLIENT_ADDRESS
Dim ByteRet As Long
Dim lpBuffer As Long
Dim p As Long

' get the id of current process running
lngPID = GetCurrentProcessId

' get the session id in which this process is running
ProcessIdToSessionId lngPID, WTS_CURRENT_SESSION

' user the current server, session id to trap the other details
RetVal = WTSQuerySessionInformation(WTS_CURRENT_SERVER_HAND LE, WTS_CURRENT_SESSION, WTSClientAddress, lpBuffer, ByteRet)

If RetVal Then
' WTSQuerySessionInfo was successful.
p = lpBuffer
CopyMemory TmpAddress, ByVal p, ByteRet
' Free the memory buffer.
WTSFreeMemory lpBuffer
Else
GetClientIPAddress = ""
Err.Raise Err.Number, Err.Source, "Error with the wtsQuerySessionInfo command " & Err.LastDllError
End If
GetClientIPAddress = Trim(TmpAddress.ADDRESS(2) & "." & TmpAddress.ADDRESS(3) & "." & TmpAddress.ADDRESS(4) & "." & TmpAddress.ADDRESS(5))
End Function