Delphi « GSaraiva's Projects

19
Jul 08

ParallelJobs: Simple use

:: articles :: by Gilberto Saraiva

Folks,

This is the first article about ParallelJobs and I’ll show you how to create a simple parallel process.

Lets create a simple drawing system that display a follower effect on a bitmap:

 Delphi |   copy code | ?  
01 function TfrmMain.UpdateFollower: integer;
02 const
03   FOLLOWERSIZE = 30;
04 var
05   Points: array [1..FOLLOWERSIZE] of TPoint;
06   i: Integer;
07 begin
08   while not CurrentJobTerminated do
09   begin
10     for i := 1 to FOLLOWERSIZE - 1 do
11       Points[i] := Points[i + 1];
12  
13     with Points[FOLLOWERSIZE], Mouse do
14     begin
15       X := CursorPos.X div 3;
16       Y := CursorPos.Y div 3;
17     end;
18  
19     Bmp.Canvas.Lock;
20     try
21       Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);
22       for i := 2 to FOLLOWERSIZE do
23       begin
24         with Points[i - 1] do
25           Bmp.Canvas.MoveTo(X, Y);
26         with Points[i] do
27           Bmp.Canvas.LineTo(X, Y);
28       end;
29     finally
30       Bmp.Canvas.Unlock;
31       Invalidate;
32     end;
33     Sleep(10);
34   end;
35  
36   Result := 0;
37 end;

This code will hold the last 30 positions(X, Y) of the mouse and when we modify something on Bmp we have to lock the canvas to don’t let it be display by WM_PAINT message on the wrong time.

Since we use the TBitmap Bmp we have to create it and setup as wish. After that its time to create the parallel job with ParallelJobs library.
The code below show how I did it:

 Delphi |   copy code | ?  
01 procedure TfrmMain.FormCreate(Sender: TObject);
02 begin
03   ControlStyle := [csOpaque];
04   Bmp := TBitmap.Create;
05   with Bmp do
06   begin
07     Width := Screen.Width div 3;
08     Height := Screen.Height div 3;
09  
10     Canvas.Brush.Color := clBlack;
11     Canvas.Pen.Color := RGB(255, 130, 0);
12   end;
13   ParallelJob(Self, @TfrmMain.UpdateFollower);
14 end;

ParallelJobs provide two ways to create a parallel process with any function or method you want, this code use one that you need to specify the object ( Self ) that contain the method and the method to work on a parallel process.

Now we have to create the display of the follower effect:

 Delphi |   copy code | ?  
01 procedure TfrmMain.WMPaint(var Message: TWMPaint);
02 begin
03   Inherited;
04   Bmp.Canvas.Lock;
05   try
06     Canvas.Draw(0, 0, Bmp);
07   finally
08     Bmp.Canvas.Unlock;
09   end;
10 end;

Take a look on the Canvas.Lock, that will create a basic switcher between modification and drawing processes.

Finally, to don’t raise a exception we need to terminate the parallel process before closing the form and on it destruction we have to free the Bmp to avoid memory leak.

 Delphi |   copy code | ?  
1 procedure TfrmMain.FormDestroy(Sender: TObject);
2 begin
3   Bmp.Free;
4 end;
5  
6 procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
7 begin
8   TerminateAllParallelJobs;
9 end;

Full source without ParallelJobs library, Download it here: pj_example1 (1.27 KB) - 64 hits

Very nice and easy, uhm?

Hugs for all

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 :: WorkOnProcessor

:: articles :: by Gilberto Saraiva

Folks,

For evebody who wants to control how the application’s threads and processes will consume the CPU I wrote this function to provide an easy way to do this.

 Delphi |   copy code | ?  
01 uses Windows;
02  
03 type
04   TWorkOnProcessorUseMode = (cpuNum, cpuPerc, cpuIndex);
05  
06 procedure WorkOnProcessor(AUse: Cardinal; AMode: TWorkOnProcessorUseMode);
07 var
08   Mask: integer;
09   lpSystemInfo: TSystemInfo;
10  
11   function ToMask(m: integer): integer;
12   var
13     i: integer;
14   begin
15     Result := 0;
16     for i := 0 to m - 1 do
17       Result := Result + (1 shl i);
18   end;
19 begin
20   GetSystemInfo(lpSystemInfo);
21   with lpSystemInfo do
22   begin
23     case AMode of
24       cpuNum: begin
25         if AUse > dwNumberOfProcessors then
26           AUse := dwNumberOfProcessors;
27       end;
28       cpuPerc: begin
29         if AUse > 100 then AUse := 100;
30         AUse := Round(dwNumberOfProcessors / 100 * AUse);
31       end;
32     end;
33     if AMode <> cpuIndex then
34     begin
35       Mask := ToMask(dwNumberOfProcessors);
36       Mask := Mask xor ToMask(dwNumberOfProcessors - AUse);
37     end else
38       Mask := (1 shl (AUse - 1));
39     SetProcessAffinityMask(GetCurrentProcess, Mask);
40   end;    
41 end;

You’ll have three ways to put your application running only on the processor(s) you want.

cpuNum mode:
With this mode you’ll be able to specify the number of processors you want to use. The logical structure will count from the first processor.

cpuPerc mode:
With this mode you’ll be able to specify a percentage to use of all processors on the machine. If the machine have four processors and you specify 50 (50%) on the first param, your application will use 2 cores. If 2 cores and 50% will use 1 core.

cpuIndex mode:
With this mode you’ll be able to specify the processor you want to use. If you have 4 cores and you want to use only the third core, specify 3 on the first param and your application will use only the 3º core and no one more.

A little detail:
Your application starts without a setting about what processor will be used and all threads and processes created before the use of the function above can be not modified and so the process can keep on an unspecified core.
The best way to use this function is declaring it on the DPR and using it before Application.Initialize;
Ex:

 Delphi |   copy code | ?  
1 // on the .DPR of the project
2 begin
3   WorkOnProcessor(50, cpuPerc);
4   Application.Initialize;
5   Application.CreateForm(TForm1, Form1);
6   Application.Run;
7 end.

articles — No 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

ParallelJobs: Simple use

Delphi: Utils :: WalkOnHandles

Delphi: Utils :: WorkOnProcessor

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	function TfrmMain.UpdateFollower: integer;
02	const
03	FOLLOWERSIZE = 30;
04	var
05	Points: array [1..FOLLOWERSIZE] of TPoint;
06	i: Integer;
07	begin
08	while not CurrentJobTerminated do
09	begin
10	for i := 1 to FOLLOWERSIZE - 1 do
11	Points[i] := Points[i + 1];
12
13	with Points[FOLLOWERSIZE], Mouse do
14	begin
15	X := CursorPos.X div 3;
16	Y := CursorPos.Y div 3;
17	end;
18
19	Bmp.Canvas.Lock;
20	try
21	Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);
22	for i := 2 to FOLLOWERSIZE do
23	begin
24	with Points[i - 1] do
25	Bmp.Canvas.MoveTo(X, Y);
26	with Points[i] do
27	Bmp.Canvas.LineTo(X, Y);
28	end;
29	finally
30	Bmp.Canvas.Unlock;
31	Invalidate;
32	end;
33	Sleep(10);
34	end;
35
36	Result := 0;
37	end;

01	procedure TfrmMain.FormCreate(Sender: TObject);
02	begin
03	ControlStyle := [csOpaque];
04	Bmp := TBitmap.Create;
05	with Bmp do
06	begin
07	Width := Screen.Width div 3;
08	Height := Screen.Height div 3;
09
10	Canvas.Brush.Color := clBlack;
11	Canvas.Pen.Color := RGB(255, 130, 0);
12	end;
13	ParallelJob(Self, @TfrmMain.UpdateFollower);
14	end;

01	procedure TfrmMain.WMPaint(var Message: TWMPaint);
02	begin
03	Inherited;
04	Bmp.Canvas.Lock;
05	try
06	Canvas.Draw(0, 0, Bmp);
07	finally
08	Bmp.Canvas.Unlock;
09	end;
10	end;

1	procedure TfrmMain.FormDestroy(Sender: TObject);
2	begin
3	Bmp.Free;
4	end;
5
6	procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
7	begin
8	TerminateAllParallelJobs;
9	end;

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	type
04	TWorkOnProcessorUseMode = (cpuNum, cpuPerc, cpuIndex);
05
06	procedure WorkOnProcessor(AUse: Cardinal; AMode: TWorkOnProcessorUseMode);
07	var
08	Mask: integer;
09	lpSystemInfo: TSystemInfo;
10
11	function ToMask(m: integer): integer;
12	var
13	i: integer;
14	begin
15	Result := 0;
16	for i := 0 to m - 1 do
17	Result := Result + (1 shl i);
18	end;
19	begin
20	GetSystemInfo(lpSystemInfo);
21	with lpSystemInfo do
22	begin
23	case AMode of
24	cpuNum: begin
25	if AUse > dwNumberOfProcessors then
26	AUse := dwNumberOfProcessors;
27	end;
28	cpuPerc: begin
29	if AUse > 100 then AUse := 100;
30	AUse := Round(dwNumberOfProcessors / 100 * AUse);
31	end;
32	end;
33	if AMode <> cpuIndex then
34	begin
35	Mask := ToMask(dwNumberOfProcessors);
36	Mask := Mask xor ToMask(dwNumberOfProcessors - AUse);
37	end else
38	Mask := (1 shl (AUse - 1));
39	SetProcessAffinityMask(GetCurrentProcess, Mask);
40	end;
41	end;

1	// on the .DPR of the project
2	begin
3	WorkOnProcessor(50, cpuPerc);
4	Application.Initialize;
5	Application.CreateForm(TForm1, Form1);
6	Application.Run;
7	end.

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