Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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.
- unit screenShowClassEx;
- {$mode objfpc}{$H+}
- interface
- uses
- Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
- windows, ssockets;
- type
- { TMyServer }
- TMyServer=class(TInetServer)
- public
- end;
- { TMyServer }
- { TForm1 }
- TForm1 = class(TForm)
- Button1: TButton;
- Image1: TImage;
- procedure Button1Click(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- private
- public
- end;
- var
- Form1: TForm1;
- implementation
- {$R *.lfm}
- procedure receiveImage();
- var
- Server: TInetServer;
- Bmp: Graphics.TBitmap;
- JpegImage: TJpegImage;
- begin
- Server := TMyServer.Create('loopback', 4800);
- showmessage('ok i am receiving now');
- while true do
- begin
- Server.StartAccepting;
- // show image on imagebox where Image1 :Timage
- JpegImage.Assign(Bmp);
- Form1.Image1.Canvas.Draw(0,0,JpegImage);
- end;
- end;
- { TForm1 }
- procedure TForm1.Button1Click(Sender: TObject);
- begin
- receiveImage();
- end;
- procedure TForm1.FormCreate(Sender: TObject);
- begin
- end;
- end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement