1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
| procedure tRDSession.tester ;
var
hserveur : handle;
booOk : boolean;
ppsession : PWTS_SESSION_INFO;
nbSession : dword;
indexSession : dword;
Session : WTS_SESSION_INFO;
strTemp : string;
begin
fnbICA := 0;
fnbRDP := 0;
fbooListenICA := false;
fbooListenRDP := false;
fbooServeurOK := false;
if strServeur ='' then exit;
hserveur := WTSOpenServerA(pchar(fstrServeur));
if hserveur = 0 then exit;
try
// c'est ici que cela ce fige
booOk := WTSEnumerateSessionsA(hserveur,0,1,ppsession,nbSession );
if booOk and (nbsession > 0 )then
begin
fbooServeurOK := true;
for indexSession := 0 to nbSession-1 do
begin
Session := PWTS_SESSION_INFO(integer(ppsession)+indexsession * sizeof(wts_session_info))^;
strTemp := lowercase(session.pWinStationName);
if pos('ica-tcp#',strtemp)<> 0 then inc(fnbICA ,1);
if pos('rdp-tcp#',strtemp)<> 0 then inc(fnbRDP ,1);
if strTemp = 'ica-tcp' then fbooListenICA := session.State = WTSListen;
if strTemp = 'rdp-tcp' then fbooListenRDP := session.State = WTSListen;
end;
WTSFreeMemory (ppsession );
end;
except
on e:exception do
fblog.add('Erreur : '+e.Message );
end;
WTSCloseServer(hserveur);
end; |
Partager