neoturk: ...Get and set mouse position ?...
// Get mouse positon
procedure TForm1.Button1Click(Sender: TObject);
var
MausPos: TPoint;
begin
GetCursorPos(MausPos);
label1.Caption := IntToStr(MausPos.x);
label2.Caption := IntToStr(MausPos.y);
end;
// Set mouse position to (x,y)
procedure TForm1.Button2Click(Sender: TObject);
begin
SetCursorPos(600, 600);
end;
Delphi - .....................................
neoturk: ...Get and set mouse position ?...
// Get mouse positon
procedure TForm1.Button1Click(Sender: TObject);
var
MausPos: TPoint;
begin
GetCursorPos(MausPos);
label1.Caption := IntToStr(MausPos.x);
label2.Caption := IntToStr(MausPos.y);
end;
// Set mouse position to (x,y)
procedure TForm1.Button2Click(Sender: TObject);
begin
SetCursorPos(600, 600);
end;
Delphi - .....................................
neoturk: ...Move window controls at runtime ?...
{Assign the OnMouseDown event for each component you want to move at runtime }
type
TForm1 = class(TForm)
{...}
procedure MoveControl(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private-Declarations }
public
{ Public-Declarations }
end;
end;
// In the implementation Section:
procedure TForm1.MoveControl(Sender:TObject; Button:TMouseButton;
Shift:TShiftState; X,Y:Integer);
var
TempPanel: TPanel;
Control: TControl;
begin
// Releases the mouse capture from a window
ReleaseCapture;
// If the component is a TWinControl, move it directly
if Sender is TWinControl then
TWinControl(Sender).Perform(WM_SYSCOMMAND,$F012,0)
else
try
Control := TControl(Sender);
TempPanel := TPanel.Create(Self);
with TempPanel do
begin
//Replace the component with TempPanel
Caption := '';
BevelOuter := bvNone;
SetBounds(Control.Left, Control.Top, Control.Width, Control.Height);
Parent := Control.Parent;
//Put our control in TempPanel
Control.Parent := TempPanel;
//Move TempPanel with control inside it
Perform(WM_SYSCOMMAND, $F012, 0);
//Put the component where the panel was dropped
Control.Parent := Parent;
Control.Left := Left;
Control.Top := Top;
end;
finally
TempPanel.Free;
end;
end;
Delphi - .....................................
neoturk: ...Move window controls at runtime ?...
{Assign the OnMouseDown event for each component you want to move at runtime }
type
TForm1 = class(TForm)
{...}
procedure MoveControl(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private-Declarations }
public
{ Public-Declarations }
end;
end;
// In the implementation Section:
procedure TForm1.MoveControl(Sender:TObject; Button:TMouseButton;
Shift:TShiftState; X,Y:Integer);
var
TempPanel: TPanel;
Control: TControl;
begin
// Releases the mouse capture from a window
ReleaseCapture;
// If the component is a TWinControl, move it directly
if Sender is TWinControl then
TWinControl(Sender).Perform(WM_SYSCOMMAND,$F012,0)
else
try
Control := TControl(Sender);
TempPanel := TPanel.Create(Self);
with TempPanel do
begin
//Replace the component with TempPanel
Caption := '';
BevelOuter := bvNone;
SetBounds(Control.Left, Control.Top, Control.Width, Control.Height);
Parent := Control.Parent;
//Put our control in TempPanel
Control.Parent := TempPanel;
//Move TempPanel with control inside it
Perform(WM_SYSCOMMAND, $F012, 0);
//Put the component where the panel was dropped
Control.Parent := Parent;
Control.Left := Left;
Control.Top := Top;
end;
finally
TempPanel.Free;
end;
end;
Delphi - .....................................
neoturk: ...Change the display time of the hints ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
//default = 2500 ms
Application.HintHidePause := 10000 //10 Sec
end;
Delphi - .....................................
neoturk: ...Change the display time of the hints ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
//default = 2500 ms
Application.HintHidePause := 10000 //10 Sec
end;
Delphi - .....................................
neoturk: ...Adjust the windowform to a tcanvas ?...
{
When youu need a form like a tree or something else what do you do? Windows
provides the CreateRoundRectRegion() function that just cuts the edges of your
form. If you want to do something else, you need to completely draw your
region in a HDC (TCanvas) while Windows looks on your hand to learn it.
After this, you can set the new region to your form using the 'SetWindowRgn()' function.
And how to do this? Here you will find a simple example that just gives some text
and sets the region like it. Expand it by your mind!
}
var
Form1: TForm1;
HRgn: THandle;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
DeleteObject(HRgn);
s := InputBox('Region Text', 'Please enter some text to set to the region', 'CoolRgn');
BeginPath(Canvas.Handle);
with Canvas do
begin
Font.Name := 'Comic Sans MS';
Font.Size := 64;
Font.Style := [fsBold];
TextOut(0, 0, s);
end;
EndPath(Canvas.Handle);
HRgn := PathToRegion(Canvas.Handle);
SetWindowRgn(Handle, HRgn, True);
button1.Visible := False;
Color := clRed;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DeleteObject(HRgn);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
SendMessage(Handle, WM_NCLBUTTONDOWN, HTCAPTION, 0);
end;
end;
Delphi - .....................................
neoturk: ...Adjust the windowform to a tcanvas ?...
{
When youu need a form like a tree or something else what do you do? Windows
provides the CreateRoundRectRegion() function that just cuts the edges of your
form. If you want to do something else, you need to completely draw your
region in a HDC (TCanvas) while Windows looks on your hand to learn it.
After this, you can set the new region to your form using the 'SetWindowRgn()' function.
And how to do this? Here you will find a simple example that just gives some text
and sets the region like it. Expand it by your mind!
}
var
Form1: TForm1;
HRgn: THandle;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
DeleteObject(HRgn);
s := InputBox('Region Text', 'Please enter some text to set to the region', 'CoolRgn');
BeginPath(Canvas.Handle);
with Canvas do
begin
Font.Name := 'Comic Sans MS';
Font.Size := 64;
Font.Style := [fsBold];
TextOut(0, 0, s);
end;
EndPath(Canvas.Handle);
HRgn := PathToRegion(Canvas.Handle);
SetWindowRgn(Handle, HRgn, True);
button1.Visible := False;
Color := clRed;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DeleteObject(HRgn);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
SendMessage(Handle, WM_NCLBUTTONDOWN, HTCAPTION, 0);
end;
end;
Delphi - .....................................
neoturk: ...Make a form transparent ?...
{
Suppose you have one form named Form1, and a button1 on Form1,
On Form1's OnCreate event write these code:
}
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle, GWL_EXSTYLE,
(GetWindowLong(Form1.Handle, GWL_EXSTYLE) or WS_WX_TRANSPARENT));
end;
{
Only the button can be seen, but form cannot.
Works on Windows 98/2000
}
Delphi - .....................................
neoturk: ...Make a form transparent ?...
{
Suppose you have one form named Form1, and a button1 on Form1,
On Form1's OnCreate event write these code:
}
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle, GWL_EXSTYLE,
(GetWindowLong(Form1.Handle, GWL_EXSTYLE) or WS_WX_TRANSPARENT));
end;
{
Only the button can be seen, but form cannot.
Works on Windows 98/2000
}
Delphi - .....................................
neoturk: ...Find classes registered by a form class ?...
type
PFieldClassTable = ^TFieldClassTable;
TFieldClassTable = packed record
Count: Smallint;
Classes: array[0..8191] of ^TPersistentClass;
end;
function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
asm
MOV EAX,[EAX].vmtFieldTable
OR EAX,EAX
JE @@1
MOV EAX,[EAX+2].Integer
@@1:
end;
procedure TForm1.Button1Click(Sender: TObject);
procedure Display(const S: string);
begin
memo1.Lines.Add(S);
end;
var
pFCT: PFieldClassTable;
aClass: TClass;
i: SmallInt;
begin
memo1.Clear;
aClass := Classtype;
while aClass <> TPersistent do
begin
Display('Registered classes for class ' + aClass.ClassName);
pFCT := GetFieldClasstable(aClass);
if not Assigned(pFCT) then
Display(' No classes registered')
else
begin
Display(Format(' %d classes registered', [pFCT^.Count]));
for i := 0 to pFCT^.Count - 1 do
Display(' ' + pFCT^.Classes[i]^.ClassName);
end;
aClass := aClass.ClassParent;
end
end;
Delphi - .....................................
neoturk: ...Find classes registered by a form class ?...
type
PFieldClassTable = ^TFieldClassTable;
TFieldClassTable = packed record
Count: Smallint;
Classes: array[0..8191] of ^TPersistentClass;
end;
function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
asm
MOV EAX,[EAX].vmtFieldTable
OR EAX,EAX
JE @@1
MOV EAX,[EAX+2].Integer
@@1:
end;
procedure TForm1.Button1Click(Sender: TObject);
procedure Display(const S: string);
begin
memo1.Lines.Add(S);
end;
var
pFCT: PFieldClassTable;
aClass: TClass;
i: SmallInt;
begin
memo1.Clear;
aClass := Classtype;
while aClass <> TPersistent do
begin
Display('Registered classes for class ' + aClass.ClassName);
pFCT := GetFieldClasstable(aClass);
if not Assigned(pFCT) then
Display(' No classes registered')
else
begin
Display(Format(' %d classes registered', [pFCT^.Count]));
for i := 0 to pFCT^.Count - 1 do
Display(' ' + pFCT^.Classes[i]^.ClassName);
end;
aClass := aClass.ClassParent;
end
end;
Delphi - .....................................
neoturk: ...Prevent a form from moving-resizing ?...
private
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
{...}
implementation
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if ((Msg.CmdType and $FFF0) = SC_MOVE) or
((Msg.CmdType and $FFF0) = SC_SIZE) then
begin
Msg.Result := 0;
Exit;
end;
inherited;
end;
Delphi - .....................................
neoturk: ...Prevent a form from moving-resizing ?...
private
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
{...}
implementation
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if ((Msg.CmdType and $FFF0) = SC_MOVE) or
((Msg.CmdType and $FFF0) = SC_SIZE) then
begin
Msg.Result := 0;
Exit;
end;
inherited;
end;
Delphi - .....................................
neoturk: ...Show a popupmenu in the task notification area ?...
(*
(Vorbemerkung zu "TNA": damit ist der "Task Notification Area" gemeint.)
Ein Symbol im TNA zu erzeugen -> kein Problem
Ein Popupmenu beim Klick auf dieses Symbol anzuzeigen -> kein Problem
AAABER dieses auch wieder verschwinden zu lassen wenn der Klick irgendwo anders
erfolgt -> eine Katastrophe ... jedenfalls bis mir die Idee kam ... siehe unten
die mit "ACHTUNG!!!" gekennzeichnete Zeile
*)
unit TNA;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls,
ShellApi, Menus;
const
k_WM_TASKMSG = WM_APP + 100; //die "100" ist ein frei wählbarer Wert
type
TForm1 = class(TForm)
TPopupMenu1: TPopupMenu;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormDblClick(Sender: TObject);
procedure PopupMenuClick(Sender: TObject);
private
{ Private-Deklarationen }
tTNA: TNotifyIconData;
procedure WMTaskMsg(var Msg: TMessage); message k_WM_TASKMSG;
procedure AppActive;
procedure AppDeactivate;
procedure ShowIcon;
procedure ChangeIcon;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{$R TNA.RES} //eine Resource mit 2 Icons oder Bitmaps
procedure TForm1.FormCreate(Sender: TObject);
begin
{läßt die Form schon bei Programmstart verschwinden}
Application.ShowMainForm := False;
{Symbol im TNA anzeigen}
Self.ShowIcon;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
{Symbol aus dem TNA entfernen}
Shell_NotifyIcon(NIM_DELETE, @tTNA);
end;
procedure TForm1.FormDblClick(Sender: TObject);
begin
{lassen wir doch die Form wieder verschwinden ...}
Self.AppDeactivate;
{... und ändern das Symbol in dem TNA}
Self.ChangeIcon;
end;
procedure TForm1.PopupMenuClick(Sender: TObject);
begin
case TPopupMenu(Sender).Tag of
{hier steht dann die Auswahl was getan werden soll}
{wenn auf das erschienene Popupmenü geklickt wurde}
end;
end;
procedure TForm1.WMTaskMsg(var Msg: TMessage);
var
rCursor: TPoint;
begin
{wenn die Nachricht aus unserem definierten Bereich kommt dann ...}
if Msg.wParam = tTNA.uID then
begin
{... tu was wenn das Ereignis ein ...}
case Msg.lParam of
{... rechter Mausklick ist oder ...}
WM_RBUTTONDOWN:
begin
{aktuelle Cursoposition holen}
GetCursorPos(rCursor);
{ACHTUNG!!!!! Der folgende Aufruf ist an dieser Stelle ganz wichtig!!!!}
{Erst durch diese API-Funktion wird das Popupmenü dazu bewegt zu verschwinden
wenn ein Klick außerhalb des Popupmenüs erfolgt}
SetForegroundWindow(Self.Handle);
{Also, nicht vergessen!!!}
{Das Popupmenü erscheint an der gewünschten Position in dem TNA}
TPopupMenu1.Popup(rCursor.x, rCursor.y);
end;
{... ein linker doppelter Mausklick ist}
WM_LBUTTONDBLCLK: Self.AppActive;
end;
end;
end;
procedure TForm1.AppActive;
var
hOwner: THandle;
begin
{Form einblenden}
SendMessage(Self.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
ShowWindow(Self.Handle, SW_SHOW);
SetForegroundWindow(Self.Handle);
{Symbol in der Taskbar einblenden}
hOwner := GetWindow(Self.Handle, GW_OWNER);
SendMessage(hOwner, WM_SYSCOMMAND, SC_RESTORE, 0);
ShowWindow(hOwner, SW_SHOW);
end;
procedure TForm1.AppDeactivate;
begin
{Form ausblenden}
ShowWindow(Self.Handle, SW_HIDE);
{Symbol in der Taskbar ausblenden}
ShowWindow(GetWindow(Self.Handle, GW_OWNER), SW_HIDE);
end;
procedure TForm1.ShowIcon;
begin
tTNA.cbSize := SizeOf(tTNA);
tTNA.Wnd := Self.Handle;
tTNA.uID := 24112000; //frei wählbarer Wert zur Identifizierung
tTNA.uCallbackMessage := k_WM_TASKMSG;
tTNA.hIcon := LoadIcon(hInstance, 'xxx');
//xxx ist die Bezeichnung eines Icons aus "TNA.res"
StrCopy(tTNA.szTip, 'Hallo'); //Hint
tTNA.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
{CB Symbol in dem TNA einrichten CE}
Shell_NotifyIcon(NIM_ADD, @tTNA);
end;
procedure TForm1.ChangeIcon;
begin
tTNA.cbSize := SizeOf(tTNA);
tTNA.hIcon := LoadIcon(hInstance, 'yyy');
//yyy ist die Bezeichnung eines weiteren Icons aus "TNA.res"
StrCopy(tTNA.szTip, 'Welt'); //Hint
{CB Symbol im TNA ändern CE}
Shell_NotifyIcon(NIM_MODIFY, @tTNA);
end;
end.
Delphi - .....................................
neoturk: ...Show a popupmenu in the task notification area ?...
(*
(Vorbemerkung zu "TNA": damit ist der "Task Notification Area" gemeint.)
Ein Symbol im TNA zu erzeugen -> kein Problem
Ein Popupmenu beim Klick auf dieses Symbol anzuzeigen -> kein Problem
AAABER dieses auch wieder verschwinden zu lassen wenn der Klick irgendwo anders
erfolgt -> eine Katastrophe ... jedenfalls bis mir die Idee kam ... siehe unten
die mit "ACHTUNG!!!" gekennzeichnete Zeile
*)
unit TNA;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls,
ShellApi, Menus;
const
k_WM_TASKMSG = WM_APP + 100; //die "100" ist ein frei wählbarer Wert
type
TForm1 = class(TForm)
TPopupMenu1: TPopupMenu;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormDblClick(Sender: TObject);
procedure PopupMenuClick(Sender: TObject);
private
{ Private-Deklarationen }
tTNA: TNotifyIconData;
procedure WMTaskMsg(var Msg: TMessage); message k_WM_TASKMSG;
procedure AppActive;
procedure AppDeactivate;
procedure ShowIcon;
procedure ChangeIcon;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{$R TNA.RES} //eine Resource mit 2 Icons oder Bitmaps
procedure TForm1.FormCreate(Sender: TObject);
begin
{läßt die Form schon bei Programmstart verschwinden}
Application.ShowMainForm := False;
{Symbol im TNA anzeigen}
Self.ShowIcon;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
{Symbol aus dem TNA entfernen}
Shell_NotifyIcon(NIM_DELETE, @tTNA);
end;
procedure TForm1.FormDblClick(Sender: TObject);
begin
{lassen wir doch die Form wieder verschwinden ...}
Self.AppDeactivate;
{... und ändern das Symbol in dem TNA}
Self.ChangeIcon;
end;
procedure TForm1.PopupMenuClick(Sender: TObject);
begin
case TPopupMenu(Sender).Tag of
{hier steht dann die Auswahl was getan werden soll}
{wenn auf das erschienene Popupmenü geklickt wurde}
end;
end;
procedure TForm1.WMTaskMsg(var Msg: TMessage);
var
rCursor: TPoint;
begin
{wenn die Nachricht aus unserem definierten Bereich kommt dann ...}
if Msg.wParam = tTNA.uID then
begin
{... tu was wenn das Ereignis ein ...}
case Msg.lParam of
{... rechter Mausklick ist oder ...}
WM_RBUTTONDOWN:
begin
{aktuelle Cursoposition holen}
GetCursorPos(rCursor);
{ACHTUNG!!!!! Der folgende Aufruf ist an dieser Stelle ganz wichtig!!!!}
{Erst durch diese API-Funktion wird das Popupmenü dazu bewegt zu verschwinden
wenn ein Klick außerhalb des Popupmenüs erfolgt}
SetForegroundWindow(Self.Handle);
{Also, nicht vergessen!!!}
{Das Popupmenü erscheint an der gewünschten Position in dem TNA}
TPopupMenu1.Popup(rCursor.x, rCursor.y);
end;
{... ein linker doppelter Mausklick ist}
WM_LBUTTONDBLCLK: Self.AppActive;
end;
end;
end;
procedure TForm1.AppActive;
var
hOwner: THandle;
begin
{Form einblenden}
SendMessage(Self.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
ShowWindow(Self.Handle, SW_SHOW);
SetForegroundWindow(Self.Handle);
{Symbol in der Taskbar einblenden}
hOwner := GetWindow(Self.Handle, GW_OWNER);
SendMessage(hOwner, WM_SYSCOMMAND, SC_RESTORE, 0);
ShowWindow(hOwner, SW_SHOW);
end;
procedure TForm1.AppDeactivate;
begin
{Form ausblenden}
ShowWindow(Self.Handle, SW_HIDE);
{Symbol in der Taskbar ausblenden}
ShowWindow(GetWindow(Self.Handle, GW_OWNER), SW_HIDE);
end;
procedure TForm1.ShowIcon;
begin
tTNA.cbSize := SizeOf(tTNA);
tTNA.Wnd := Self.Handle;
tTNA.uID := 24112000; //frei wählbarer Wert zur Identifizierung
tTNA.uCallbackMessage := k_WM_TASKMSG;
tTNA.hIcon := LoadIcon(hInstance, 'xxx');
//xxx ist die Bezeichnung eines Icons aus "TNA.res"
StrCopy(tTNA.szTip, 'Hallo'); //Hint
tTNA.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
{CB Symbol in dem TNA einrichten CE}
Shell_NotifyIcon(NIM_ADD, @tTNA);
end;
procedure TForm1.ChangeIcon;
begin
tTNA.cbSize := SizeOf(tTNA);
tTNA.hIcon := LoadIcon(hInstance, 'yyy');
//yyy ist die Bezeichnung eines weiteren Icons aus "TNA.res"
StrCopy(tTNA.szTip, 'Welt'); //Hint
{CB Symbol im TNA ändern CE}
Shell_NotifyIcon(NIM_MODIFY, @tTNA);
end;
end.
Delphi - .....................................
neoturk: ...Make a desktop screenshot ?...
{---------------------1---------------------}
function GetScreenShot: TBitmap;
var
Desktop: HDC;
begin
Result := TBitmap.Create;
Desktop := GetDC(0);
try
try
Result.PixelFormat := pf32bit;
Result.Width := Screen.Width;
Result.Height := Screen.Height;
BitBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, Desktop, 0, 0, SRCCOPY);
Result.Modified := True;
finally
ReleaseDC(0, Desktop);
end;
except
Result.Free;
Result := nil;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Bitmap := GetScreenShot;
end;
{---------------------2---------------------}
procedure TForm1.Button1Click(Sender: TObject);
var DCDesk: HDC; // hDC of Desktop
bmp: TBitmap;
begin
{Create a bitmap}
bmp := TBitmap.Create;
{Set a bitmap sizes}
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
{Get a desktop DC handle - handle of a display device context}
DCDesk := GetWindowDC(GetDesktopWindow);
{Copy to any canvas, here canvas of an image}
BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DCDesk, 0, 0, SRCCOPY);
{Save the bitmap}
bmp.SaveToFile('ScreenShot.bmp');
{Release desktop DC handle}
ReleaseDC(GetDesktopWindow, DCDesk);
{Release a bitmap}
bmp.Free;
end;
{---------------------3---------------------}
{
If you will try to capture the screen to bitmap using BitBlt function
and have a layered (transparent) window visible,
you will get only a picture of the screen without this window.
To fix it we have to use the new raster-operation code for BitBlt
function CAPTUREBLT that introduced in Windows 2000 for including
any windows that are layered on top of your window in the resulting image.
}
procedure CaptureScreen(AFileName: string);
const
CAPTUREBLT = $40000000;
var
hdcScreen: HDC;
hdcCompatible: HDC;
bmp: TBitmap;
hbmScreen: HBITMAP;
begin
// Create a normal DC and a memory DC for the entire screen. The
// normal DC provides a "snapshot" of the screen contents. The
// memory DC keeps a copy of this "snapshot" in the associated
// bitmap.
hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
hdcCompatible := CreateCompatibleDC(hdcScreen);
// Create a compatible bitmap for hdcScreen.
hbmScreen := CreateCompatibleBitmap(hdcScreen,
GetDeviceCaps(hdcScreen, HORZRES),
GetDeviceCaps(hdcScreen, VERTRES));
// Select the bitmaps into the compatible DC.
SelectObject(hdcCompatible, hbmScreen);
bmp := TBitmap.Create;
bmp.Handle := hbmScreen;
BitBlt(hdcCompatible,
0, 0,
bmp.Width, bmp.Height,
hdcScreen,
0, 0,
SRCCOPY or CAPTUREBLT);
bmp.SaveToFile(AFileName);
bmp.Free;
DeleteDC(hdcScreen);
DeleteDC(hdcCompatible);
end;
