屏幕传输ScreenSpy.pas单元加光标版

最新推荐文章于 2016-12-21 16:14:10 发布

sooven

最新推荐文章于 2016-12-21 16:14:10 发布

阅读量536

点赞数

分类专栏： delphi 其它文章标签： function destructor integer constructor byte cmd

delphi 其它专栏收录该内容

1 篇文章 0 订阅

订阅专栏

屏幕传输ScreenSpy.pas单元原本传输的屏幕图像中没有看见鼠标，小的只是加多了个可以看见鼠标进去，呵呵。

unit ScreenSpy;

interface

uses
Windows, Classes, Variants, SysUtils, Graphics, Controls, Math, OverbyteIcsWSocket, Clipbrd, ZLibEx;

const
DEF_STEP = 23;
OFF_SET = 24;

type
PCapCmd = ^TCapCmd;
TCapCmd = packed record
    Cmd:    Byte;
    Size:   Integer;
    Width: Word;
    Height: Word;
end;

PCtlCmd = ^TCtlCmd;
TCtlCmd = packed record
Cmd: Byte;
X, Y: Word;
end;

TScreenSpy = class(TThread)
private
    FScrStream: TMemoryStream;
    FSendStream: TMemoryStream;
    FFullBmp, FLineBmp, FRectBmp: TBitmap;
    FWidth, FHeight, FLine: Integer;
    FRect: TRect;
    FSocket: TWSocket;
    FCmd: TCapCmd;
    vCursor:HCURSOR;
    vDC:HDC;
    //
    function CheckScr: Boolean;
    function GetFirst: Boolean;
    function GetNext: Boolean;
    function Compress: Boolean;
    function SendInfo: Boolean;
    function SendData: Boolean;
    procedure CopyRect(rt: TRect);
protected
    procedure Execute; override;
public
    constructor Create(ASocket: TWSocket); reintroduce;
    destructor Destroy; override;
end;

implementation

constructor TScreenSpy.Create(ASocket: TWSocket);
begin
FreeOnTerminate := True;
FSocket := ASocket;
FScrStream := TMemoryStream.Create;
FSendStream := TMemoryStream.Create;
FFullBmp := TBitmap.Create;
FLineBmp := TBitmap.Create;
FRectBmp := TBitmap.Create;
FWidth := 0;
FHeight := 0;
inherited Create(True);
end;

destructor TScreenSpy.Destroy;
begin
FScrStream.Free;
FSendStream.Free;
FRectBmp.Destroy;
FFullBmp.Destroy;
FLineBmp.Destroy;
inherited Destroy;
end;

procedure TScreenSpy.Execute;
begin
while (not Terminated) and (FSocket.State = wsConnected) do
begin
if CheckScr then GetFirst else GetNext;
end;
end;

function TScreenSpy.CheckScr: Boolean;
var
nWidth, nHeight: Integer;
begin
Result := False;
nWidth := GetSystemMetrics(SM_CXSCREEN);
nHeight := GetSystemMetrics(SM_CYSCREEN);
if (nWidth <> FWidth) or (nHeight <> FHeight) then
begin
    FWidth := nWidth;
    FHeight := nHeight;
    FFullBmp.Width := FWidth;
    FFullBmp.Height := FHeight;
    FLineBmp.Width := FWidth;
    FLineBmp.Height := 1;
    FFullBmp.PixelFormat := pf15bit;
    FLineBmp.PixelFormat := pf15bit;
    FRectBmp.PixelFormat := pf15bit;
    FLine := 0;
    Result := True;
end;
end;

function TScreenSpy.GetFirst: Boolean;
begin
SetCursor(LoadCursor(0,IDC_ARROW));
vCursor:=GetCursor;
vDC:=GetDC(0);
FFullBmp.Canvas.Lock;
BitBlt(FFullBmp.Canvas.Handle, 0, 0, FWidth, FHeight, vDC, 0, 0, SRCCOPY);
DrawIcon(FFullBmp.Canvas.Handle,Mouse.CursorPos.X,Mouse.CursorPos.Y,vCursor);
FFullBmp.Canvas.Unlock;
ReleaseDC(0, vDC);
SetRect(FRect, 0, 0, FWidth, FHeight);
FScrStream.Clear;
FScrStream.WriteBuffer(FRect, SizeOf(TRect));
FFullBmp.SaveToStream(FScrStream);
Result := Compress;
if Result then
begin
SendInfo;
Result := SendData;
end;
end;

procedure TScreenSpy.CopyRect(rt: TRect);
begin
FFullBmp.Canvas.Lock;
FRectBmp.Canvas.Lock;
try
    SetCursor(LoadCursor(0,IDC_ARROW));
    vCursor:=GetCursor;
    vDC:=GetDC(0);
    FRectBmp.Width := rt.Right - rt.Left;
    FRectBmp.Height := rt.Bottom - rt.Top;
    BitBlt(FFullBmp.Canvas.Handle, rt.Left, rt.Top, FRectBmp.Width, FRectBmp.Height, vDC, rt.Left, rt.Top, SRCCOPY);
    DrawIcon(FFullBmp.Canvas.Handle,Mouse.CursorPos.X,Mouse.CursorPos.Y,vCursor);
    BitBlt(FRectBmp.Canvas.Handle, 0, 0, FRectBmp.Width, FRectBmp.Height, FFullBmp.Canvas.Handle, rt.Left, rt.Top, SRCCOPY);
    FScrStream.WriteBuffer(FRect, SizeOf(TRect));
    FRectBmp.SaveToStream(FScrStream);
finally
    FFullBmp.Canvas.Unlock;
    FRectBmp.Canvas.Unlock;
end;
end;

function TScreenSpy.GetNext: Boolean;
var
p1, p2: PDWORD;
i, j: Integer;
begin
Result := False;
FScrStream.Clear;
vCursor:=GetCursor;
vDC:=GetDC(0);
i := FLine;
FLineBmp.Canvas.Lock;
while i < FHeight do
begin
    BitBlt(FLineBmp.Canvas.Handle, 0, 0, FWidth, 1, vDC, 0, i, SRCCOPY);
    DrawIcon(FLineBmp.Canvas.Handle,Mouse.CursorPos.X,Mouse.CursorPos.Y,vCursor);
    p1 := FFullBmp.ScanLine[i];
    p2 := FLineBmp.ScanLine[0];
    SetRect(FRect, -1, Max(i - DEF_STEP, 0), -1, Min(i + DEF_STEP * 2, FHeight));
    j := 0;
    while j < FWidth do
    begin
      if (p1^ <> p2^) then
      begin
        if (FRect.Right < 0) then FRect.Left := Max(j - OFF_SET, 0);
        FRect.Right := Min(j + OFF_SET, FWidth);
      end;
      Inc(p1);
      Inc(p2);
      Inc(j, 2);
    end;
    if (FRect.Right > -1) then
    begin
      CopyRect(FRect);
      SetRect(FRect, -1, -1, -1, -1);
      Inc(i, DEF_STEP);
    end;
    Inc(i, DEF_STEP);
end;
FLineBmp.Canvas.Unlock;
FLine := (FLine + 3) mod DEF_STEP;
if FScrStream.Position > 0 then
begin
    Result := Compress;
    if Result then Result := SendData;
end;
ReleaseDC(0, vDC);
Sleep(30);
end;

function TScreenSpy.Compress: Boolean;
begin
Result := False;
try
    FSendStream.Clear;
    FScrStream.Position := 0;
    ZCompressStream(FScrStream, FSendStream);
    FSendStream.Position := 0;
    Result := True;
except
end;
end;

function TScreenSpy.SendInfo: Boolean;
begin
try
    FCmd.Cmd := 1;
    FCmd.Size := 0;
    FCmd.Width := FWidth;
    FCmd.Height := FHeight;
    FSocket.Send(@FCmd, SizeOf(TCapCmd));
    Result := True;
except
    Result := False;
end;
end;

function TScreenSpy.SendData: Boolean;
begin
try
    FCmd.Cmd := 2;
    FCmd.Size := FSendStream.Size;
    FSocket.Send(@FCmd, SizeOf(TCapCmd));
    FSocket.Send(FSendStream.Memory, FSendStream.Size);
    Result := True;
except
    Result := False;
end;
end;

end.