I have been writing a program that ideally will run on a server in the background without ever closing - therefore it is important that any memory leaks are non existent. My program involves retrieving live session information using the Windows Terminal Services API (wtsapi32.dll) and since the information must be live the function is being run every few seconds, I have found that calling the WTSEnumerateSessionsEx function has lead to a fairly sizable memory leak. It seems the call to WTSFreeMemoryEx as instructed in the MSDN documentation seems to have no impact yet I receive no error messages from either call.
To summarize: the problem is not in execution of WTSEnumerateSessionsEx since valid data is returned; the memory is simply not being freed and this leads to problems when left to run for extended periods of time.
Currently the short-term solution has been to restart the process when used memory exceeds a threshold however this doesn't seem to be a satisfactory solution and rectifying this leak would be most desirable.
The enumeration types have been taken directly from the Microsoft MSDN documentation.
Attached is the relevant source file.
unit WtsAPI32;
interface
uses Windows, Classes, Dialogs, SysUtils, StrUtils;
const
WTS_CURRENT_SERVER_HANDLE = 0;
type
WTS_CONNECTSTATE_CLASS = (WTSActive, WTSConnected, WTSConnectQuery,
WTSShadow, WTSDisconnected, WTSIdle, WTSListen, WTSReset, WTSDown,
WTSInit);
type
WTS_TYPE_CLASS = (WTSTypeProcessInfoLevel0, WTSTypeProcessInfoLevel1,
WTSTypeSessionInfoLevel1);
type
WTS_SESSION_INFO_1 = record
ExecEnvId: DWord;
State: WTS_CONNECTSTATE_CLASS;
SessionId: DWord;
pSessionName: LPtStr;
pHostName: LPtStr;
pUserName: LPtStr;
pDomainName: LPtStr;
pFarmName: LPtStr;
end;
type
TSessionInfoEx = record
ExecEnvId: DWord;
State: WTS_CONNECTSTATE_CLASS;
SessionId: DWord;
pSessionName: string;
pHostName: string;
pUserName: string;
pDomainName: string;
pFarmName: string;
end;
TSessions = array of TSessionInfoEx;
function FreeMemoryEx(WTSTypeClass: WTS_TYPE_CLASS; pMemory: Pointer;
NumberOfEntries: Integer): BOOL; stdcall;
external 'wtsapi32.dll' name 'WTSFreeMemoryExW';
function FreeMemory(pMemory: Pointer): DWord; stdcall;
external 'wtsapi32.dll' name 'WTSFreeMemory';
function EnumerateSessionsEx(hServer: THandle; var pLevel: DWord;
Filter: DWord; var ppSessionInfo: Pointer; var pCount: DWord): BOOL;
stdcall; external 'wtsapi32.dll' name 'WTSEnumerateSessionsExW';
function EnumerateSessions(var Sessions: TSessions): Boolean;
implementation
function EnumerateSessions(var Sessions: TSessions): Boolean;
type
TSessionInfoExArr = array[0..2000 div SizeOf(WTS_SESSION_INFO_1)] of WTS_SESSION_INFO_1;
var
ppSessionInfo: Pointer;
pCount: DWord;
hServer: THandle;
level: DWord;
i: Integer;
ErrCode: Integer;
Return: DWord;
begin
pCount := 0;
level := 1;
hServer := WTS_CURRENT_SERVER_HANDLE;
ppSessionInfo := NIL;
if not EnumerateSessionsEx(hServer, level, 0, ppSessionInfo, pCount) then
begin
ErrCode := GetLastError;
ShowMessage('Error in EnumerateSessionsEx - Code: ' + IntToStr(ErrCode)
+ ' Message: ' + SysErrorMessage(ErrCode));
en
else
begin
SetLength(Sessions, pCount);
for i := 0 to pCount - 1 do
begin
Sessions[i].ExecEnvId := TSessionInfoExArr(ppSessionInfo^)[i].ExecEnvId;
Sessions[i].State := TSessionInfoExArr(ppSessionInfo^)[i].State;
Sessions[i].SessionId := TSessionInfoExArr(ppSessionInfo^)[i].SessionId;
Sessions[i].pSessionName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pSessionName);
Sessions[i].pHostName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pHostName);
Sessions[i].pUserName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pUserName);
Sessions[i].pDomainName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pDomainName);
Sessions[i].pFarmName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pFarmName);
end;
if not FreeBufferEx(WTSTypeSessionInfoLevel1, ppSessionInfo, pCount);
begin
ErrCode := GetLastError;
ShowMessage('Error in EnumerateSessionsEx - Code: ' + IntToStr(ErrCode)
+ ' Message: ' + SysErrorMessage(ErrCode));
end;
ppSessionInfo := nil;
end;
end;
end.
Here's is a minimal SSCCE that demonstrates the issue. When this program executes, it exhausts available memory in short time.
program SO17839270;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
const
WTS_CURRENT_SERVER_HANDLE = 0;
type
WTS_TYPE_CLASS = (WTSTypeProcessInfoLevel0, WTSTypeProcessInfoLevel1,
WTSTypeSessionInfoLevel1);
function WTSEnumerateSessionsEx(hServer: THandle; var pLevel: DWORD;
Filter: DWORD; var ppSessionInfo: Pointer; var pCount: DWORD): BOOL; stdcall;
external 'wtsapi32.dll' name 'WTSEnumerateSessionsExW';
function WTSFreeMemoryEx(WTSTypeClass: WTS_TYPE_CLASS; pMemory: Pointer;
NumberOfEntries: Integer): BOOL; stdcall;
external 'wtsapi32.dll' name 'WTSFreeMemoryExW';
procedure EnumerateSessionsEx;
var
ppSessionInfo: Pointer;
pCount: DWORD;
level: DWORD;
begin
level := 1;
if not WTSEnumerateSessionsEx(WTS_CURRENT_SERVER_HANDLE, level, 0,
ppSessionInfo, pCount) then
RaiseLastOSError;
if not WTSFreeMemoryEx(WTSTypeSessionInfoLevel1, ppSessionInfo, pCount) then
RaiseLastOSError;
end;
begin
while True do
EnumerateSessionsEx;
end.
To summarise the comment trail, I think that there is a fault in the WTS library code, that afflicts the WTSEnumerateSessionsEx and WTSFreeMemoryEx functions. The SSCCE that I added to the question gives a pretty clear demonstration of that.
So, your options to work around the fault would appear to be:
Only call WTSEnumerateSessionsEx when you get notified that a session is created or destroyed. That would minimise the number of calls you make. You'd still be left with a leak, but I suspect that it would take a very long time before you encountered problems.
Switch to WTSEnumerateSessions and then call WTSQuerySessionInformation to obtain any extra information that you need. From my trials, WTSEnumerateSessions would appear not to be afflicted by the same problem as WTSEnumerateSessionsEx.
I created the same sample in MSVC:
#include <Windows.h>
#include <WtsApi32.h>
#pragma comment(lib, "wtsapi32")
int _tmain(int argc, _TCHAR* argv[])
{
DWORD Level = 1;
PWTS_SESSION_INFO_1 pSessionInfo;
DWORD Count = 0;
BOOL bRes;
while (WTSEnumerateSessionsEx(WTS_CURRENT_SERVER_HANDLE, &Level, 0, &pSessionInfo, &Count))
{
if (!WTSFreeMemoryEx(WTSTypeSessionInfoLevel1, pSessionInfo, Count))
{
break;
}
}
return 0;
}
I am observing the same behaviour in Task Manager and even though Task Manager is not a tool to track memory leaks this behaviour is clearly a leak and it seems like a bug.
It happens both in x86 and x64 build (x64 uses the x64 version of WtsApi32.dll).
When you have finished using the array, free it by calling the WTSFreeMemoryEx function. You should also set the pointer to NULL.
(C) https://learn.microsoft.com/en-us/windows/desktop/api/wtsapi32/nf-wtsapi32-wtsenumeratesessionsexa
Related
I have some code which uses EnumFontFamiliesEX to determine whether a particular font (using its "facename") is installed. The code was working fine in 32-bit. When I compile and run it as 64-bit, it kept throwing an exception in the callback routine.
I have now gotten it to work under both BUT only if instead of passing the function FindFontbyFaceName's result as the 4th parameter to EnumFontFamiliesEX, I pass a local (or global) variable - MYresult in this case. (And then set result from it). I don't understand what is going on? Can anyone explain or point me to a better way. (I'm not so much interested in the mechanics of the fonts, as the basic callback mechanics).
// single font find callback
function FindFontFace( {$IFDEF CPUX86} lpelf: PLogFont; {$ENDIF}
{$IFDEF CPUX64} lpelf: PEnumLogFontEx; {$ENDIF}
lpntm: PNewTextMetricEx;
AFontType: DWORD; var Aresult: lparam): integer ; stdcall;
begin
result := 0; // 1 shot only please - not interested in any variations in style etc
if (lpelf <> nil) then
Aresult := -1 // TRUE
else
Aresult := 0;
end;
function FindFontbyFaceName(ACanvas: TCanvas; const AFacename: string): boolean;
var
lf: TLogFont;
Myresult: boolean;
begin
MYresult := false;
FillChar(lf, SizeOf(lf), 0);
StrLCopy(lf.lfFaceName, PChar(AFacename), 32);
lf.lfCharSet := DEFAULT_CHARSET;
// this works in both 32 and 64 bit
EnumFontFamiliesEX(ACanvas.Handle, lf, #FindFontFace, lparam(#MYresult), 0);
result := MYresult;
// this works in 32 bit but throws exception in callback in 64 bit
// EnumFontFamiliesEX(ACanvas.Handle, lf, #FindFontFace, lparam(#result), 0);
end;
function FindFont(const AFacename: string): boolean;
var
AImage: TImage;
begin
AImage := Timage.Create(nil);
try
result := FindFontbyFaceName(AImage.Canvas, Afacename);
finally
Aimage.Free;
end;
end;
Your callback function is not declared correctly. You are declaring the last parameter as a var LPARAM, which is wrong. The lParam parameter is passed by value, not by reference. When calling EnumFontFamiliesEx() you are passing a pointer to a Boolean as the lParam value.
Your callback is trying to write sizeof(LPARAM) number of bytes to a memory address that only has SizeOf(Boolean) bytes available (and why are you trying to write a -1 to a Boolean?). So you are overwriting memory. When using a pointer to a local variable as the lParam, you are likely just overwriting memory on the calling function's call stack that does not really matter, so you don't see a crash.
You need to either:
remove the var and typecast the lParam parameter to a PBoolean:
function FindFontFace( lpelf: PLogFont;
lpntm: PTextMetric;
FontType: DWORD;
lParam: LPARAM): Integer ; stdcall;
begin
PBoolean(lParam)^ := True;
Result := 0; // 1 shot only please - not interested in any variations in style etc
end;
Or:
function FindFontFace( lpelf: PLogFont;
lpntm: PTextMetric;
FontType: DWORD;
lParam: PBoolean): Integer ; stdcall;
begin
lParam^ := True;
Result := 0; // 1 shot only please - not interested in any variations in style etc
end;
leave the var but change the parameter type to Boolean instead of LPARAM:
function FindFontFace( var lpelf: TLogFont;
var lpntm: TTextMetric;
FontType: DWORD;
var lParam: Boolean): Integer ; stdcall;
begin
lParam := True;
Result := 0; // 1 shot only please - not interested in any variations in style etc
end;
Either approach will allow you to pass #Result as the lParam to EnumFontFamiliesEx() in both 32bit and 64bit:
function FindFontbyFaceName(ACanvas: TCanvas; const AFacename: string): Boolean;
var
lf: TLogFont;
begin
Result := False;
FillChar(lf, SizeOf(lf), 0);
StrLCopy(lf.lfFaceName, PChar(AFacename), 32);
lf.lfCharSet := DEFAULT_CHARSET;
EnumFontFamiliesEX(ACanvas.Handle, lf, #FindFontFace, LPARAM(#Result), 0);
end;
On a side note, creating a TImage just to have a canvas to enumerate with is wasteful. You don't need it at all:
function FindFontFace( lpelf: PLogFont;
lpntm: PTextMetric;
FontType: DWORD;
lParam: LPARAM): integer ; stdcall;
begin
PBoolean(lParam)^ := True;
Result := 0; // 1 shot only please - not interested in any variations in style etc
end;
function FindFont(const AFacename: string): Boolean;
var
lf: TLogFont;
DC: HDC;
begin
Result := False;
FillChar(lf, SizeOf(lf), 0);
StrLCopy(lf.lfFaceName, PChar(AFacename), 32);
lf.lfCharSet := DEFAULT_CHARSET;
DC := GetDC(0);
EnumFontFamiliesEx(DC, lf, #FindFontFace, LPARAM(#Result), 0);
ReleaseDC(0, DC);
end;
That being said, you can simplify the code if you use the TScreen.Fonts property instead of calling EnumFontFamiliesEx() directly:
function FindFont(const AFacename: string): Boolean;
begin
Result := (Screen.Fonts.IndexOf(AFacename) <> -1);
end;
Guys I got a source from a friend that is suppose to help me learn RE a lot but I got error
Error:identifier not found "TResourceStream"
"Bool"
"TMemoryStream"
"TResourceInfo"
"try"
And
Fatal: Syntax error, ";" expected but " identifier MS" found
Please help I need to compile this.
Excuse me please I know nothing yet, about programming.
Here is the source
function EnumResourceNames(hModule: HMODULE; // EXE handle returned from LoadLibrary/Ex
lpType: PChar; // resource type (eg: RT_RCDATA)
lpEnumFunc: ENUMRESNAMEPROC; // callback function address
lParam: Integer // long integer (eg: pointer to an object)
): BOOL; stdcall;
function CB_EnumDfmNameProc(hModule: THandle; lpszType, lpszName: PChar;
lParam: Integer): Boolean; stdcall;
var
ms: TMemoryStream;
rs: TResourceStream;
Buffer: array of Byte;
begin
with TResourceInfo(lParam) do
begin
rs := TResourceStream.Create(TResourceInfo(lParam).Module,
lpszname, lpszType); // load resource in memory
try
ms := TMemoryStream.Create;
try
try
SetLength(Buffer, 4);
rs.Read(Buffer[0], SizeOf(Buffer)); // read the first 4 bytes
if string(Buffer) = 'TPF0' then // is it a DFM resource?
begin
rs.Seek(0, 0);
ObjectBinaryToText(rs, ms); // decode DFM
ms.Seek(0, 0);
AddDfm(StrPas(lpszName), ms); // add it to our own list
end;
except
raise;
end;
finally
ms.Free;
end;
finally
rs.free;
end;
end;
Result := True;
end;
procedure TResourceInfo.EnumDfmNames;
begin
if FModule > 0 then // if an EXE file has been loaded
EnumResourceNames(FModule, RT_RCDATA, // go and search RCDATA resources
#CB_EnumDfmNameProc, Integer(Self));
end;
I need to get the volume serial number for a drive letter during an installation created with Inno Setup. I know that DLL functions can be imported into Inno, but I'm fairly new to it and having some problems getting it to work. I know that the GetVolumeInformation function in kernel32 can do what I need. Could someone show me how to import and use that functionality in an Inno script to retrieve the volume serial number?
Thanks!
Inno-Setup code::
[Code]
function GetVolumeInformation(
lpRootPathName: PChar;
lpVolumeNameBuffer: PChar;
nVolumeNameSize: DWORD;
var lpVolumeSerialNumber: DWORD;
var lpMaximumComponentLength: DWORD;
var lpFileSystemFlags: DWORD;
lpFileSystemNameBuffer: PChar;
nFileSystemNameSize: DWORD
): BOOL;
external 'GetVolumeInformationA#kernel32.dll stdcall';
function LoWord(dw: DWORD): WORD;
begin
Result := WORD(dw);
end;
function HiWord(dw: DWORD): WORD;
begin
Result := WORD((dw shr 16) and $FFFF);
end;
function WordToHex(w: WORD): string;
begin
Result := Format('%.4x', [w]);
end;
function FindVolumeSerial(const Drive: string): string;
var
FileSystemFlags: DWORD;
VolumeSerialNumber: DWORD;
MaximumComponentLength: DWORD;
begin
Result := '';
// Note on passing PChars using RemObjects Pascal Script:
// '' pass a nil PChar
// #0 pass an empty PChar
if GetVolumeInformation(
PChar(Drive),
'', // nil
0,
VolumeSerialNumber,
MaximumComponentLength,
FileSystemFlags,
'', // nil
0)
then
Result := WordToHex(HiWord(VolumeSerialNumber)) + '-' + WordToHex(LoWord(VolumeSerialNumber));
end;
function InitializeSetup(): Boolean;
begin
MsgBox(FindVolumeSerial('c:\'), mbInformation, mb_Ok);
end;
Tested with Inno-setup version 5.2.3
In Unicode versions of Inno-Setup replace PChar with PAnsiChar
Since the InnoSetup doesn't support pointers you will have to create the external library for the call of the GetVolumeInformation function. The following code samples should work for all combinations of the Delphi and InnoSetup (from the Unicode support point of view).
Here's the Delphi library code:
library VolumeInformation;
uses
Types, Classes, SysUtils, Windows;
var
SerialNumber: AnsiString;
function GetVolumeSerial(Drive: PAnsiChar): PAnsiChar; stdcall;
var
FileSystemFlags: DWORD;
VolumeSerialNumber: DWORD;
MaximumComponentLength: DWORD;
begin
SerialNumber := '';
GetVolumeInformationA(Drive, nil, 0, #VolumeSerialNumber,
MaximumComponentLength, FileSystemFlags, nil, 0);
SerialNumber := IntToHex(HiWord(VolumeSerialNumber), 4) + ' - ' +
IntToHex(LoWord(VolumeSerialNumber), 4);
Result := PAnsiChar(SerialNumber);
end;
exports
GetVolumeSerial;
end.
And here's the InnoSetup code:
[Files]
Source: "VolumeInformation.dll"; Flags: dontcopy
[Code]
function GetVolumeSerial(Drive: PAnsiChar): PAnsiChar;
external 'GetVolumeSerial#files:VolumeInformation.dll stdcall setuponly';
procedure ButtonOnClick(Sender: TObject);
var
S: string;
begin
S := GetVolumeSerial('c:\');
MsgBox(S, mbInformation, mb_Ok);
end;
The information on the version Exe-file I receive by means of VerQueryValue. Is there an inverse function (WinApi or Delphi) which can register (establish or change) such information?
Here, for example, there is a program which is able to do so. How may it work (http://www.angusj.com/resourcehacker)?
The version information is stored via resources; to edit that you simply need to edit that resource. Here is a unit I found that can clone an existing file version information and attach it to another file. It's very easy to do what you want starting from this code (it's coded by a friend of mine and is available public):
unit cloneinfo;
interface
uses Windows, SysUtils;
type
LANGANDCODEPAGE = record
wLanguage: Word;
wCodePage: Word;
end;
procedure clone(sFile,output:string);
implementation
procedure clone(sFile,output:string);
var
dwHandle, cbTranslate: cardinal;
sizeVers: DWord;
lpData, langData: Pointer;
lpTranslate: ^LANGANDCODEPAGE;
hRes : THandle;
begin
sizeVers := GetFileVersionInfoSize(PChar(sFile), dwHandle);
If sizeVers = 0 then
exit;
GetMem(lpData, sizeVers);
try
ZeroMemory(lpData, sizeVers);
GetFileVersionInfo (PChar(sFile), 0, sizeVers, lpData);
If not VerQueryValue (lpData, '\VarFileInfo\Translation', langData, cbTranslate) then
exit;
hRes := BeginUpdateResource(pchar(output), FALSE);
//For i := 0 to (cbTranslate div sizeof(LANGANDCODEPAGE)) do
//begin
lpTranslate := Pointer(Integer(langData) + sizeof(LANGANDCODEPAGE));
UpdateResource(hRes, RT_VERSION, MAKEINTRESOURCE(VS_VERSION_INFO), lpTranslate^.wLanguage,lpData, sizeVers);
//end;
EndUpdateResource(hRes, FALSE);
finally
FreeMem(lpData);
end;
end;
end.
Using the standard win32 api, what's the best way to detect more than one user is logged on? I have an upgrade to our software product that can't be run when more than one user is logged in. (I know this is something to be avoided because of its annoyance factor, but the product is very complicated. You'll have to trust me when I say there really is no other solution.) Thanks.
In order to have more than one user logged in at once, Terminal Services or Fast User Switching must be enabled. Since Fast User Switching is implemented using Terminal Services, you first need to find out if the OS has it enabled. You can use GetVersionEx with an OSVERSIONINFOEX. Check for the VER_SUITE_SINGLEUSERTS and VER_SUITE_TERMINAL flags.
If TS is enabled, you can use WTSEnumerateSessions to find out how many users are logged on. This only works if the "Terminal Services" service is started.
If the machine doesn't support Terminal Services (or if the service isn't started), then you can only have one user logged on.
Here's a solution that works on XP, Server 2003, Vista, and Server 2008. Note, this won't work on Windows 2000, because "LsaEnumerateLogonSessions" is not available on Windows 2000. This code is modified from a Delphi-PRAXIS post.
To compile this, create a new VCL application with a TButton and a TMemo on the form. Then copy and paste this code and it should compile. I tested on XP and Vista and it works well. It will return interactive and remote users.
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
const
WTS_CURRENT_SERVER_HANDLE = 0;
type
PTOKEN_USER = ^TOKEN_USER;
_TOKEN_USER = record
User: TSidAndAttributes;
end;
TOKEN_USER = _TOKEN_USER;
USHORT = word;
_LSA_UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
Buffer: LPWSTR;
end;
LSA_UNICODE_STRING = _LSA_UNICODE_STRING;
PLuid = ^LUID;
_LUID = record
LowPart: DWORD;
HighPart: LongInt;
end;
LUID = _LUID;
_SECURITY_LOGON_TYPE = (
seltFiller0, seltFiller1,
Interactive,
Network,
Batch,
Service,
Proxy,
Unlock,
NetworkCleartext,
NewCredentials,
RemoteInteractive,
CachedInteractive,
CachedRemoteInteractive);
SECURITY_LOGON_TYPE = _SECURITY_LOGON_TYPE;
PSECURITY_LOGON_SESSION_DATA = ^SECURITY_LOGON_SESSION_DATA;
_SECURITY_LOGON_SESSION_DATA = record
Size: ULONG;
LogonId: LUID;
UserName: LSA_UNICODE_STRING;
LogonDomain: LSA_UNICODE_STRING;
AuthenticationPackage: LSA_UNICODE_STRING;
LogonType: SECURITY_LOGON_TYPE;
Session: ULONG;
Sid: PSID;
LogonTime: LARGE_INTEGER;
LogonServer: LSA_UNICODE_STRING;
DnsDomainName: LSA_UNICODE_STRING;
Upn: LSA_UNICODE_STRING;
end;
SECURITY_LOGON_SESSION_DATA = _SECURITY_LOGON_SESSION_DATA;
_WTS_INFO_CLASS = (
WTSInitialProgram,
WTSApplicationName,
WTSWorkingDirectory,
WTSOEMId,
WTSSessionId,
WTSUserName,
WTSWinStationName,
WTSDomainName,
WTSConnectState,
WTSClientBuildNumber,
WTSClientName,
WTSClientDirectory,
WTSClientProductId,
WTSClientHardwareId,
WTSClientAddress,
WTSClientDisplay,
WTSClientProtocolType);
WTS_INFO_CLASS = _WTS_INFO_CLASS;
_WTS_CONNECTSTATE_CLASS = (
WTSActive, // User logged on to WinStation
WTSConnected, // WinStation connected to client
WTSConnectQuery, // In the process of connecting to client
WTSShadow, // Shadowing another WinStation
WTSDisconnected, // WinStation logged on without client
WTSIdle, // Waiting for client to connect
WTSListen, // WinStation is listening for connection
WTSReset, // WinStation is being reset
WTSDown, // WinStation is down due to error
WTSInit); // WinStation in initialization
WTS_CONNECTSTATE_CLASS = _WTS_CONNECTSTATE_CLASS;
function LsaFreeReturnBuffer(Buffer: pointer): Integer; stdcall;
function WTSGetActiveConsoleSessionId: DWORD; external 'Kernel32.dll';
function LsaGetLogonSessionData(LogonId: PLUID;
var ppLogonSessionData: PSECURITY_LOGON_SESSION_DATA): LongInt; stdcall;
external 'Secur32.dll';
function LsaNtStatusToWinError(Status: cardinal): ULONG; stdcall;
external 'Advapi32.dll';
function LsaEnumerateLogonSessions(Count: PULONG; List: PLUID): LongInt;
stdcall; external 'Secur32.dll';
function WTSQuerySessionInformationA(hServer: THandle; SessionId: DWORD;
WTSInfoClass: WTS_INFO_CLASS; var pBuffer: Pointer;
var pBytesReturned: DWORD): BOOL; stdcall; external 'Wtsapi32.dll';
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function LsaFreeReturnBuffer; external 'secur32.dll' name 'LsaFreeReturnBuffer';
procedure GetActiveUserNames(var slUserList : TStringList);
var
Count: cardinal;
List: PLUID;
sessionData: PSECURITY_LOGON_SESSION_DATA;
i1: integer;
SizeNeeded, SizeNeeded2: DWORD;
OwnerName, DomainName: PChar;
OwnerType: SID_NAME_USE;
pBuffer: Pointer;
pBytesreturned: DWord;
sUser : string;
begin
//result:= '';
//Listing LogOnSessions
i1:= lsaNtStatusToWinError(LsaEnumerateLogonSessions(#Count, #List));
try
if i1 = 0 then
begin
i1:= -1;
if Count > 0 then
begin
repeat
inc(i1);
LsaGetLogonSessionData(List, sessionData);
//Checks if it is an interactive session
sUser := sessionData.UserName.Buffer;
if (sessionData.LogonType = Interactive)
or (sessionData.LogonType = RemoteInteractive)
or (sessionData.LogonType = CachedInteractive)
or (sessionData.LogonType = CachedRemoteInteractive) then
begin
//
SizeNeeded := MAX_PATH;
SizeNeeded2:= MAX_PATH;
GetMem(OwnerName, MAX_PATH);
GetMem(DomainName, MAX_PATH);
try
if LookupAccountSID(nil, sessionData.SID, OwnerName,
SizeNeeded, DomainName,SizeNeeded2,
OwnerType) then
begin
if OwnerType = 1 then //This is a USER account SID (SidTypeUser=1)
begin
sUser := AnsiUpperCase(sessionData.LogonDomain.Buffer);
sUser := sUser + '\';
sUser := sUser + AnsiUpperCase(sessionData.UserName.Buffer);
slUserList.Add(sUser);
// if sessionData.Session = WTSGetActiveConsoleSessionId then
// begin
// //Wenn Benutzer aktiv
// try
// if WTSQuerySessionInformationA
// (WTS_CURRENT_SERVER_HANDLE,
// sessionData.Session, WTSConnectState,
// pBuffer,
// pBytesreturned) then
// begin
// if WTS_CONNECTSTATE_CLASS(pBuffer^) = WTSActive then
// begin
// //result:= sessionData.UserName.Buffer;
// slUserList.Add(sessionData.UserName.Buffer);
// end;
// end;
// finally
// LSAFreeReturnBuffer(pBuffer);
// end;
//end;
end;
end;
finally
FreeMem(OwnerName);
FreeMem(DomainName);
end;
end;
inc(List);
try
LSAFreeReturnBuffer(sessionData);
except
end;
until (i1 = Count-1);// or (result <> '');
end;
end;
finally
LSAFreeReturnBuffer(List);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
slUsers : TStringList;
begin
slUsers := TStringList.Create;
slUsers.Duplicates := dupIgnore;
slUsers.Sorted := True;
try
GetActiveUserNames(slUsers);
Memo1.Lines.AddStrings(slUsers);
finally
FreeAndNil(slUsers)
end;
end;
end.
This might be a roundabout way, but run down the process list and see who the process owners are.