Mega Code Archive
Capturing of the assigned area with mouse button event
<![CDATA[
Title: Capturing of the assigned area with mouse button event
Question: How to capture assigned area with mouse button event?
Answer:
if you want to capture on any desktop area by clicking mouse left button in its client area then add two TImage, TTimer, TLabel, TCheckBox and TButton components to the form.
Here is code;
-------------
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
AppEvnts, Buttons, Jpeg, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Button1: TButton;
Label1: TLabel;
Timer1: TTimer;
CheckBox1: TCheckBox;
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
MHookGo : Boolean;
public
end;
var
Form1: TForm1;
MHook: THandle;
implementation
{$R *.DFM}
function JournalProc(Code, wParam: Integer; var EventW: TEventMsg): Integer; stdcall;
label go, jump;
var
s, tm: string;
JPGFile: TJPEGImage;
a1, p: integer;
Ad, s1, s2, s3: string;
begin
Result := CallNextHookEx(MHook, Code, wParam, Longint(@EventW));
if Code if Code = HC_SYSMODALON then Exit;
if Code = HC_ACTION then
begin
s := '';
if EventW.message = WM_LBUTTONDOWN then // mouse left button pressed
begin
JPGFile := TJPEGImage.Create;
s := 'Mouse coordinates: X: '
+ IntToStr(EventW.paramL)
+ ' Y: ' + IntToStr(EventW.paramH);
Form1.image2.Picture := Form1.Image1.Picture;
if Form1.CheckBox1.Checked = True then
begin
JPGFile.Assign(Form1.Image2.Picture.Bitmap);
{ as a file name will use current time.
Therefore, For file name, converting : character to . character }
tm := DateTimeToStr(Now);
go:
Ad := tm;
a1 := Length(Ad);
p := Pos(':', Ad);
if p = 0 then
begin
goto jump;
end
else
begin
s1 := Copy(Ad, 1, p);
s2 := Copy(Ad, (p + 1), (a1 - p));
end;
s1 := Copy(Ad, 1, p - 1);
s3 := s1 + '.' + s2;
tm := s3;
goto go;
jump:
JPGFile.SaveToFile(s3 + '.jpg'); // saved into the same folder
end;
end;
if s '' then Form1.Label1.Caption := s;
end;
end;
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
// if Ctrl-Alt-Del or Ctrl-Esc pressed then journal hook will be disable
Handled := False;
if (Msg.message = WM_CANCELJOURNAL) and MHookGo then
MHook := SetWindowsHookEx(WH_JOURNALRECORD, @JournalProc, 0, 0);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var Asn1, Asn2, Asn3: TRect;
aWidth, aHeight: Integer;
aMusX, aMusY: Real;
Cv: TCanvas;
Crs: TPoint;
begin
if not IsIconic(Application.Handle) then
begin
GetCursorPos(Crs);
Asn3 := Rect(Form1.Left,Form1.Top, Form1.Left
+ Form1.Width, Form1.Top
+ Form1.Height);
if not PtInRect(Asn3, Crs) then
begin
aWidth := Image1.Width;
aHeight := Image1.Height;
Asn2 := Rect(0, 0, aWidth, aHeight);
// captured area proportions - you can change it
aMusX := aWidth / (1 * 2);
aMusY := aHeight / (1 * 2);
Asn1 := Rect(Crs.x, Crs.y, Crs.x, Crs.y);
InflateRect(Asn1, Round(aMusX), Round(aMusY));
if Asn1.Left if Asn1.Top if Asn1.Right Screen.Width then
OffsetRect(Asn1, - (Asn1.Right - Screen.Width), 0);
if Asn1.Bottom Screen.Height then
OffsetRect(Asn1, 0, - (Asn1.Bottom - Screen.Height));
Cv := TCanvas.Create;
try
Cv.Handle := GetDC(GetDesktopWindow);
Image1.Canvas.CopyRect(Asn2, Cv, Asn1);
finally
Cv.Free;
end;
Application.ProcessMessages;
end;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// unhook closing
if MHookGo then UnhookWindowsHookEx(MHook);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Caption := 'Mouse coordinates:';
CheckBox1.Caption := 'Start for Capture area';
if MHookGo then Exit; // Mouse Journaled absent
MHook := SetWindowsHookEx(WH_JOURNALRECORD, @JournalProc, hInstance, 0);
// Hook starting
if MHook 0 then MHookGo := True
else Exit; // Journal Hook absent
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// disable hook
MHookGo := False;
UnhookWindowsHookEx(MHook);
MHook := 0;
Label1.Caption := '';
end;
end.
]]>