Hello SilviaLl
Your post is 2 times wrong in terms of "Language"
1. The programming language , as this is newgroup has a dotnet prefix it is
not a "classic" group i recomend for VB6
microsoft.public.vb.general.discussion as this group seems to be pretty
active
2. The language in nwich you ask your question newgroup without anny
language identifiers ( nl for dutch , it for italian , es for spanish
etc etc etc ) are so called international groups the comunication language
in these groups is the English language .
if i understand you correctly you need a way to detect the clients starting
your program on a terminal server written in VB6
this might help you as this code can retrieve the client session id
you might license your program for lets say 2 ,4 , 6 , 8 etc etc users if
your program detects more session id`s as it has valid licenses , you can
then display a message
***************** Code Start **************
' Portions of this code have been copied from many sources
' including msdn. You are free to use it in any application.
'
' Compiled, modified and tested by Tom Malia and Habib Salim 3/14/2006
' Returns a Terminal Server Session ID and the Computer Name of a Terminal
' Server Client computer. Also use to detect if Terminal Server is running
' on a machine.
'**************
Option Explicit
Const WTS_CURRENT_SERVER_HANDLE = 0&
Private Declare Function WTSEnumerateProcesses Lib "wtsapi32.dll" _
Alias "WTSEnumerateProcessesA" _
(ByVal hServer As Long, _
ByVal Reserved As Long, _
ByVal Version As Long, _
ByRef ppProcessInfo As Long, _
ByRef pCount 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, _
pBytesReturned 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 Function GetCurrentProcessId Lib "kernel32" _
() As Long
Private Type WTS_PROCESS_INFO
SessionId As Long
ProcessId As Long
pProcessName As Long
pUserSid As Long
End Type
Public Enum WTS_INFO_CLASS
WTSInitialProgram
WTSApplicationName
WTSWorkingDirectory
WTSOEMId
WTSSessionId
WTSUserName
WTSWinStationName
WTSDomainName
WTSConnectState
WTSClientBuildNumber
WTSClientName
WTSClientDirectory
WTSClientProductId
WTSClientHardwareId
WTSClientAddress
WTSClientDisplay
WTSClientProtocolType
End Enum
Function TerminalServerClientID() As String
'MAIN FUNCTION
'Purpose : Returns the name of the Client Machine logged into to TS
'Inputs : N/A
'Outputs : Returns "N/A" if not a terminal server,
' "Unknown/Err" if an error occured
' else returns Computer Name of the client machine
Dim lRetVal As Long
Dim lThisSessionId As Long
Dim lThisProcessId As Long
Dim sBuffer As String
Dim lp As Long
Dim sClientName As String
Dim p As Long
On Error GoTo ErrNotTerminalServer
'Set Default Value
TerminalServerClientID = ""
lThisSessionId = 0
sBuffer = String(100, vbNullChar)
'Get the session id for the current user; if session id = 0 this is not
a TS session
lThisSessionId = TerminalServerSessionId
If lThisSessionId Then
'query TS for client Name
lRetVal = WTSQuerySessionInformation(WTS_CURRENT_SERVER_HANDLE,
lThisSessionId, WTSClientName, p, lp)
If lRetVal Then
'The client name has been passed to the buffer - now get it
back
Debug.Print GetStringFromLP(p)
sClientName = GetStringFromLP(p)
'sClientName = GetStringFromLP(sBuffer)- this causes a type
mismatch
Debug.Print sClientName
TerminalServerClientID = sClientName
Else
TerminalServerClientID = "UNKNOWN/ERR"
End If
Else
'This is not a TS Session
TerminalServerClientID = "N/A"
End If
Exit Function
ErrNotTerminalServer:
Debug.Print Err.Number; Err.Description
TerminalServerClientID = "UNKNOWN/ERR"
End Function
Function TerminalServerSessionId() As String
'Purpose : Returns a terminal server session ID
'Inputs : N/A
'Outputs : Returns "0" if not a terminal server, else returns the
terminal server session ID.
Dim lRetVal As Long
Dim lCount As Long
Dim lThisProcess As Long
Dim lThisProcessId As Long
Dim lpBuffer As Long
Dim lp As Long
Dim udtProcessInfo As WTS_PROCESS_INFO
On Error GoTo ErrNotTerminalServer
'Set Default Value
TerminalServerSessionId = "0"
lThisProcessId = GetCurrentProcessId
lRetVal = WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0&, 1,
lpBuffer, lCount)
If lRetVal Then
'Successful
lp = lpBuffer
For lThisProcess = 1 To lCount
CopyMemory udtProcessInfo, ByVal lp, LenB(udtProcessInfo)
If lThisProcessId = udtProcessInfo.ProcessId Then
TerminalServerSessionId = CStr(udtProcessInfo.SessionId)
Exit For
End If
lp = lp + LenB(udtProcessInfo)
Next
'Free memory buffer
WTSFreeMemory lpBuffer
End If
Exit Function
ErrNotTerminalServer:
'The machine is not a Terminal Server
On Error GoTo 0
End Function
Private Function GetStringFromLP(ByVal StrPtr As Long) As String
Dim b As Byte
Dim tempStr As String
Dim bufferStr As String
Dim Done As Boolean
Done = False
Do
' Get the byte/character that StrPtr is pointing to.
CopyMemory b, ByVal StrPtr, 1
If b = 0 Then ' If you've found a null character, then you're done.
Done = True
Else
tempStr = Chr$(b) ' Get the character for the byte's value
bufferStr = bufferStr & tempStr 'Add it to the string
StrPtr = StrPtr + 1 ' Increment the pointer to next byte/char
End If
Loop Until Done
GetStringFromLP = bufferStr
End Function
hth
Michel
