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.publi c.vb.general.di scussion 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_SER VER_HANDLE = 0&
Private Declare Function WTSEnumeratePro cesses Lib "wtsapi32.d ll" _
Alias "WTSEnumeratePr ocessesA" _
(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 WTSQuerySession Information Lib "wtsapi32.d ll" _
Alias "WTSQuerySessio nInformationA" _
(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.d ll" _
(ByVal pMemory As Long)
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMem ory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function GetCurrentProce ssId Lib "kernel32" _
() As Long
Private Type WTS_PROCESS_INF O
SessionId As Long
ProcessId As Long
pProcessName As Long
pUserSid As Long
End Type
Public Enum WTS_INFO_CLASS
WTSInitialProgr am
WTSApplicationN ame
WTSWorkingDirec tory
WTSOEMId
WTSSessionId
WTSUserName
WTSWinStationNa me
WTSDomainName
WTSConnectState
WTSClientBuildN umber
WTSClientName
WTSClientDirect ory
WTSClientProduc tId
WTSClientHardwa reId
WTSClientAddres s
WTSClientDispla y
WTSClientProtoc olType
End Enum
Function TerminalServerC lientID() 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 ErrNotTerminalS erver
'Set Default Value
TerminalServerC lientID = ""
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 = TerminalServerS essionId
If lThisSessionId Then
'query TS for client Name
lRetVal = WTSQuerySession Information(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
TerminalServerC lientID = sClientName
Else
TerminalServerC lientID = "UNKNOWN/ERR"
End If
Else
'This is not a TS Session
TerminalServerC lientID = "N/A"
End If
Exit Function
ErrNotTerminalS erver:
Debug.Print Err.Number; Err.Description
TerminalServerC lientID = "UNKNOWN/ERR"
End Function
Function TerminalServerS essionId() 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_INF O
On Error GoTo ErrNotTerminalS erver
'Set Default Value
TerminalServerS essionId = "0"
lThisProcessId = GetCurrentProce ssId
lRetVal = WTSEnumeratePro cesses(WTS_CURR ENT_SERVER_HAND LE, 0&, 1,
lpBuffer, lCount)
If lRetVal Then
'Successful
lp = lpBuffer
For lThisProcess = 1 To lCount
CopyMemory udtProcessInfo, ByVal lp, LenB(udtProcess Info)
If lThisProcessId = udtProcessInfo. ProcessId Then
TerminalServerS essionId = CStr(udtProcess Info.SessionId)
Exit For
End If
lp = lp + LenB(udtProcess Info)
Next
'Free memory buffer
WTSFreeMemory lpBuffer
End If
Exit Function
ErrNotTerminalS erver:
'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
"SilviaLl" <sllado@[NONECESARI]gmailDOTcomschr eef in bericht
news:uO******** ******@TK2MSFTN GP02.phx.gbl...
Hola buenos dias,
Estoy haciendo un programa en VB 6 que se ejecutara en remoto con Terminal
Server o con CITRIX. Pero tengo que hacer un control de licencias, pensava
en hacer un control por el ordenador que està visualizando el programa. És
posible saber la dirección MAC o el serial del disco duro de ordenador que
esta visualizando el programa? Alguien tiene alguna sugerencia para que
solo el ordenador que se ha licenciado lo pueda ver?
Se agradece cualquier sugerencia,
Saludos cordiales,
SilviaLl.
