Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WTSClientName As Long = 10
Private Const WTS_CURRENT_SERVER_HANDLE As Long = 0
Private Const WTS_CURRENT_SESSION As Long = -1
Private Declare Function WTSQuerySessionInformation Lib "wtsapi32" _
Alias "WTSQuerySessionInformationA" _
(ByVal hServer As Long, _
ByVal SessionID As Long, _
ByVal WTSInfoClass As Long, _
ppBuffer As Long, _
pBytesReturned As Long) 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
Private Sub Command1_Click()
Label1.Caption = "This Terminal Session is running on computer " & GetTSClientHostName()
End Sub
Private Function GetTSClientHostName() As String
Dim bufptr As Long
Dim dwBufLen As Long
If WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE, _
WTS_CURRENT_SESSION, _
WTSClientName, _
bufptr, _
dwBufLen) > 0 Then
GetTSClientHostName = GetStrFromPtrA(bufptr)
End If
End Function
Private Function GetStrFromPtrA(ByVal lpszA As Long) As String
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function |