unit ScreenShotForm;
{$mode objfpc}{$H+}
interface
uses
SysUtils,
Classes, Forms, Controls, Graphics, Dialogs, Buttons,
StdCtrls, Types, LCLIntf, LCLType;
type
{ TfrmScreenShot }
TfrmScreenShot = class(TForm)
BClose: TBitBtn;
LDirections: TLabel;
procedure BCloseClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
private
FScreenshot: TBitmap;
FMakingSelection: boolean;
FSelectionMade: boolean;
FSelectionRect: TRect;
procedure SaveSelectedRegion;
function GetScreenshot: TBitmap;
end;
var
SelectedRegionFilename : string;
var
frmScreenShot: TfrmScreenShot;
implementation
{$R *.lfm}
{ TfrmScreenShot }
procedure TfrmScreenShot.FormCreate(Sender: TObject);
begin
frmScreenShot.Top := 0;
frmScreenShot.Left :=0;
BorderStyle:=bsNone;
WindowState:=wsFullScreen;
FScreenshot:=GetScreenshot;
Canvas.Pen.Color:=clRed;
frmScreenShot.Cursor := crCross;
end;
procedure TfrmScreenShot.BCloseClick(Sender: TObject);
begin
end;
procedure TfrmScreenShot.FormDestroy(Sender: TObject);
begin
frmScreenShot.Cursor := crDefault;
FScreenshot.Free;
end;
procedure TfrmScreenShot.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FMakingSelection:=True;
FSelectionRect.Left:=X;
FSelectionRect.Top:=Y;
end;
procedure TfrmScreenShot.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FMakingSelection then begin
FSelectionRect.Right:=X;
FSelectionRect.Bottom:=Y;
Repaint;
end;
end;
procedure TfrmScreenShot.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if FMakingSelection then begin
FMakingSelection:=False;
FSelectionMade:=True;
Repaint;
SaveSelectedRegion;
Close;
end;
end;
procedure TfrmScreenShot.FormPaint(Sender: TObject);
begin
if Assigned(FScreenshot) then
Canvas.Draw(0, 0, FScreenshot);
if FMakingSelection and not IsRectEmpty(FSelectionRect) then
Canvas.DrawFocusRect(FSelectionRect);
if FSelectionMade then with Canvas do begin
Frame(FSelectionRect);
FSelectionMade:=False;
end;
end;
function TfrmScreenShot.GetScreenshot: TBitmap;
var
screenDC: HDC;
begin
screenDC:=GetDC(0);
try
Result:=TBitmap.Create;
Result.LoadFromDevice(screenDC);
finally
ReleaseDC(0, screenDC);
end;
end;
procedure Bmp2Jpeg(bitMio:TBitmap; JpgFileName: string);
var
Bmp: TBitmap;
Jpg: TJPEGImage;
begin
Bmp := TBitmap.Create;
Jpg := TJPEGImage.Create;
try
Bmp := bitMio;
Jpg.Assign(Bmp);
Jpg.SaveToFile(JpgFileName);
finally
Jpg.Free;
Bmp.Free;
end;
end;
procedure TfrmScreenShot.SaveSelectedRegion;
var
bmp: TBitmap;
r: TRect;
sz: TSize;
begin
if IsRectEmpty(FSelectionRect) then
Exit;
sz:=Size(FSelectionRect);
r:=Rect(0, 0, sz.cx, sz.cy);
bmp:=TBitmap.Create;
try
bmp.SetSize(sz.cx, sz.cy);
bmp.Canvas.CopyRect(r, Canvas, FSelectionRect);
SelectedRegionFilename := ExtractFilePath(ParamStr(0)) + 'temp';
Bmp2Jpeg(bmp, SelectedRegionFilename+'.jpg');
finally
FSelectionRect:=Rect(0, 0, 0, 0);
// bmp.Free;
end;
end;
end.