unit ScreenCapClassEx;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ssockets ,windows;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
FAbort: Boolean;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure DrawCursor (ACanvas:TCanvas; Position:TPoint) ;
var
HCursor : THandle;
begin
HCursor := GetCursor;
DrawIconEx(ACanvas.Handle, Position.X, Position.Y,
HCursor, 32, 32, 0, 0, DI_NORMAL) ;
end;
function CaptureWindow(const WindowHandle: HWnd): Graphics.TBitmap;
var
DC: HDC;
wRect: TRect;
CurPos: TPoint;
begin
DC := GetWindowDC(WindowHandle);
Result := Graphics.TBitmap.Create;
Result.PixelFormat := pf32bit;
try
GetWindowRect(WindowHandle, wRect);
Result.Width := wRect.Right - wRect.Left;
Result.Height := wRect.Bottom - wRect.Top;
BitBlt(Result.Canvas.Handle,
0,
0,
Result.Width,
Result.Height,
DC,
0,
0,
SRCCOPY);
GetCursorPos(CurPos);
DrawCursor(Result.Canvas, CurPos);
finally
ReleaseDC(WindowHandle, DC);
end;
end;
procedure DoCapture;
var
Socket: TInetSocket;
Bmp: Graphics.TBitmap;
FAbort: Boolean;
begin
{ Create the socket now and free it only when you're done with it}
Socket:= TInetSocket.Create('loopback',4800);
try
{ You need some "scape". Infinite loops are ... bad }
while (not FAbort) and (not Application.Terminated) do begin
Bmp := CaptureWindow(GetDesktopWindow);
try
Bmp.Canvas.Changed;
Socket.Write(Bmp,1000553);
finally
{If you don't do this, you'll consume all the memory}
Bmp.Free;
end;
Application.ProcessMessages;
end;
finally
Socket.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Assigned(Sender) and Sender.InheritsFrom(TControl) then begin
{ Use the button to start/stop capture,
using the button's Tag as a flag to know in which mode we are. }
if (Sender as TControl).Tag < 0 then begin
FAbort := True;
(Sender as TControl).Caption := '&Start capture';
(Sender as TControl).Tag := 0;
end else begin
FAbort := False;
(Sender as TControl).Caption := '&Stop capture';
(Sender as TControl).Tag := -1;
end;
DoCapture;
end;
end;
end.