Usefull Function « GSaraiva's Projects

08
Jul 09

Delphi: Utils :: AppRunningCount

:: articles :: by Gilberto Saraiva

Folks,

For everybody thats need to limit the instance number of your application:

 Delphi |   copy code | ?  
01 uses SysUtils, TLHelp32;
02  
03 function AppRunningCount(const AExeName: string): integer;
04 var
05   hSnap: THandle;
06   p32: TProcessEntry32;
07 begin
08   Result := 0;
09   hSnap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
10   p32.dwSize := Sizeof(TProcessEntry32);
11   Process32First(hSnap, p32);
12   repeat
13     if SameText(AExeName, ExtractFileName(p32.szExeFile)) then
14       inc(Result);
15   until not Process32Next(hSnap, p32);
16   CloseHandle(hSnap);
17 end;

Use:

 Delphi |   copy code | ?  
1 // On DPR
2 // Limit to 1 instance
3 begin 
4   if AppRunningCount(ExtractFileName(ParamStr(0))) = 1 then
5   begin
6   // Application codes
7   end;
8 end.
9

Explaining more about this approach:
In a situation of multiples logons at the same machine the Mutex cannot provide a correctly singleton structure because the mutex handle still only under the local scope of the user. So the way to control the instance number is counting the number of times the process appear on the process list of the machine.

articles — No comments

03
Jul 08

Delphi: Utils :: WalkOnHandles

:: articles :: by Gilberto Saraiva

Folks,

A light for everybody. First of all, I’ll use two other usefull functions I posted on this site:

GetHwndClass

GetHwndText

And now the magic:

 Delphi |   copy code | ?  
01 uses Windows, TLHelp32;
02  
03 type
04   TWalkOnHandlesCallback = function(AHwnd, AParentHWnd: HWND;
05     AClass, AText: string; AFlag: Integer): boolean of object;
06  
07 function WalkOnHandles(AParent: HWND; AFlag: integer;
08   ACallback: TWalkOnHandlesCallback): Integer;
09 var
10   CurrHWnd: HWND;
11 begin
12   Result := 0;
13   CurrHWnd := GetTopWindow(AParent);
14   while CurrHWnd <> 0 do
15   begin
16     Result := Result + 1;
17     if Assigned(ACallback) then
18       if not ACallback(CurrHWnd, AParent,
19         GetHwndClass(CurrHWnd), GetHwndText(CurrHWnd), AFlag) then
20         Break;
21     CurrHWnd := GetNextWindow(CurrHWnd, GW_HWNDNEXT);
22   end;
23 end;
24  
25 function WalkOnHandlesOfExe(AExeName: string; AFlag: integer;
26   ACallback: TWalkOnHandlesCallback): Integer;
27 var
28   PID, CheckPID: DWord;
29   hSnapShot: THandle;
30   ProcessEntry: TProcessEntry32;
31   CurrHWnd: HWND;
32 begin
33   Result := 0;
34   PID := 0;
35   hSnapShot := CreateToolhelp32Snapshot((TH32CS_SNAPALL), 0);
36   ProcessEntry.dwSize := SizeOf(TProcessEntry32);
37   Process32First(hSnapShot, ProcessEntry);
38   repeat
39     if ProcessEntry.szExeFile = AExeName then
40     begin
41       PID := ProcessEntry.th32ProcessID;
42       Break;
43     end;
44   until Process32Next(hSnapShot, ProcessEntry) = false;
45   CloseHandle(hSnapShot);
46  
47   if PID > 0 then
48   begin
49     CurrHWnd := GetTopWindow(GetDesktopWindow);
50     while CurrHWnd <> 0 do
51     begin
52       Result := Result + 1;
53       GetWindowThreadProcessID(CurrHWnd, @CheckPID);
54       if CheckPID = PID then
55         if Assigned(ACallback) then
56           if not ACallback(CurrHWnd, 0,
57             GetHwndClass(CurrHWnd), GetHwndText(CurrHWnd), AFlag) then
58             Break;
59       CurrHWnd := GetNextWindow(CurrHWnd, GW_HWNDNEXT);
60     end;
61   end;
62 end;

Now let me explain what this big code do.

This code its only a light, a simple idea, about how you can navigate through the Windows Objects (Handle) from everywhere.

A simple example:

Create a TMemo named mmoLog

Link OnCreate of the Main Form

Create a the callback on the Main Form class

 Delphi |   copy code | ?  
01 
02   TForm1 = class(TForm)
03     mmoLog: TMemo;
04     procedure FormCreate(Sender: TObject);
05   private
06     { Private declarations }
07   public
08     function WalkCall(AHwnd, AParentHWnd: HWND;
09       AClass, AText: string; AFlag: Integer): boolean;
10   end;
11

The rest of the code:

 Delphi |   copy code | ?  
01 
02 procedure TForm1.FormCreate(Sender: TObject);
03 begin
04   WalkOnHandlesOfExe('delphi32.exe', 0, WalkCall);
05 end;
06  
07 function TForm1.WalkCall(AHwnd, AParentHWnd: HWND; AClass,
08   AText: string; AFlag: Integer): boolean;
09 begin
10   Result := True;
11   mmoLog.Lines.Add(stringofChar(' ', AFlag)  + Format('%d: [ %s ] %s', [AHwnd, AClass, AText]));
12   WalkOnHandles(AHwnd, AFlag + 2, WalkCall);
13 end;
14

This example will list all Windows Objects on the Delphi application and will result a idented log on the mmoLog.

Simple uhm?

WalkOnHandles
Walk on all handles by the Z-order of the specified Parent.

WalkOnHandlesOfExe
Walk on all handles by the Z-order that have DesktopWindow as parent and the Application as owner.

articles — 3 comments

03
Jul 08

Delphi: Utils :: AppSingleton

:: articles :: by Gilberto Saraiva

Folks,

This code below implement a singleton structure for the aplication, and that need to be implemented on the DPR file of the project:

 Delphi |   copy code | ?  
01 uses Windows;
02  
03 function AppSingleton(ACheckPath: boolean = false): boolean;
04 var
05   s: string;
06   i, iLast: Cardinal;
07 begin
08   s := ParamStr(0);
09   iLast := 1;
10   case Integer(ACheckPath) of
11     0: for i := 1 to Length(s) do if s[i] = '\' then iLast := i;
12     1: for i := 1 to Length(s) do if s[i] in [':','\','.',' '] then s[i] := '_';
13   end;
14   Result := (CreateMutex(nil, true, PChar(Cardinal(@s) + (iLast - 1))) <> 0) and
15     (GetLastError = 0);
16 end;

I use the CreateMutex API that works as a semaphore, if open, the application is unique, if closed the application is already running.

I wrote a condition to check the full path of the application for the Mutex call, so if you want to check the full path use the funciotn with param as True, the default is False and the check will be only on the application exe name.

A little detail about checking the functionality of this function:
Under debug mode the checkout on full path mode will fail and more then one application can be raised. This problem is because the relationship of the application with other program, so the CreateMutex API understand the Process ID is diferent from others.

articles — No comments

28
Jun 08

Delphi: Utils :: GetShellFolder

:: articles :: by Gilberto Saraiva

Folks,

Get some Shell Folder from Current User or All User ( System ):

 Delphi |   copy code | ?  
01 uses Registry;
02  
03 type
04   TShellFolderType = (
05     // User
06     sftAppData, sftCookies, sftDesktop, sftFavorites,
07     sftNetHood, sftPersonal, sftPrintHood, sftRecent, sftSendTo, sftStartMenu,
08     sftTemplates, sftPrograms, sftStartup, sftLocalSettings, sftLocalAppData,
09     sftCache, sftHistory, sftMyPictures, sftFonts, sftMyMusic, sftCDBurning,
10     sftMyVideo, sftAdminTools,
11     // System
12     sftCommonAppData, sftCommonPrograms, sftCommonDocuments, sftCommonDesktop,
13     sftCommonStartMenu, sftCommonPictures, sftCommonMusic, sftCommonVideo,
14     sftCommonFavorites, sftCommonStartup, sftCommonTemplates,
15     sftCommonAdminTools, sftCommonPersonal);
16  
17  
18 function GetShellFolder(AShellFolderType: TShellFolderType): string;
19 begin
20   with TRegistry.Create do
21   begin
22     if AShellFolderType <= sftAdminTools then
23       RootKey := HKEY_CURRENT_USER
24     else
25       RootKey := HKEY_LOCAL_MACHINE;
26  
27     OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', True);
28     case AShellFolderType of
29       sftAppData       : Result := ReadString('AppData');
30       sftCookies       : Result := ReadString('Cookies');
31       sftDesktop       : Result := ReadString('Desktop');
32       sftFavorites     : Result := ReadString('Favorites');
33       sftNetHood       : Result := ReadString('NetHood');
34       sftPersonal      : Result := ReadString('Personal');
35       sftPrintHood     : Result := ReadString('PrintHood');
36       sftRecent        : Result := ReadString('Recent');
37       sftSendTo        : Result := ReadString('SendTo');
38       sftStartMenu     : Result := ReadString('Start Menu');
39       sftTemplates     : Result := ReadString('Templates');
40       sftPrograms      : Result := ReadString('Programs');
41       sftStartup       : Result := ReadString('Startup');
42       sftLocalSettings : Result := ReadString('Local Settings');
43       sftLocalAppData  : Result := ReadString('Local AppData');
44       sftCache         : Result := ReadString('Cache');
45       sftHistory       : Result := ReadString('History');
46       sftMyPictures    : Result := ReadString('My Pictures');
47       sftFonts         : Result := ReadString('Fonts');
48       sftMyMusic       : Result := ReadString('My Music');
49       sftCDBurning     : Result := ReadString('CD Burning');
50       sftMyVideo       : Result := ReadString('My Video');
51       sftAdminTools    : Result := ReadString('Administrative Tools');
52  
53       // System
54       sftCommonAppData    : Result := ReadString('Common AppData');
55       sftCommonPrograms   : Result := ReadString('Common Programs');
56       sftCommonDocuments  : Result := ReadString('Common Documents');
57       sftCommonDesktop    : Result := ReadString('Common Desktop');
58       sftCommonStartMenu  : Result := ReadString('Common Start Menu');
59       sftCommonPictures   : Result := ReadString('CommonPictures');
60       sftCommonMusic      : Result := ReadString('CommonMusic');
61       sftCommonVideo      : Result := ReadString('CommonVideo');
62       sftCommonFavorites  : Result := ReadString('Common Favorites');
63       sftCommonStartup    : Result := ReadString('Common Startup');
64       sftCommonTemplates  : Result := ReadString('Common Templates');
65       sftCommonAdminTools : Result := ReadString('Common Administrative Tools');
66       sftCommonPersonal   : Result := ReadString('Personal');
67     end;                                                     
68   end;
69 end;

articles — No comments

28
Jun 08

Delphi: Utils :: WinSystem32Path

:: articles :: by Gilberto Saraiva

Folks,

Get Windows’s System32 Directory as Path ( \ at end)

 Delphi |   copy code | ?  
01 var
02   WinSystem32PathStr: string = '';
03  
04 function WinSystem32Path: string;
05 begin
06   if WinSystem32PathStr = '' then
07   begin
08     SetLength(Result, MAX_PATH);
09     SetLength(Result, GetSystemDirectory(PChar(Result), MAX_PATH));
10     WinSystem32PathStr := Result + '\';
11   end;
12   Result := WinSystem32PathStr;
13 end;

articles — No comments

28
Jun 08

Delphi: Utils :: WindowsPath

:: articles :: by Gilberto Saraiva

Folks,

Get the Windows Directory as Path ( \ at end ):

 Delphi |   copy code | ?  
01 var
02   WindowsPathStr: string = '';
03  
04 function WindowsPath: string;
05 begin
06   if WindowsPathStr = '' then
07   begin
08     SetLength(Result, MAX_PATH);
09     SetLength(Result, GetWindowsDirectory(PChar(Result), MAX_PATH));
10     WindowsPathStr := Result + '\';
11   end;
12   Result := WindowsPathStr;
13 end;

articles — No comments

28
Jun 08

Delphi: Utils :: GetShortcutCmd

:: articles :: by Gilberto Saraiva

Folks,

Get the program and command line of a shortcurt file (.LNK)

 Delphi |   copy code | ?  
01 uses ActiveX, ComObj, ShlObj;
02  
03 function GetShortcutCmd(AShortcutPath: string): string;
04 var
05   ShellLink: IUnknown;
06   Win32Data: TWin32FindData;
07   Buff: array [0..MAX_PATH*2] of Char;
08 begin
09   ShellLink := CreateComObject(CLSID_ShellLink);
10   with (ShellLink as IShellLink), (ShellLink as IPersistFile) do
11   begin
12     Load(PWChar(WideString(AShortcutPath)), 0);
13     GetPath(@Buff[0], MAX_PATH, Win32Data, SLGP_UNCPRIORITY);
14     GetArguments(@Buff[MAX_PATH], MAX_PATH);
15     Result := Trim(PChar(@Buff) + ' ' + PChar(@Buff[MAX_PATH]));
16   end;
17 end;

articles — No comments

28
Jun 08

Delphi: Utils :: GetHwndClass

:: articles :: by Gilberto Saraiva

Folks,

Get the Class Name of the Window Object ( Handle )

 Delphi |   copy code | ?  
1 uses Windows;
2  
3 function GetHwndClass(AHandle: HWND): string;
4 begin
5   SetLength(Result, 255);
6   GetClassName(AHandle, PChar(Result), 255);
7   Result := StrPas(PChar(Result));
8 end;

articles — No comments

28
Jun 08

Delphi: Utils :: GetHwndText

:: articles :: by Gilberto Saraiva

Folks,

The first of a serie of usefull functions, that I’ll provide here.

Get the Text ( Caption ) of a Windows Object ( Handle )

 Delphi |   copy code | ?  
01 uses Windows;
02  
03  
04 function GetHwndText(AHandle: HWND): string;
05 var
06   iLen: integer;
07 begin
08   iLen := GetWindowTextLength(AHandle);
09   SetLength(Result, iLen);
10   GetWindowText(AHandle, PChar(Result), iLen + 1);
11 end;

articles — No comments

Step by step

Delphi: Utils :: AppRunningCount

Delphi: Utils :: WalkOnHandles

Delphi: Utils :: AppSingleton

Delphi: Utils :: GetShellFolder

Delphi: Utils :: WinSystem32Path

Delphi: Utils :: WindowsPath

Delphi: Utils :: GetShortcutCmd

Delphi: Utils :: GetHwndClass

Delphi: Utils :: GetHwndText

Pages

Last Comments

Meta

01	uses SysUtils, TLHelp32;
02
03	function AppRunningCount(const AExeName: string): integer;
04	var
05	hSnap: THandle;
06	p32: TProcessEntry32;
07	begin
08	Result := 0;
09	hSnap := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
10	p32.dwSize := Sizeof(TProcessEntry32);
11	Process32First(hSnap, p32);
12	repeat
13	if SameText(AExeName, ExtractFileName(p32.szExeFile)) then
14	inc(Result);
15	until not Process32Next(hSnap, p32);
16	CloseHandle(hSnap);
17	end;

1	// On DPR
2	// Limit to 1 instance
3	begin
4	if AppRunningCount(ExtractFileName(ParamStr(0))) = 1 then
5	begin
6	// Application codes
7	end;
8	end.
9

01	uses Windows, TLHelp32;
02
03	type
04	TWalkOnHandlesCallback = function(AHwnd, AParentHWnd: HWND;
05	AClass, AText: string; AFlag: Integer): boolean of object;
06
07	function WalkOnHandles(AParent: HWND; AFlag: integer;
08	ACallback: TWalkOnHandlesCallback): Integer;
09	var
10	CurrHWnd: HWND;
11	begin
12	Result := 0;
13	CurrHWnd := GetTopWindow(AParent);
14	while CurrHWnd <> 0 do
15	begin
16	Result := Result + 1;
17	if Assigned(ACallback) then
18	if not ACallback(CurrHWnd, AParent,
19	GetHwndClass(CurrHWnd), GetHwndText(CurrHWnd), AFlag) then
20	Break;
21	CurrHWnd := GetNextWindow(CurrHWnd, GW_HWNDNEXT);
22	end;
23	end;
24
25	function WalkOnHandlesOfExe(AExeName: string; AFlag: integer;
26	ACallback: TWalkOnHandlesCallback): Integer;
27	var
28	PID, CheckPID: DWord;
29	hSnapShot: THandle;
30	ProcessEntry: TProcessEntry32;
31	CurrHWnd: HWND;
32	begin
33	Result := 0;
34	PID := 0;
35	hSnapShot := CreateToolhelp32Snapshot((TH32CS_SNAPALL), 0);
36	ProcessEntry.dwSize := SizeOf(TProcessEntry32);
37	Process32First(hSnapShot, ProcessEntry);
38	repeat
39	if ProcessEntry.szExeFile = AExeName then
40	begin
41	PID := ProcessEntry.th32ProcessID;
42	Break;
43	end;
44	until Process32Next(hSnapShot, ProcessEntry) = false;
45	CloseHandle(hSnapShot);
46
47	if PID > 0 then
48	begin
49	CurrHWnd := GetTopWindow(GetDesktopWindow);
50	while CurrHWnd <> 0 do
51	begin
52	Result := Result + 1;
53	GetWindowThreadProcessID(CurrHWnd, @CheckPID);
54	if CheckPID = PID then
55	if Assigned(ACallback) then
56	if not ACallback(CurrHWnd, 0,
57	GetHwndClass(CurrHWnd), GetHwndText(CurrHWnd), AFlag) then
58	Break;
59	CurrHWnd := GetNextWindow(CurrHWnd, GW_HWNDNEXT);
60	end;
61	end;
62	end;

01
02	TForm1 = class(TForm)
03	mmoLog: TMemo;
04	procedure FormCreate(Sender: TObject);
05	private
06	{ Private declarations }
07	public
08	function WalkCall(AHwnd, AParentHWnd: HWND;
09	AClass, AText: string; AFlag: Integer): boolean;
10	end;
11

01
02	procedure TForm1.FormCreate(Sender: TObject);
03	begin
04	WalkOnHandlesOfExe('delphi32.exe', 0, WalkCall);
05	end;
06
07	function TForm1.WalkCall(AHwnd, AParentHWnd: HWND; AClass,
08	AText: string; AFlag: Integer): boolean;
09	begin
10	Result := True;
11	mmoLog.Lines.Add(stringofChar(' ', AFlag) + Format('%d: [ %s ] %s', [AHwnd, AClass, AText]));
12	WalkOnHandles(AHwnd, AFlag + 2, WalkCall);
13	end;
14

01	uses Windows;
02
03	function AppSingleton(ACheckPath: boolean = false): boolean;
04	var
05	s: string;
06	i, iLast: Cardinal;
07	begin
08	s := ParamStr(0);
09	iLast := 1;
10	case Integer(ACheckPath) of
11	0: for i := 1 to Length(s) do if s[i] = '\' then iLast := i;
12	1: for i := 1 to Length(s) do if s[i] in [':','\','.',' '] then s[i] := '_';
13	end;
14	Result := (CreateMutex(nil, true, PChar(Cardinal(@s) + (iLast - 1))) <> 0) and
15	(GetLastError = 0);
16	end;

01	var
02	WinSystem32PathStr: string = '';
03
04	function WinSystem32Path: string;
05	begin
06	if WinSystem32PathStr = '' then
07	begin
08	SetLength(Result, MAX_PATH);
09	SetLength(Result, GetSystemDirectory(PChar(Result), MAX_PATH));
10	WinSystem32PathStr := Result + '\';
11	end;
12	Result := WinSystem32PathStr;
13	end;

01	var
02	WindowsPathStr: string = '';
03
04	function WindowsPath: string;
05	begin
06	if WindowsPathStr = '' then
07	begin
08	SetLength(Result, MAX_PATH);
09	SetLength(Result, GetWindowsDirectory(PChar(Result), MAX_PATH));
10	WindowsPathStr := Result + '\';
11	end;
12	Result := WindowsPathStr;
13	end;

01	uses ActiveX, ComObj, ShlObj;
02
03	function GetShortcutCmd(AShortcutPath: string): string;
04	var
05	ShellLink: IUnknown;
06	Win32Data: TWin32FindData;
07	Buff: array [0..MAX_PATH*2] of Char;
08	begin
09	ShellLink := CreateComObject(CLSID_ShellLink);
10	with (ShellLink as IShellLink), (ShellLink as IPersistFile) do
11	begin
12	Load(PWChar(WideString(AShortcutPath)), 0);
13	GetPath(@Buff[0], MAX_PATH, Win32Data, SLGP_UNCPRIORITY);
14	GetArguments(@Buff[MAX_PATH], MAX_PATH);
15	Result := Trim(PChar(@Buff) + ' ' + PChar(@Buff[MAX_PATH]));
16	end;
17	end;

1	uses Windows;
2
3	function GetHwndClass(AHandle: HWND): string;
4	begin
5	SetLength(Result, 255);
6	GetClassName(AHandle, PChar(Result), 255);
7	Result := StrPas(PChar(Result));
8	end;

01	uses Windows;
02
03
04	function GetHwndText(AHandle: HWND): string;
05	var
06	iLen: integer;
07	begin
08	iLen := GetWindowTextLength(AHandle);
09	SetLength(Result, iLen);
10	GetWindowText(AHandle, PChar(Result), iLen + 1);
11	end;

Step by step

Tags

Pages

Last Comments

Meta