Connaître l'adresse ou le nom du poste physique

Private Enum WTS_INFO_CLASS
WTSInitialProgram '(String)
WTSApplicationName '(String)
WTSWorkingDirectory '(String)
WTSOEMId 'OEMID(:String)
WTSSessionId 'ID(ULONG)
WTSUserName '(String)
WTSWinStationName '(String)
WTSDomainName '(String)
WTSConnectState '(WTS_CONNECTSTATE_CLASS)
WTSClientBuildNumber '(USHORT)
WTSClientName '()(String)
WTSClientDirectory '(String)
WTSClientProductId '(USHORT)
WTSClientHardwareId '(USHORT)
WTSClientAddress '(WTS_CLIENT_ADDRESS)
WTSClientDisplay '(WTS_CLIENT_DISPLAY)
WTSClientProtocolType '()
End Enum

Private Const WTS_CURRENT_SERVER_HANDLE = 0& 'TerminalServer

'
Private Declare Function GetCurrentProcessId _
Lib "kernel32" () _
As Long

'
Private Declare Function ProcessIdToSessionId _
Lib "kernel32" _
(ByVal lProcessId As Long, _
ByRef lSessionId As Long) _
As Long

'
Private Declare Function WTSQuerySessionInformation _
Lib "wtsapi32.dll" Alias "WTSQuerySessionInformationA" _
(ByVal hServer As Long, _
ByVal SessionId As Long, _
ByVal WTSInfoClass As WTS_INFO_CLASS, _
ByRef ppBuffer As Long, _
ByRef pBytesReturned As Long) _
As Long

'
Private Declare Sub WTSFreeMemory _
Lib "wtsapi32.dll" _
(ByVal pMemory As Long)

'
Private Declare Function lstrcpyA Lib "kernel32" _
(ByVal RetVal As String, ByVal Ptr As Long) As Long

'
Private Declare Function lstrlenA _
Lib "kernel32" _
(ByVal Ptr As Any) _
As Long

'
Public Function GetWTSClientName() As String
Dim lProcId As Long 'ID
Dim lRet As Long '
Dim lMySessionId As Long '
Dim lpBuffer As Long '
Dim lBytes As Long '

'
lProcId = GetCurrentProcessId

'
lRet = ProcessIdToSessionId(lProcId, lMySessionId)
'
If lMySessionId = 0 Then
'GetWTSClientName = "<<Session introuvable>>"
Exit Function
End If

'
lRet = WTSQuerySessionInformation( _
WTS_CURRENT_SERVER_HANDLE, _
lMySessionId, _
WTS_INFO_CLASS.WTSClientName, _
lpBuffer, _
lBytes)
'
If lRet = 0 Then
GetWTSClientName = ""
Exit Function
End If

'
GetWTSClientName = String$(lstrlenA(ByVal lpBuffer), 0)
Call lstrcpyA(ByVal GetWTSClientName, ByVal lpBuffer)

'
If lpBuffer <> 0 Then
WTSFreeMemory lpBuffer
End If
End Function