远程截屏的一个控件源码(来自Torry，FreeWare)(0分)

unit ScrSpy;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
BufferUDP;

Type
TScreenBlock= record
BlockIndex: Integer;
BMP: TBitmap;
ptr: Pointer;
Bound: TRect;
end;

type
TScreenSpyBitmapEvent = procedure(Sender: TObject; const Block: TScreenBlock; LastScanline: Pointer; IsIFrame: Boolean) of object;
TFrameStartEvent = procedure(Sender: TObject; const FrameCount: Cardinal; const IsIFrame: Boolean) of object;
TFrameEndEvent = procedure(Sender: TObject; const FrameCount: Cardinal; const IsIFrame: Boolean; const HasBitmapEvent: Boolean) of object;

TScreenSpy = class;
EScrSpy = Exception;

TScreenSpyThread = class(TThread)
private
// Properties
FScreenSpy: TScreenSpy;
// Golbal variable
SBIndex: Integer; // ScreenBitmaps' Index
IsIFrame: Boolean;
TCWhenCapture: Cardinal;
protected
Procedure CaptureScreen; Virtual;
procedure ScreenBitmap;
Procedure FrameStart;
Procedure FrameEnd;
procedure Execute; override;
property ScreenSpy: TScreenSpy read FScreenSpy write FScreenSpy;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;

TScreenSpy = class(TComponent)
private
{ Private declarations }
// Properties
FIFrame: Cardinal;
FActive: Boolean;
FThreadPriority: TThreadPriority;
FScreenCanvas: TCanvas;
FScreenWidth: Word;
FScreenHeight: Word;
FBytesPerPixel: Byte;
FPixelFormat: TPixelFormat;
FMaxFrameRate: Byte;
FMaxBlockSize: Integer;
FBlockRowCount: Integer;
FBlockColumnCount: Integer;
FBlockCount: Integer;
FBlockWidth: Integer;
FBlockHeight: Integer;
FBlockSize: Integer;
FBlockBound: TRect; // Block size = (0, 0, BWidth, BHeight)
FFrameCount: Cardinal;
// Events
FOnScreenBitmap: TScreenSpyBitmapEvent;
FOnFrameStart: TFrameStartEvent;
FOnFrameEnd: TFrameEndEvent;
// Golbal private Variables
HasBitmapEvent: Boolean;
MaxDelayMilliseconds: Cardinal;
ScreenBitmaps: array of TScreenBlock;
LastScreen: array of Pointer;
BMPBlockSize: Integer; // Size of Bitmap for one block
MemoryAllowcated: Boolean;
SCThread: TScreenSpyThread;
Procedure SetActive(const Value: Boolean);
Procedure SetThreadPriority(const Value: TThreadPriority);
Procedure SetMaxBlockSize(const Value: Integer);
Procedure SetMaxFrameRate(const Value: Byte);
Procedure SetIFrame(const Value: Cardinal);
protected
{ Protected declarations }
procedure CalculateScreenData;
procedure ReleaseScreenData;
procedure DoScreenBitmap(ScreenBitmapIndex: Integer; IsIFrame: Boolean);
procedure DoFrameStart(const IsIFrame: Boolean);
procedure DoFrameEnd(const IsIFrame: Boolean);
public
{ Public declarations }
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Property ScreenCanvas: TCanvas read FScreenCanvas;
Property ScreenWidth: Word read FScreenWidth;
Property ScreenHeight: Word read FScreenHeight;
Property BytesPerPixel: Byte read FBytesPerPixel;
Property PixelFormat: TPixelFormat read FPixelFormat;
Property BlockCount: Integer read FBlockCount;
Property BlockRowCount: Integer read FBlockRowCount;
Property BlockColumnCount: Integer read FBlockColumnCount;
Property BlockWidth: Integer read FBlockWidth;
Property BlockHeight: Integer read FBlockHeight;
Property BlockSize: Integer read FBlockSize;
Property BlockBound: TRect read FBlockBound;
Property FrameCount: Cardinal read FFrameCount;
published
{ Published declarations }
Property OnScreenBitmap: TScreenSpyBitmapEvent read FOnScreenBitmap write FOnScreenBitmap;
Property OnFrameStart: TFrameStartEvent read FOnFrameStart write FOnFrameStart;
Property OnFrameEnd: TFrameEndEvent read FOnFrameEnd write FOnFrameEnd;
Property IFrame: Cardinal read FIFrame write SetIFrame default 30;
Property ThreadPriority: TThreadPriority read FThreadPriority write SetThreadPriority default tpNormal;
Property MaxBlockSize: Integer read FMaxBlockSize write SetMaxBlockSize default 30000;
Property MaxFrameRate: Byte read FMaxFrameRate write SetMaxFrameRate default 10;
Property Active : Boolean read FActive write SetActive default False;
end;

TSFastRLE = class(TObject)
private
t, s: Pointer;
function PackSeg(Source, Target: Pointer; SourceSize: Word): Word;
function UnPackSeg(Source, Target: Pointer; SourceSize: Word): Word;
protected
public
Constructor Create;
Destructor Destroy; override;
function Pack(Source, Target: Pointer; SourceSize: LongInt): LongInt; { Return TargetSize }
function UnPack(Source, Target: Pointer; SourceSize: LongInt): LongInt; {Return TargetSize }
function PackString(Source: String): String;
function UnPackString(Source: String): String;
function PackFile(SourceFileName, TargetFileName: String): Boolean; { Return FALSE if IOError }
function UnPackFile(SourceFileName, TargetFileName: String): Boolean; { Return FALSE if IOError }
end;

{ Protocol }
Const
RID_Invalid = $00;
RID_Header = $02;
RID_Block = $04;
RID_FrameStart = $06;
RID_FrameEnd = $08;
RID_MousePos = $0A;
RID_Start = $0C;
RID_Stop = $0E;

type
TRID = Word;
TRSize = Cardinal;
TScreenDataStyle = (sdsUncompress, sdsRLENormal, sdsRLEXor);

Type // Data type for transmission pack
TftAny= Packed Record
dwSize: TRSize;
PackID : TRID;
Data: Array [0..0] of Byte;
End;
PftAny= ^TftAny;

TftHeader= Packed Record
dwSize: TRSize;
PackID : TRID;
ScreenWidth: Word;
ScreenHeight: Word;
BytesPerPixel: Byte;
BlockWidth: Word;
BlockHeight: Word;
End;
PftHeader = ^TftHeader;

TftBlock = Packed Record
dwSize: TRSize;
PackID: TRID;
BlockIndex: Cardinal;
FrameStyle: TScreenDataStyle;
Data: Array [0..0] of Byte;
End;
PftBlock = ^TftBlock;

TftFrameStart = Packed Record
dwSize: TRSize;
PackID: TRID;
FrameCount: Cardinal;
IsIFrame: Boolean;
End;
PftFrameStart = ^TftFrameStart;

TftFrameEnd = Packed Record
dwSize: TRSize;
PackID: TRID;
FrameCount: Cardinal;
IsIFrame: Boolean;
HasBitmapEvent: Boolean;
End;
PftFrameEnd = ^TftFrameEnd;

Const
SizeOfTftBlock = SizeOf(TftBlock);
SizeOfTftHeader = SizeOf(TftHeader);
SizeOfTftFrameStart = SizeOf(TftFrameStart);
SizeOfTftFrameEnd = SizeOf(TftFrameEnd);


{ TScreen Transfer}
Type
TScreenEncoder = class(TComponent)
private
{ Private declarations }
// Properties
FActive : Boolean;
FBlockDelay : Cardinal;
FBlockInterval: Cardinal;
FIFrameDelay: Cardinal;
// Events
FOnFrameStart: TFrameStartEvent;
FOnFrameEnd: TFrameEndEvent;
// Golbal variables
FScreenSpy : TScreenSpy;
FUDPSender : TUDPSender;
FSFastRLE : TSFastRLE;
XorDataPtr: array [1..4] of Pointer; // MAX 4 bytes per pixel
RHeader : TftHeader;
RFrameStart: TftFrameStart;
RFrameEnd: TftFrameEnd;
Blockptr: PftBlock;
BlockIntervalCount: Cardinal;
function GetIFrame: Cardinal;
function GetMaxBlockSize: Integer;
function GetMaxFrameRate: Byte;
function GetThreadPriority: TThreadPriority;
procedure SetActive(Value: Boolean);
procedure SetIFrame(const Value: Cardinal);
procedure SetMaxBlockSize(const Value: Integer);
procedure SetMaxFrameRate(const Value: Byte);
procedure SetThreadPriority(const Value: TThreadPriority);
function GetRemoteHost: String;
function GetRemoteIP: String;
function GetRemotePort: Word;
procedure SetRemoteHost(const Value: String);
procedure SetRemoteIP(const Value: String);
procedure SetRemotePort(const Value: Word);
procedure SetBlockDelay(const Value: Cardinal);
procedure SetBlockInterval(const Value: Cardinal);
procedure SetIFrameDelay(const Value: Cardinal);
protected
{ Protected declarations }
procedure ScreenSpyOnScreenBitmap(Sender: TObject; const Block: TScreenBlock; LastScanline: Pointer; IsIFrame: Boolean);
procedure ScreenSpyOnFrameStart(Sender: TObject; const FrameCount: Cardinal; const IsIFrame: Boolean);
procedure ScreenSpyOnFrameEnd(Sender: TObject; const FrameCount: Cardinal; const IsIFrame: Boolean; const HasBitmapEvent: Boolean);
Procedure SendHeader;
procedure DoFrameStart(const FrameCount: Cardinal; const IsIFrame: Boolean); virtual;
procedure DoFrameEnd(const FrameCount: Cardinal; const IsIFrame: Boolean; const HasBitmapEvent: Boolean); virtual;
public
{ Public declarations }
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
published
{ Published declarations }
Property OnFrameStart: TFrameStartEvent read FOnFrameStart write FOnFrameStart;
Property OnFrameEnd: TFrameEndEvent read FOnFrameEnd write FOnFrameEnd;
Property BlockInterval: Cardinal read FBlockInterval write SetBlockInterval default 10;
Property BlockDelay: Cardinal read FBlockDelay write SetBlockDelay default 1;
Property IFrameDelay: Cardinal read FIFrameDelay write SetIFrameDelay default 100;
Property IFrame: Cardinal read GetIFrame write SetIFrame;
Property ThreadPriority: TThreadPriority read GetThreadPriority write SetThreadPriority;
Property MaxBlockSize: Integer read GetMaxBlockSize write SetMaxBlockSize;
Property MaxFrameRate: Byte read GetMaxFrameRate write SetMaxFrameRate;
property RemoteIP: String read GetRemoteIP write SetRemoteIP;
property RemoteHost: String read GetRemoteHost write SetRemoteHost;
property RemotePort: Word read GetRemotePort write SetRemotePort;
Property Active : Boolean read FActive write SetActive default False;
end;

TScreenPlayerBitmapEvent = procedure(Sender: TObject; const Block: TScreenBlock) of object;
TScreenPlayer = class(TComponent)
private
{ Private declarations }
// Properties
FScreenWidth: Word;
FScreenHeight: Word;
FBytesPerPixel: Byte;
FPixelFormat: TPixelFormat;
FBlockRowCount: Integer;
FBlockColumnCount: Integer;
FBlockCount: Integer;
FBlockWidth: Integer;
FBlockHeight: Integer;
FBlockSize: Integer;
// Events
FOnScreenBitmap: TScreenPlayerBitmapEvent;
FOnHeaderUpdate: TNotifyEvent;
FOnFrameEnd: TFrameEndEvent;
FOnFrameStart: TFrameStartEvent;
// Golbal Variables
FUDPReceiver : TUDPReceiver;
FSFastRLE : TSFastRLE;
XorDataPtr: array [1..4] of Pointer; // MAX 4 bytes per pixel
ScreenBitmaps: array of TScreenBlock;
BMPBlockSize: Integer; // Size of Bitmap for one block
MemoryAllowcated: Boolean;
Header: TftHeader;
AnyPtr: PftAny;
BlockPtr: PftBlock;
FrameStartPtr: PftFrameStart;
FrameEndPtr: PftFrameEnd;
function GetActive: Boolean;
function GetMulticastIP: String;
function GetPort: Word;
procedure SetActive(const Value: Boolean);
procedure SetMulticastIP(const Value: String);
procedure SetPort(const Value: Word);
protected
{ Protected declarations }
procedure CalculateScreenData; virtual;
procedure ReleaseScreenData; virtual;
procedure DoScreenBitmap(ScreenBitmapIndex: Integer); virtual;
procedure DoHeaderUpdate;
procedure UDPReceiverOnUDPData(Sender: TObject; const Buffer: Pointer; const RecvSize:Integer; const Peer: string; const Port: Integer); virtual;
public
{ Public declarations }
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Property ScreenWidth: Word read FScreenWidth;
Property ScreenHeight: Word read FScreenHeight;
Property BytesPerPixel: Byte read FBytesPerPixel;
Property PixelFormat: TPixelFormat read FPixelFormat;
Property BlockCount: Integer read FBlockCount;
Property BlockRowCount: Integer read FBlockRowCount;
Property BlockColumnCount: Integer read FBlockColumnCount;
Property BlockWidth: Integer read FBlockWidth;
Property BlockHeight: Integer read FBlockHeight;
Property BlockSize: Integer read FBlockSize;
published
{ Published declarations }
Property OnScreenBitmap: TScreenPlayerBitmapEvent read FOnScreenBitmap write FOnScreenBitmap;
Property OnHeaderUpdate: TNotifyEvent read FOnHeaderUpdate write FOnHeaderUpdate;
Property OnFrameStart: TFrameStartEvent read FOnFrameStart write FOnFrameStart;
Property OnFrameEnd: TFrameEndEvent read FOnFrameEnd write FOnFrameEnd;
property Port: Word read GetPort write SetPort;
property MulticastIP: String read GetMulticastIP write SetMulticastIP;
property Active: Boolean read GetActive write SetActive default False;
end;

procedure Register;

resourcestring
ESSACTIVED = 'Connot perform this action while component is in active!';
ESSINVALIDVALUE = 'Invalid value assigned!';
implementation

procedure Register;
begin
RegisterComponents('Samson', [TScreenSpy, TScreenEncoder, TScreenPlayer]);
end;

{ TScreenSpy }

procedure TScreenSpy.CalculateScreenData;
// e.g.: ANumber = 800, MaxRoot = 21; Result = 20 (800 mod 20=0)
Function MultiRoot(ANumber, MaxRoot: Cardinal): Cardinal;
Begin
If MaxRoot>0 then
While (ANumber mod MaxRoot)<>0 do
MaxRoot:= MaxRoot-1;
Result:= MaxRoot;
End;
// e.g.: ANumber = 800, MinRoot=20, MaxRoot = 41; Result = 40 (800 mod 40=0)
Function MaxRootOf(ANumber, MinRoot, MaxRoot: Cardinal): Cardinal;
Begin
If (MaxRoot>0) and (MinRoot>0) then
While ((ANumber mod MaxRoot)<>0) and (MaxRoot>=MinRoot) do
MaxRoot:= MaxRoot-1;

If MaxRoot>=MinRoot then
Result:= MaxRoot
Else
Result:= 0; // not found
End;
Var
i: Integer;
BitsPerPixel: Integer;
begin
If MemoryAllowcated then
ReleaseScreenData;
MemoryAllowcated:= True;

// Find system information for screen
// Get ready to capture screen
FScreenCanvas.Handle:= GetDC(0);
// Get All information about screen
FScreenWidth:= Screen.Width;
FScreenHeight:= Screen.Height;
BitsPerPixel := GetDeviceCaps(ScreenCanvas.Handle, BITSPIXEL);
Case BitsPerPixel of
8 :
Begin
FBytesPerPixel:= 1;
FPixelFormat:= pf8bit;
End;
16:
Begin
FBytesPerPixel:= 2;
FPixelFormat:= pf16bit;
End;
24:
Begin
FBytesPerPixel:= 3;
FPixelFormat:= pf24bit;
End;
32:
Begin
FBytesPerPixel:= 4;
FPixelFormat:= pf32bit;
End;
Else
Begin
FBytesPerPixel:= 3;
FPixelFormat:= pf24bit;
End;
End;{CASE}

// Calculate Block information
// Max block area for avaliable block size
i:= FMaxBlockSize div FBytesPerPixel;
FBlockHeight:= Trunc(sqrt(i));
FBlockHeight:= MultiRoot(ScreenHeight, FBlockHeight);
FBlockWidth:= i div FBlockHeight;
FBlockWidth:= MultiRoot(ScreenWidth, FBlockWidth);
FBlockHeight:= MaxRootOf(ScreenHeight, FBlockHeight, i div FBlockWidth);
FBlockSize:= BlockWidth * FBlockHeight;
BMPBlockSize := BlockSize * BytesPerPixel;
FBlockColumnCount:= FScreenWidth div FBlockWidth;
FBlockRowCount:= FScreenHeight div FBlockHeight;
FBlockCount:= FBlockColumnCount * FBlockRowCount;

// Re-Allocate memory
// Create off-screen memory for store last screen
SetLength(LastScreen, BlockCount);
For i:=0 to BlockCount-1 do
Begin
GetMem(LastScreen, BMPBlockSize);
FillChar(LastScreen^, BMPBlockSize, $0);
End;

// Get buffer for send-data
// GetMem(ScreenBlockPtr, SizeOf(TScreenBlock)+BMPBlockSize+8);
//ScreenBlockPtr^.UNID:= 0; // In fact it is a user defined value
//ScreenBlockDataPtr:= @(ScreenBlockPtr^.Data[0]); // Why use it?

FBlockBound:= Rect(0, 0, FBlockWidth, FBlockHeight);
// Create temp bitmap for copy a pice of desktop image
SetLength(ScreenBitmaps, BlockCount);
For i:=0 to BlockCount-1 do
Begin
ScreenBitmaps.BlockIndex:= i;
ScreenBitmaps.Bound:= Rect(0,0,BlockWidth,BlockHeight);
OffsetRect(ScreenBitmaps.Bound, (i mod FBlockColumnCount) * FBlockWidth, (i div FBlockColumnCount) * FBlockHeight);
{ScreenBitmaps.Bound:= Rect((i mod BlockWidth) * BMPBlockWidth, (i div BlockWidth) * BMPBlockHeight,
(i mod BlockWidth) * BMPBlockWidth + BMPBlockWidth, (i div BlockWidth) * BMPBlockHeight + BMPBlockHeight);{}
ScreenBitmaps.BMP:= TBitmap.Create;
With ScreenBitmaps.BMP do
Begin
Width:= BlockWidth;
Height:= BlockHeight;
PixelFormat:= FPixelFormat;
If Cardinal(ScanLine[0])<Cardinal(ScanLine[1]) then
ScreenBitmaps.ptr:= ScanLine[0]
Else
ScreenBitmaps.ptr:= ScanLine[Height-1];
End;
End;
end;

constructor TScreenSpy.Create(AOwner: TComponent);
begin
inherited;
// Init default properties
FMaxBlockSize := 30000;
FMaxFrameRate := 0;
MaxFrameRate := 10;
FIFrame := 30;
FActive:= False;
FThreadPriority:= tpNormal;
FScreenCanvas:= TCanvas.Create;
// Calculate information of screen
MemoryAllowcated:= False;
if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then
CalculateScreenData;
end;

destructor TScreenSpy.Destroy;
begin
Active:= False;
ReleaseScreenData;
FScreenCanvas.Free;
inherited;
end;

procedure TScreenSpy.DoFrameEnd(const IsIFrame: Boolean);
begin
If Assigned(FOnFrameEnd) then
FOnFrameEnd(Self, FrameCount, IsIFrame, HasBitmapEvent);
end;

procedure TScreenSpy.DoFrameStart(const IsIFrame: Boolean);
begin
If Assigned(FOnFrameStart) then
FOnFrameStart(Self, FrameCount, IsIFrame);
end;

procedure TScreenSpy.DoScreenBitmap(ScreenBitmapIndex: Integer;
IsIFrame: Boolean);
begin
If Assigned(FOnScreenBitmap) then
try
FOnScreenBitmap(Self, ScreenBitmaps[ScreenBitmapIndex], LastScreen[ScreenBitmapIndex], IsIFrame);
except
FOnScreenBitmap:= nil;
end;
end;

procedure TScreenSpy.ReleaseScreenData;
Var
i: Integer;
begin
If MemoryAllowcated then
Begin
If FActive then
Raise EScrSpy.CreateRes(@ESSACTIVED);
MemoryAllowcated:= False;
// Do release
ReleaseDC(0, FScreenCanvas.Handle);
For i:=0 to BlockCount-1 do
FreeMem(LastScreen);
SetLength(LastScreen, 0);
For i:=0 to BlockCount-1 do
Begin
ScreenBitmaps.ptr:= nil;
ScreenBitmaps.BMP.Free;
End;
SetLength(ScreenBitmaps, 0);
End;
end;

procedure TScreenSpy.SetActive(const Value: Boolean);
begin
If FActive<>Value then
Begin
FActive:= Value;
If Not (csDesigning in ComponentState) then
Begin
If Value then
Begin
If Not MemoryAllowcated then
CalculateScreenData;
{// Init for new Frame
FFrameCount:= 0;
HasBitmapEvent:= False;{}
SCThread:= TScreenSpyThread.Create;
With SCThread do
Begin
ScreenSpy:= Self;
Priority:= FThreadPriority;
FreeOnTerminate:= True;
Resume;
End;{}
End Else
Begin
SCThread.Terminate;
SCThread.WaitFor;
//FSCThread:= nil;{}
End;
End;
End;
end;

procedure TScreenSpy.SetIFrame(const Value: Cardinal);
begin
If FIFrame<>Value then
Begin
if not (csLoading in ComponentState) and not (csDesigning in ComponentState) and
FActive then
Raise EScrSpy.CreateRes(@ESSACTIVED);
If Value = 0 then
Raise EScrSpy.CreateRes(@ESSINVALIDVALUE);
FIFrame:= Value;
End;
end;

procedure TScreenSpy.SetMaxBlockSize(const Value: Integer);
begin
If FMaxBlockSize<>Value then
Begin
if not (csLoading in ComponentState) and not (csDesigning in ComponentState) and
FActive then
Raise EScrSpy.CreateRes(@ESSACTIVED);

FMaxBlockSize:= Value;

if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then
CalculateScreenData;
End;
end;

procedure TScreenSpy.SetMaxFrameRate(const Value: Byte);
begin
If FMaxFrameRate<>Value then
Begin
if not (csLoading in ComponentState) and not (csDesigning in ComponentState) and
FActive then
Raise EScrSpy.CreateRes(@ESSACTIVED);
If Value = 0 then
Raise EScrSpy.CreateRes(@ESSINVALIDVALUE);
FMaxFrameRate:= Value;
MaxDelayMilliseconds:= 1000 div FMaxFrameRate;
End;
end;

procedure TScreenSpy.SetThreadPriority(const Value: TThreadPriority);
begin
If FThreadPriority<>Value then
Begin
if not (csLoading in ComponentState) and not (csDesigning in ComponentState) and
FActive then
Raise EScrSpy.CreateRes(@ESSACTIVED);
FThreadPriority := Value;
End;
end;

{ TScreenSpyThread }

procedure TScreenSpyThread.CaptureScreen;
Var
i: Integer;
Begin
TCWhenCapture:= GetTickCount;
With FScreenSpy do
Begin
FFrameCount:= FFrameCount + 1;
For i:=0 to BlockCount-1 do
With ScreenBitmaps do
If BMP.Canvas.TryLock then
try
BMP.Canvas.CopyRect(BlockBound, ScreenCanvas, Bound);
finally
BMP.Canvas.Unlock;
end;
End;
end;

constructor TScreenSpyThread.Create;
begin
Inherited Create(True);
end;

destructor TScreenSpyThread.Destroy;
begin
inherited;
end;

procedure TScreenSpyThread.Execute;
Var
// BlockSame: Boolean;
TickCountLag: Integer;
begin
With FScreenSpy do
Begin
SBIndex:= 0;
IsIFrame:= True; // For Hide Complie message
FFrameCount:= 0;
// Init TickCounts
TCWhenCapture:= 0;
While FScreenSpy.Active and Not Terminated do
Begin
If SBIndex=0 then
Begin
IsIFrame:= (FFrameCount mod FIFrame)=0;
// Delay for MaxFrameRate!
TickCountLag:= MaxDelayMilliseconds- (GetTickCount-TCWhenCapture);
If TickCountLag>0 then
Sleep(TickCountLag);
Synchronize(CaptureScreen);
Synchronize(FrameStart);
End;

If IsIFrame or Not CompareMem(ScreenBitmaps[SBIndex].ptr, LastScreen[SBIndex], BMPBlockSize) then
{If IsIFrame then
BlockSame:= False
Else
BlockSame:= CompareMem(ScreenBitmaps[SBIndex].ptr, LastScreen[SBIndex], BMPBlockSize);
If Not BlockSame then{}
Begin
Synchronize(ScreenBitmap);
Move(ScreenBitmaps[SBIndex].ptr^, LastScreen[SBIndex]^, BMPBlockSize);
End;

SBIndex:= (SBIndex + 1) mod BlockCount;
If (SBIndex=0) then
Synchronize(FrameEnd);
End;
End;
end;

procedure TScreenSpyThread.FrameEnd;
begin
FScreenSpy.DoFrameEnd(IsIFrame);
end;

procedure TScreenSpyThread.FrameStart;
begin
FScreenSpy.HasBitmapEvent:= False;
FScreenSpy.DoFrameStart(IsIFrame);
end;

procedure TScreenSpyThread.ScreenBitmap;
begin
FScreenSpy.DoScreenBitmap(SBIndex, IsIFrame);
FScreenSpy.HasBitmapEvent:= True;
end;

{ TRLE }

Type
LongType = record
case Word of
0: (Ptr: Pointer);
1: (Long: LongInt);
2: (Lo: Word;
Hi: Word);
end;

constructor TSFastRLE.Create;
begin
inherited;
GetMem(s, $FFFF);
GetMem(t, $FFFF);
end;

destructor TSFastRLE.Destroy;
begin
FreeMem(t);
FreeMem(s);
inherited;
end;

function TSFastRLE.PackSeg(Source, Target: Pointer; SourceSize: Word): Word;
begin
asm
push esi
push edi
push eax
push ebx
push ecx
push edx

cld
xor ecx, ecx
mov cx, SourceSize
mov edi, Target

mov esi, Source
add esi, ecx
dec esi
lodsb
inc eax
mov [esi], al

mov ebx, edi
add ebx, ecx
inc ebx
mov esi, Source
add ecx, esi
add edi, 2
@CyclePack:
cmp ecx, esi
je @Konec
lodsw
stosb
dec esi
cmp al, ah
jne @CyclePack
cmp ax, [esi+1]
jne @CyclePack
cmp al, [esi+3]
jne @CyclePack
sub ebx, 2
push edi
sub edi, Target
mov [ebx], di
pop edi
mov edx, esi
add esi, 3
@Nimnul:
inc esi
cmp al, [esi]
je @Nimnul
mov eax, esi
sub eax, edx
or ah, ah
jz @M256
mov byte ptr [edi], 0
inc edi
stosw
jmp @CyclePack
@M256:
stosb
jmp @CyclePack
@Konec:
push ebx
mov ebx, Target
mov eax, edi
sub eax, ebx
mov [ebx], ax
pop ebx
inc ecx
cmp ebx, ecx
je @Lock1
mov esi, ebx
sub ebx, Target
sub ecx, Source
sub ecx, ebx
rep movsb
@Lock1:
sub edi, Target
mov Result, di

pop edx
pop ecx
pop ebx
pop eax
pop edi
pop esi
end;
end;

function TSFastRLE.UnPackSeg(Source, Target: Pointer; SourceSize: Word): Word;
begin
asm
push esi
push edi
push eax
push ebx
push ecx
push edx
cld
mov esi, Source
mov edi, Target
mov ebx, esi
xor edx, edx
mov dx, SourceSize
add ebx, edx
mov dx, word ptr [esi]
add edx, esi
add esi, 2
@UnPackCycle:
cmp edx, ebx
je @Konec2
sub ebx, 2
xor ecx, ecx
mov cx, word ptr [ebx]
add ecx, Source
sub ecx, esi
dec ecx
rep movsb
lodsb
mov cl, byte ptr [esi]
inc esi
or cl, cl
jnz @Low1
xor ecx, ecx
mov cx, word ptr [esi]
add esi, 2
@Low1:
inc ecx
rep stosb
jmp @UnPackCycle
@Konec2:
mov ecx, edx
sub ecx, esi
rep movsb
sub edi, Target
mov Result, di

pop edx
pop ecx
pop ebx
pop eax
pop edi
pop esi
end;
end;

function TSFastRLE.Pack(Source, Target: Pointer; SourceSize: Integer): LongInt;
var
w, tmp: Word;
Sourc, Targ: LongType;
begin
{ // Move
Move(Source^, Target^, SourceSize);
Result:= SourceSize;
Exit;{}

// RLE Compress
Sourc.Ptr := Source;
Targ.Ptr := Target;
Result := 0;
while SourceSize <> 0 do
begin
if SourceSize > $FFFA then tmp := $FFFA
else tmp := SourceSize;
dec(SourceSize, tmp);
move(Sourc.Ptr^, s^, tmp);
w := PackSeg(s, t, tmp);
inc(Sourc.Long, tmp);
Move(w, Targ.Ptr^, 2);
inc(Targ.Long, 2);
Move(t^, Targ.Ptr^, w);
inc(Targ.Long, w);
Result := Result + w + 2;
end;
end;

function TSFastRLE.PackFile(SourceFileName, TargetFileName: String): Boolean;
var
Source, Target: Pointer;
SourceFile, TargetFile: File;
RequiredMaxSize, TargetFSize, FSize: LongInt;
begin
AssignFile(SourceFile, SourceFileName);
Reset(SourceFile, 1);
FSize := FileSize(SourceFile);

RequiredMaxSize := FSize + (FSize div $FFFF + 1) * 2;
GetMem(Source, RequiredMaxSize);
GetMem(Target, RequiredMaxSize);

BlockRead(SourceFile, Source^, FSize);
CloseFile(SourceFile);

TargetFSize := Pack(Source, Target, FSize);

AssignFile(TargetFile, TargetFileName);
Rewrite(TargetFile, 1);
{ Also, you may put header }
BlockWrite(TargetFile, FSize, SizeOf(FSize)); { Original file size (Only from 3.0) }
BlockWrite(TargetFile, Target^, TargetFSize);
CloseFile(TargetFile);

FreeMem(Target, RequiredMaxSize);
FreeMem(Source, RequiredMaxSize);

Result := IOResult = 0;
end;

function TSFastRLE.PackString(Source: String): String;
var
PC, PC2: PChar;
SS, TS: Integer;
begin
SS := Length(Source);
GetMem(PC, SS);
GetMem(PC2, SS + 8); // If line can't be packed its size can be longer
Move(Source[1], PC^, SS);
TS := Pack(PC, PC2, SS);
SetLength(Result, TS + 4);
Move(SS, Result[1], 4);
Move(PC2^, Result[5], TS);
FreeMem(PC2);
FreeMem(PC);
end;

function TSFastRLE.UnPack(Source, Target: Pointer;
SourceSize: Integer): LongInt;
var
Increment, i: LongInt;
tmp: Word;
Swap: LongType;
begin
{ // Move
Move(Source^, Target^, SourceSize);
Result:= SourceSize;
Exit;{}

// RLE Decompress
Increment := 0;
Result := 0;
while SourceSize <> 0 do
begin
Swap.Ptr := Source;
inc(Swap.Long, Increment);
Move(Swap.Ptr^, tmp, 2);
inc(Swap.Long, 2);
dec(SourceSize, tmp + 2);
i := UnPackSeg(Swap.Ptr, t, tmp);
Swap.Ptr := Target;
inc(Swap.Long, Result);
inc(Result, i);
Move(t^, Swap.Ptr^, i);
inc(Increment, tmp + 2);
end;
end;

function TSFastRLE.UnPackFile(SourceFileName, TargetFileName: String): Boolean;
var
Source, Target: Pointer;
SourceFile, TargetFile: File;
OriginalFileSize, FSize: LongInt;
begin
AssignFile(SourceFile, SourceFileName);
Reset(SourceFile, 1);
FSize := FileSize(SourceFile) - SizeOf(OriginalFileSize);

{ Read header ? }
BlockRead(SourceFile, OriginalFileSize, SizeOf(OriginalFileSize));

GetMem(Source, FSize);
GetMem(Target, OriginalFileSize);

BlockRead(SourceFile, Source^, FSize);
CloseFile(SourceFile);

UnPack(Source, Target, FSize);

AssignFile(TargetFile, TargetFileName);
Rewrite(TargetFile, 1);
BlockWrite(TargetFile, Target^, OriginalFileSize);
CloseFile(TargetFile);

FreeMem(Target, OriginalFileSize);
FreeMem(Source, FSize);

Result := IOResult = 0;
end;

function TSFastRLE.UnPackString(Source: String): String;
var
PC, PC2: PChar;
SS, TS: Integer;
begin
SS := Length(Source) - 4;
GetMem(PC, SS);
Move(Source[1], TS, 4);
GetMem(PC2, TS);
Move(Source[5], PC^, SS);
TS := UnPack(PC, PC2, SS);
SetLength(Result, TS);
Move(PC2^, Result[1], TS);
FreeMem(PC2);
FreeMem(PC);
end;

{ TScreenEncoder }
constructor TScreenEncoder.Create(AOwner: TComponent);
begin
inherited;
// default properties value
FActive:= False;
FBlockInterval:= 1;
FBlockDelay:= 1;
FIFrameDelay:= 100;
// Create aggerated components
FSFastRLE:= TSFastRLE.Create;
FUDPSender:= TUDPSender.Create(Self);
FScreenSpy:= TScreenSpy.Create(Self);
FScreenSpy.OnScreenBitmap:= ScreenSpyOnScreenBitmap;
FScreenSpy.OnFrameStart:= ScreenSpyOnFrameStart;
FScreenSpy.OnFrameEnd:= ScreenSpyOnFrameEnd;
// default golbal value
{Records}
With RHeader do
Begin
dwSize:= SizeOfTftHeader;
PackID:= RID_Header;
End;
With RFrameStart do
Begin
dwSize:= SizeOfTftFrameStart;
PackID:= RID_FrameStart;
End;
With RFrameEnd do
Begin
dwSize:= SizeOfTftFrameEnd;
PackID:= RID_FrameEnd;
End;
{Block}
Blockptr:= nil;
XorDataPtr[1]:= nil;
MaxBlockSize:= FScreenSpy.MaxBlockSize;
end;

destructor TScreenEncoder.Destroy;
begin
Active:= False;
FScreenSpy.Free;
FUDPSender.Free;
FSFastRLE.Free;
// Free golbal pointers
If Assigned(Blockptr) then
FreeMem(Blockptr);
If Assigned(XorDataPtr[1]) then
FreeMem(XorDataPtr[1]);
inherited;
end;

procedure TScreenEncoder.ScreenSpyOnScreenBitmap(Sender: TObject;
const Block: TScreenBlock; LastScanline: Pointer; IsIFrame: Boolean);
Var
i, l: Integer;
PackedSize: Integer;
ptrNow, ptrLast: ^Byte;
ptrXOR: array [1..4] of ^Byte; // Max 4 bytes per pixel
begin
If IsIFrame then
Begin // Send IFrame
With Blockptr^ do
Begin
BlockIndex:= Block.BlockIndex;
FrameStyle:= sdsRLENormal;
//Compress
PackedSize:= FSFastRLE.Pack(Block.ptr, @(Blockptr^.Data[0]), FScreenSpy.BMPBlockSize);
If PackedSize>0 then
Begin
dwSize:= SizeofTftBlock-1+PackedSize;
FUDPSender.SendBuf(Blockptr^, Blockptr^.dwSize);
// Delay when Interval
BlockIntervalCount:= (BlockIntervalCount+1) mod FBlockInterval;
If BlockIntervalCount=0 then
Sleep(FBlockDelay);
End;
End;
End Else
Begin // Send NON IFrame
With FScreenSpy, Blockptr^ do
Begin
{ Init Packet values }
BlockIndex:= Block.BlockIndex;
FrameStyle:= sdsRLEXor;
{ Xor }
ptrNow:= Block.ptr;
ptrLast:= LastScanLine;
For i:=1 to BytesPerPixel do
ptrXOR:= XorDataPtr;
For i:=1 to BlockSize do
Begin
// Move (R, G, B) to each area if (24bits), for better RLE compression.
For l:=1 to BytesPerPixel do
Begin
ptrXOR[l]^:= ptrNow^ xor ptrLast^; // XOR
Inc(ptrNow);
Inc(ptrLast);
Inc(ptrXOR[l]);
End;
End;
{ Compress }
PackedSize:= FSFastRLE.Pack(XorDataPtr[1], @(Blockptr^.Data[0]), BMPBlockSize);
{ Send }
If PackedSize>0 then
Begin
dwSize:= SizeofTftBlock-1+PackedSize;
FUDPSender.SendBuf(Blockptr^, Blockptr^.dwSize);
// Delay when Interval
BlockIntervalCount:= (BlockIntervalCount+1) mod FBlockInterval;
If BlockIntervalCount=0 then
Sleep(FBlockDelay);
End;
End;
End;
end;

function TScreenEncoder.GetIFrame: Cardinal;
begin
Result:= FScreenSpy.IFrame;
end;

function TScreenEncoder.GetMaxBlockSize: Integer;
begin
Result:= FScreenSpy.MaxBlockSize;
end;

function TScreenEncoder.GetMaxFrameRate: Byte;
begin
Result:= FScreenSpy.MaxFrameRate;
end;

function TScreenEncoder.GetRemoteHost: String;
begin
Result:= FUDPSender.RemoteHost;
end;

function TScreenEncoder.GetRemoteIP: String;
begin
Result:= FUDPSender.RemoteIP;
end;

function TScreenEncoder.GetRemotePort: Word;
begin
Result:= FUDPSender.RemotePort;
end;

function TScreenEncoder.GetThreadPriority: TThreadPriority;
begin
Result:= FScreenSpy.ThreadPriority;
end;

procedure TScreenEncoder.SetActive(Value: Boolean);
begin
If Value<>FActive then
try
If Value then
Begin
// Init
BlockIntervalCount:= 0;

try
FUDPSender.Active:= True; // Active UDP sender first
except
Value:= False;
Raise;
end;
If Value then
SendHeader;
try
FScreenSpy.Active:= Value;
except
Value:= False;
Raise;
end;
End;

If Not Value then
Begin
FScreenSpy.Active:= Value; // Deactive ScreenSpy first
FUDPSender.Active:= Value;
End;
finally
FActive:= Value;
end;
end;

procedure TScreenEncoder.SetIFrame(const Value: Cardinal);
begin
FScreenSpy.IFrame:= Value;
end;

procedure TScreenEncoder.SetMaxBlockSize(const Value: Integer);
Var
i: Integer;
begin
If Active then
Raise EScrSpy.CreateRes(@ESSACTIVED);

FScreenSpy.MaxBlockSize:= Value;
try
If Assigned(Blockptr) then
FreeMem(Blockptr);
If Assigned(XorDataPtr[1]) then
FreeMem(XorDataPtr[1]);
finally
With FScreenSpy do
Begin
// GetBlock
GetMem(Blockptr, SizeofTftBlock+BMPBlockSize+8);
FillChar(Blockptr^, SizeofTftBlock+BMPBlockSize, 0);
Blockptr^.PackID:= RID_BLOCK;
// GetXor
GetMem(XorDataPtr[1], BMPBlockSize);
For i:=2 to BytesPerPixel do
XorDataPtr:= Pointer(Integer(XorDataPtr[1])+Integer(BlockSize)*(i-1));
End;
end;
end;

procedure TScreenEncoder.SetMaxFrameRate(const Value: Byte);
begin
FScreenSpy.MaxFrameRate:= Value;
end;

procedure TScreenEncoder.SetRemoteHost(const Value: String);
begin
FUDPSender.RemoteHost:= Value;
end;

procedure TScreenEncoder.SetRemoteIP(const Value: String);
begin
FUDPSender.RemoteIP:= Value;
end;

procedure TScreenEncoder.SetRemotePort(const Value: Word);
begin
FUDPSender.RemotePort:= Value;
end;

procedure TScreenEncoder.SetThreadPriority(const Value: TThreadPriority);
begin
FScreenSpy.ThreadPriority:= Value;
end;

procedure TScreenEncoder.SendHeader;
begin
If Not FScreenSpy.MemoryAllowcated then
FScreenSpy.CalculateScreenData;

With RHeader do
Begin
ScreenWidth:= FScreenSpy.ScreenWidth;
ScreenHeight:= FScreenSpy.ScreenHeight;
BytesPerPixel:= FScreenSpy.BytesPerPixel;
BlockWidth:= FScreenSpy.BlockWidth;
BlockHeight:= FScreenSpy.BlockHeight;
End;
FUDPSender.SendBuf(RHeader, RHeader.dwSize);
end;

procedure TScreenEncoder.SetBlockDelay(const Value: Cardinal);
begin
FBlockDelay := Value;
end;

procedure TScreenEncoder.ScreenSpyOnFrameEnd(Sender: TObject;
const FrameCount: Cardinal; const IsIFrame, HasBitmapEvent: Boolean);
begin
DoFrameEnd(FrameCount, IsIFrame, HasBitmapEvent);
If IsIFrame then
Sleep(FIFrameDelay);
end;

procedure TScreenEncoder.DoFrameEnd(const FrameCount: Cardinal;
const IsIFrame, HasBitmapEvent: Boolean);
begin
RFrameEnd.FrameCount:= FrameCount;
RFrameEnd.IsIFrame:= IsIFrame;
RFrameEnd.HasBitmapEvent:= HasBitmapEvent;
FUDPSender.SendBuf(RFrameEnd, RFrameEnd.dwSize);

If Assigned(FOnFrameEnd) then
FOnFrameEnd(Self, FrameCount, IsIFrame, HasBitmapEvent);
end;

procedure TScreenEncoder.DoFrameStart(const FrameCount: Cardinal;
const IsIFrame: Boolean);
begin
RFrameStart.FrameCount:= FrameCount;
RFrameStart.IsIFrame:= IsIFrame;
FUDPSender.SendBuf(RFrameStart, RFrameStart.dwSize);

If Assigned(FOnFrameStart) then
FOnFrameStart(Self, FrameCount, IsIFrame);
end;

procedure TScreenEncoder.ScreenSpyOnFrameStart(Sender: TObject;
const FrameCount: Cardinal; const IsIFrame: Boolean);
begin
DoFrameStart(FrameCount, IsIFrame);
end;

procedure TScreenEncoder.SetBlockInterval(const Value: Cardinal);
begin
FBlockInterval := Value;
end;

procedure TScreenEncoder.SetIFrameDelay(const Value: Cardinal);
begin
FIFrameDelay := Value;
end;

{ TScreenPlayer }

procedure TScreenPlayer.CalculateScreenData;
Var
i: Integer;
begin
If MemoryAllowcated then
ReleaseScreenData;

With Header do
Begin
FScreenWidth:= ScreenWidth;
FScreenHeight:= ScreenHeight;
FBytesPerPixel:= BytesPerPixel;
FBlockWidth:= BlockWidth;
FBlockHeight:= BlockHeight;
End;
Case FBytesPerPixel of
1: FPixelFormat:= pf8Bit;
2: FPixelFormat:= pf16Bit;
3: FPixelFormat:= pf24Bit;
4: FPixelFormat:= pf32Bit;
Else FPixelFormat:= pf24Bit;
End;{CASE}
FBlockColumnCount:= FScreenWidth div FBlockWidth;
FBlockRowCount:= FScreenHeight div FBlockHeight;
FBlockCount:= FBlockColumnCount * FBlockRowCount;
FBlockSize:= FBlockWidth * FBlockHeight;
BMPBlockSize:= FBlockSize * FBytesPerPixel;

// Get Buffer for Decode Screen block
GetMem(XorDataPtr[1], BMPBlockSize);
For i:=2 to BytesPerPixel do
XorDataPtr:= Pointer(Integer(XorDataPtr[1])+BlockSize*(i-1));

// Create temp bitmap for copy a pice of desktop image
SetLength(ScreenBitmaps, BlockCount);
For i:=0 to BlockCount-1 do
Begin
ScreenBitmaps.BlockIndex:= i;
ScreenBitmaps.Bound:= Rect(0,0,BlockWidth,BlockHeight);
OffsetRect(ScreenBitmaps.Bound, (i mod FBlockColumnCount) * FBlockWidth, (i div FBlockColumnCount) * FBlockHeight);
{ScreenBitmaps.Bound:= Rect((i mod BlockWidth) * BMPBlockWidth, (i div BlockWidth) * BMPBlockHeight,
(i mod BlockWidth) * BMPBlockWidth + BMPBlockWidth, (i div BlockWidth) * BMPBlockHeight + BMPBlockHeight);{}
ScreenBitmaps.BMP:= TBitmap.Create;
With ScreenBitmaps.BMP do
Begin
Width:= BlockWidth;
Height:= BlockHeight;
PixelFormat:= FPixelFormat;
If Cardinal(ScanLine[0])<Cardinal(ScanLine[1]) then
ScreenBitmaps.ptr:= ScanLine[0]
Else
ScreenBitmaps.ptr:= ScanLine[Height-1];
End;
End;

MemoryAllowcated:= True;
end;

constructor TScreenPlayer.Create(AOwner: TComponent);
begin
inherited;
FSFastRLE := TSFastRLE.Create;
FUDPReceiver:= TUDPReceiver.Create(Self);
FUDPReceiver.OnUDPData:= UDPReceiverOnUDPData;
MemoryAllowcated:= False;
end;

destructor TScreenPlayer.Destroy;
begin
Active:= False;
FUDPReceiver.Free;
FSFastRLE.Free;
ReleaseScreenData;
inherited;
end;

procedure TScreenPlayer.DoHeaderUpdate;
begin
If Assigned(FOnHeaderUpdate) then
FOnHeaderUpdate(Self);
end;

procedure TScreenPlayer.DoScreenBitmap(ScreenBitmapIndex: Integer);
begin
If Assigned(FOnScreenBitmap) then
try
FOnScreenBitmap(Self, ScreenBitmaps[ScreenBitmapIndex]);
except
FOnScreenBitmap:= nil;
end;
end;

function TScreenPlayer.GetActive: Boolean;
begin
Result := FUDPReceiver.Active;
end;

function TScreenPlayer.GetMulticastIP: String;
begin
Result := FUDPReceiver.MulticastIP;
end;

function TScreenPlayer.GetPort: Word;
begin
Result := FUDPReceiver.Port;
end;

procedure TScreenPlayer.ReleaseScreenData;
Var
i: Integer;
begin
If MemoryAllowcated then
Begin
{If Active then
Raise EScrSpy.CreateRes(@ESSACTIVED);{}
MemoryAllowcated:= False;
// Do release
For i:=2 to BytesPerPixel do
XorDataPtr:= nil;
FreeMem(XorDataPtr[1]);
For i:=0 to BlockCount-1 do
Begin
ScreenBitmaps.ptr:= nil;
ScreenBitmaps.BMP.Free;
End;
SetLength(ScreenBitmaps, 0);
End;
end;

procedure TScreenPlayer.SetActive(const Value: Boolean);
begin
FUDPReceiver.Active:= Value;
end;

procedure TScreenPlayer.SetMulticastIP(const Value: String);
begin
FUDPReceiver.MulticastIP:= Value;
end;

procedure TScreenPlayer.SetPort(const Value: Word);
begin
FUDPReceiver.Port:= Value;
end;

procedure TScreenPlayer.UDPReceiverOnUDPData(Sender: TObject;
const Buffer: Pointer; const RecvSize: Integer; const Peer: string;
const Port: Integer);
Var
i, l: Integer;
ScanLinePtr: ^Byte;
PtrXor: array [1..4] of ^Byte; // MAX 4 bytes per pixel
begin
AnyPtr:= Buffer;
If Anyptr.dwSize <> TRSize(RecvSize) then
Exit; // Error

Case AnyPtr.PackID of
RID_HEADER:
Begin
Move(AnyPtr^, Header, AnyPtr^.dwSize);
CalculateScreenData;
DoHeaderUpdate;
End;

RID_BLOCK:
If MemoryAllowcated then
Begin
BlockPtr:= Pointer(AnyPtr);
With BlockPtr^ do
Case FrameStyle of
sdsRLENormal:
Begin
//decompress
//FSFastRLE.UnPack(@(Data[0]), ScreenBitmaps[BlockIndex].ptr, dwSize+1-SizeofTftBlock);
FSFastRLE.UnPack(@(Data[0]), XorDataPtr[1], dwSize+1-SizeofTftBlock);
Move(XorDataPtr[1]^, ScreenBitmaps[BlockIndex].ptr^, BMPBlockSize);
DoScreenBitmap(BlockIndex);
End;

sdsRLEXor:
Begin
FSFastRLE.UnPack(@(Data[0]), XorDataPtr[1], dwSize+1-SizeofTftBlock);
// Init First Pointer for sequence XOR
ScanLinePtr:= ScreenBitmaps[BlockIndex].ptr;
For i:=0 to BytesPerPixel do
PtrXor:= XorDataPtr;

For i:=0 to BlockSize-1 do
Begin
For l:=1 to BytesPerPixel do
Begin
ScanLinePtr^:= ScanLinePtr^ xor PtrXor[l]^;
Inc(ScanLinePtr);
Inc(PtrXor[l]);
End;
End;
DoScreenBitmap(BlockIndex);
End;
End;{CASE}
End;

RID_FrameStart:
Begin
FrameStartPtr:= Pointer(AnyPtr);
If Assigned(FOnFrameStart) then
FOnFrameStart(Self, FrameStartPtr^.FrameCount, FrameStartPtr^.IsIFrame);
End;

RID_FrameEnd:
Begin
FrameEndPtr:= Pointer(AnyPtr);
If Assigned(FOnFrameEnd) then
FOnFrameEnd(Self, FrameEndPtr^.FrameCount, FrameEndPtr^.IsIFrame, FrameEndPtr^.HasBitmapEvent);
End;

Else //Error
End;{CASE}
end;

end.

谢了!

速度如何？

呵呵，有这个必要吗？直接给个链接就可以了吗，节约论坛资源[]
http://www.torry.net/displaying.htm
有好几个，你这个是其中一个。

自由万岁！
FreeWare万岁！
谢谢楼主。

gz

BufferUDP 组件谁有？

unit BufferUDP;

interface

uses
Windows, SysUtils, Classes, WinSock, syncobjs;

type // Main class
TUDPDataEvent = procedure(Sender: TObject; const Buffer: Pointer; const RecvSize:Integer; const Peer: string; const Port: Integer) of object;
TUDPSender = class(TComponent)
private
{ Private declarations }
FHandle: TSocket;
FActive: Boolean;
FRemoteIP: String;
FRemoteHost: String;
FRemotePort: Word;
CS: TCriticalSection;
Procedure SetActive(const Value: Boolean);
Procedure SetRemoteIP(const Value: String);
Procedure SetRemoteHost(const Value: String);
Procedure SetRemotePort(const Value: Word);
protected
{ Protected declarations }
public
{ Public declarations }
Class function ResolveHost(const psHost: string; var psIP: string): u_long; virtual;
Class function ResolveIP(const psIP: string): string; virtual;
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Procedure Connect;
Procedure Disconnect;
Function SendBuf(var Buffer; BufSize: Integer): Integer;
property Handle: TSocket read FHandle;
published
{ Published declarations }
property Active: Boolean read FActive write SetActive default False;
property RemoteIP: String read FRemoteIP write SetRemoteIP;
property RemoteHost: String read FRemoteHost write SetRemoteHost;
property RemotePort: Word read FRemotePort write SetRemotePort;
end;

TUDPReceiver = class;

TUDPReceiverThread = class(TThread)
protected
FReceiver: TUDPReceiver;
FBuffer: Pointer;
FRecvSize: Integer;
FPeer: string;
FPort: Integer;
FBufSize: Integer;
procedure SetBufSize(const Value: Integer);
public
procedure Execute; override;
procedure UDPRead;
published
Property BufSize: Integer read FBufSize write SetBufSize;
Property Receiver: TUDPReceiver read FReceiver write FReceiver;
end;

TUDPReceiver = class(TComponent)
private
{ Private declarations }
FHandle: TSocket;
FActive: Boolean;
FPort: Word;
FBufferSize: Integer;
FMulticastIP : String;
// FUDPBuffer: Pointer;
FOnUDPData: TUDPDataEvent;
FUDPReceiverThread: TUDPReceiverThread;
Procedure SetActive(const Value: Boolean);
Procedure SetPort(const Value: Word);
Procedure SetBufferSize(const Value: Integer);
procedure SetMulticastIP(const Value: String);
protected
{ Protected declarations }
public
{ Public declarations }
Class Function BindMulticast(const Socket: TSocket; const IP:String): LongInt; virtual;
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Procedure Connect;
Procedure Disconnect;
procedure DoUDPRead(const Buffer: Pointer; const RecvSize:Integer; const Peer: string; const Port: Integer); virtual;
property Handle: TSocket read FHandle;
published
{ Published declarations }
property Active: Boolean read FActive write SetActive default False;
property Port: Word read FPort write SetPort;
property BufferSize: Integer read FBufferSize write SetBufferSize default 65000;
property OnUDPData: TUDPDataEvent read FOnUDPData write FOnUDPData;
property MulticastIP: String read FMulticastIP write SetMulticastIP;
end;

type // exception
EBufferUDP = Exception;

procedure Register;

resourcestring
EUDPNOTACTIVE = 'UDP Socket not connected';
EUDPACTIVED = 'UDP Socket already connected';
EWSAError = 'Socket Error : %d';
EUNABLERESOLVEHOST = 'Unable to resolve host: %s';
EUNABLERESOLVEIP = 'Unable to resolve IP: %s';
EZEROBYTESEND = '0 bytes were sent.';
EPACKAGETOOBIG = 'Package Size Too Big: %d';
ENOREMOTESIDE = 'Remote Host/IP not identified!';
ESIZEOUTOFBOUNDARY = 'Size value is out of boundary!';
EWSAENOBUFS = 'An operation on a socket could not be performed because the system lacked sufficient buffer space or because a queue was full.';
EWSANOTINITIALISED = 'A successful WSAStartup must occur before using this function.';
EWSAENETDOWN = 'The network subsystem has failed.';
EWSAEFAULT = 'optval is not in a valid part of the process address space or optlen argument is too small.';
EWSAEINPROGRESS = 'A blocking Windows Sockets 1.1 call is in progress, or the service provider is still processing a callback function.';
EWSAEINVAL = 'level is not valid, or the information in optval is not valid.';
EWSAENETRESET = 'Connection has timed out when SO_KEEPALIVE is set.';
EWSAENOPROTOOPT = 'The option is unknown or unsupported for the specified provider.';
EWSAENOTCONN = 'Connection has been reset when SO_KEEPALIVE is set.';
EWSAENOTSOCK = 'The descriptor is not a socket.';
EWSAUNKNOW = 'Unknow socket error.';
implementation

procedure Register;
begin
RegisterComponents('Samples', [TUDPSender, TUDPReceiver]);
end;

Type
TIMR = Packed Record
imr_multiaddr: LongInt;
imr_interface: LongInt;
End;

{ TUDPSender }

procedure TUDPSender.Connect;
Var
Faddr: TSockAddrIn;
begin
CS.Enter;
try
If FActive then
Raise EBufferUDP.CreateRes(@EUDPACTIVED);

If ((FRemoteHost='') and (FRemoteIP='')) then
Raise EBufferUDP.CreateRes(@ENOREMOTESIDE);

If Not (csDesigning in ComponentState) then
Begin
FHandle:= WinSock.Socket(PF_INET, SOCK_DGRAM, IPPROTO_IP);
If FHandle = INVALID_SOCKET then
Raise EBufferUDP.CreateResFmt(@EWSAError, [WSAGetLastError]);

with faddr do begin
sin_family := PF_INET;
sin_port := WinSock.htons(FRemotePort);
// sin_addr.s_addr := WinSock.ResolveHost(fsHost, fsPeerAddress);
if length(FRemoteIP) > 0 then begin
sin_addr.s_addr := WinSock.inet_addr(PChar(FRemoteIP));
end;
end;
WinSock.connect(FHandle, faddr, Sizeof(faddr));
End;

FActive:= True;
finally
CS.Leave;
end;
end;

constructor TUDPSender.Create(AOwner: TComponent);
begin
inherited;
CS:= TCriticalSection.Create;
FActive:= False;
FHandle := INVALID_SOCKET;
// FReceiveTimeout := -1;
end;

destructor TUDPSender.Destroy;
begin
Active:= False;
CS.Free;
inherited;
end;

procedure TUDPSender.Disconnect;
Var
OldHandle: TSocket;
begin
CS.Enter;
try
If FActive then
Begin
OldHandle:= FHandle;
FHandle:= INVALID_SOCKET;
CloseSocket(OldHandle);
End;
finally
FActive:= False;
CS.Leave;
end;
end;

class function TUDPSender.ResolveHost(const psHost: string;
var psIP: string): u_long;
Var
pa: PChar;
sa: TInAddr;
aHost: PHostEnt;
begin
psIP := psHost;
// Sometimes 95 forgets who localhost is
if CompareText(psHost, 'LOCALHOST') = 0 then
begin
sa.S_un_b.s_b1 := #127;
sa.S_un_b.s_b2 := #0;
sa.S_un_b.s_b3 := #0;
sa.S_un_b.s_b4 := #1;
psIP := '127.0.0.1';
Result := sa.s_addr;
end else begin
// Done if is tranlated (ie There were numbers}
Result := inet_addr(PChar(psHost));
// If no translation, see if it resolves}
if Result = u_long(INADDR_NONE) then begin
aHost := Winsock.GetHostByName(PChar(psHost));
if aHost = nil then
begin
Result:= 0;
psIP:= '';
Exit;
//Raise EBufferUDP.CreateResFmt(@EUNABLERESOLVEHOST, [psHost]);
end else
begin
pa := aHost^.h_addr_list^;
sa.S_un_b.s_b1 := pa[0];
sa.S_un_b.s_b2 := pa[1];
sa.S_un_b.s_b3 := pa[2];
sa.S_un_b.s_b4 := pa[3];
psIP:= String(inet_ntoa(sa));
//psIP := TInAddrToString(sa);
end;
Result := sa.s_addr;
end;
end;
end;

class function TUDPSender.ResolveIP(const psIP: string): string;
var
i: Integer;
P: PHostEnt;
begin
result := '';
if CompareText(psIP, '127.0.0.1') = 0 then
begin
result := 'LOCALHOST';
end else
begin
i := Winsock.inet_addr(PChar(psIP));
P := Winsock.GetHostByAddr(@i, 4, PF_INET);
If P = nil then
Begin
Result:= '';
Exit;
// Raise EBufferUDP.CreateResFmt(@EUNABLERESOLVEIP, [psIP]);
//CheckForSocketError2(SOCKET_ERROR, [WSANO_DATA]);
End else
Begin
result := P.h_name;
End;
end;
end;

Function TUDPSender.SendBuf(var Buffer; BufSize: Integer): Integer;
begin
CS.Enter;
try
Result:= 0;
If BufSize<=0 then
Exit;
If Not FActive then
Raise EBufferUDP.CreateRes(@EUDPNOTACTIVE);

Result:= Winsock.send(FHandle, Buffer, BufSize, 0);
If Result<>BufSize then
Begin
Case Result of
0:
Raise EBufferUDP.CreateRes(@EZEROBYTESEND);
SOCKET_ERROR:
If WSAGetLastError = WSAEMSGSIZE then
Raise EBufferUDP.CreateResFmt(@EPACKAGETOOBIG, [BufSize])
End;{CASE}
End;
finally
CS.Leave;
end;
end;

procedure TUDPSender.SetActive(const Value: Boolean);
begin
If FActive<>Value then
Begin
If Value then
Connect
Else
Disconnect;
End;
end;

procedure TUDPSender.SetRemoteHost(const Value: String);
Var
IsConnected: Boolean;
begin
If FRemoteHost<>Value then
Begin
IsConnected:= Active;
Active:= False;
FRemoteHost:= Value;
If Not (csDesigning in ComponentState) then
ResolveHost(FRemoteHost, FRemoteIP);
// Resovle IP
Active:= IsConnected;
End;
end;

procedure TUDPSender.SetRemoteIP(const Value: String);
Var
IsConnected: Boolean;
begin
If FRemoteIP<>Value then
Begin
IsConnected:= Active;
Active:= False;
FRemoteIP:= Value;
// Resovle Host name
If Not (csDesigning in ComponentState) then
FRemoteHost:= ResolveIP(FRemoteIP);
Active:= IsConnected;
End;
end;

procedure TUDPSender.SetRemotePort(const Value: Word);
Var
IsConnected: Boolean;
begin
If FRemotePort<>Value then
Begin
IsConnected:= Active;
Active:= False;
FRemotePort:= Value;
Active:= IsConnected;
End;
end;

{ TUDPReceiver }

class function TUDPReceiver.BindMulticast(const Socket: TSocket;
const IP: String): LongInt;
Var
lpMulti: TIMR;
Begin
lpMulti.imr_multiaddr := inet_addr(PChar(IP));
lpMulti.imr_interface := 0;
Result:= SetSockOpt(Socket, IPPROTO_IP, IP_ADD_MEMBERSHIP, @lpMulti, Sizeof(lpMulti));
End;

procedure TUDPReceiver.Connect;
var
m_addr: TSockAddrIn;
begin
If FActive then
Raise EBufferUDP.CreateRes(@EUDPACTIVED);

If csDesigning in ComponentState then
Begin
FActive:= True;
Exit;
End;

// SOCKET
FHandle := Winsock.Socket(PF_INET, SOCK_DGRAM, IPPROTO_IP);
If FHandle = INVALID_SOCKET then
Raise EBufferUDP.CreateResFmt(@EWSAError, [WSAGetLastError]);

// BIND
With m_addr do begin
sin_family := PF_INET;
sin_port := Winsock.htons(FPort);
sin_addr.s_addr := INADDR_ANY;
End;
If WinSock.bind(FHandle, m_addr, Sizeof(m_addr))=SOCKET_ERROR then
Raise EBufferUDP.CreateResFmt(@EWSAError, [WSAGetLastError]);

// Bind Multicast
If FMulticastIP<>'' then
If BindMulticast(FHandle, FMulticastIP)=SOCKET_ERROR then
Case WSAGetLastError of
WSAENOBUFS: Raise EBufferUDP.CreateRes(@EWSAENOBUFS );
WSANOTINITIALISED: Raise EBufferUDP.CreateRes(@EWSANOTINITIALISED);
WSAENETDOWN: Raise EBufferUDP.CreateRes(@EWSAENETDOWN );
WSAEFAULT: Raise EBufferUDP.CreateRes(@EWSAEFAULT );
WSAEINPROGRESS: Raise EBufferUDP.CreateRes(@EWSAEINPROGRESS );
WSAEINVAL: Raise EBufferUDP.CreateRes(@EWSAEINVAL );
WSAENETRESET: Raise EBufferUDP.CreateRes(@EWSAENETRESET );
WSAENOPROTOOPT: Raise EBufferUDP.CreateRes(@EWSAENOPROTOOPT );
WSAENOTCONN: Raise EBufferUDP.CreateRes(@EWSAENOTCONN );
WSAENOTSOCK: Raise EBufferUDP.CreateRes(@EWSAENOTSOCK );
Else
Raise EBufferUDP.CreateRes(@EWSAUNKNOW);
End; {CASE}

// Thread read
FUDPReceiverThread := TUDPReceiverThread.Create(True);
With FUDPReceiverThread do
Begin
Receiver:= Self;
BufSize:= FBufferSize;
FreeOnTerminate := True;
Resume;
End;

FActive:= True;
end;

constructor TUDPReceiver.Create(AOwner: TComponent);
begin
inherited;
FHandle := INVALID_SOCKET;
FActive:= False;
FBufferSize:= 65000;
FMulticastIP:= '';
end;

destructor TUDPReceiver.Destroy;
begin
Active:= False;
inherited;
end;

procedure TUDPReceiver.Disconnect;
Var
OldHandle: TSocket;
begin
If Not FActive then
Exit;

try
OldHandle:= FHandle;
FHandle:= INVALID_SOCKET;
CloseSocket(OldHandle);
finally
FActive:= False;
end;

If FUDPReceiverThread <> nil then
Begin
FUDPReceiverThread.Terminate;
FUDPReceiverThread.WaitFor;
End;
end;

procedure TUDPReceiver.DoUDPRead(const Buffer: Pointer; const RecvSize:Integer;
const Peer: string; const Port: Integer);
begin
If Assigned(FOnUDPData) then begin
FOnUDPData(Self, Buffer, RecvSize, Peer, Port);
End;
end;

procedure TUDPReceiver.SetActive(const Value: Boolean);
begin
If FActive<>Value then
Begin
If Value then
Connect
Else
Disconnect;
End;
end;

procedure TUDPReceiver.SetBufferSize(const Value: Integer);
begin
If FBufferSize<>Value then
Begin
If ((Value>=1024) and (Value<=65000)) then
FBufferSize:= Value
Else
Raise EBufferUDP.CreateRes(@ESIZEOUTOFBOUNDARY);
End;
end;

procedure TUDPReceiver.SetMulticastIP(const Value: String);
Var
IsConnected: Boolean;
begin
If Value<>FMulticastIP then
Begin
IsConnected:= Active;
Active:= False;
FMulticastIP:= Value;
Active:= IsConnected;
End;
end;

procedure TUDPReceiver.SetPort(const Value: Word);
Var
IsConnected: Boolean;
begin
If FPort<>Value then
Begin
IsConnected:= Active;
Active:= False;
FPort:= Value;
Active:= IsConnected;
End;
end;

{ TUDPReceiverThread }

procedure TUDPReceiverThread.Execute;
var
i: Integer;
addr_remote: TSockAddrin;
arSize: Integer;
begin
GetMem(FBuffer, FBufSize);
arSize:= SizeOf(addr_remote);
while FReceiver.Active and not Terminated do
Begin
i := arSize;
FRecvSize := Winsock.RecvFrom(FReceiver.Handle, FBuffer^, FBufSize, 0, addr_remote, i);
If FReceiver.Active and (FRecvSize>0) then
Begin
//fsData := Copy(fListener.fsUDPBuffer, 1, iByteCount);
FPeer := String(inet_ntoa(addr_remote.sin_addr));
//FPeer := String(TWinshoe.TInAddrToString(addr_remote.sin_addr));
FPort := Winsock.NToHS(addr_remote.sin_port);
Synchronize(UDPRead);
End;
End;
FreeMem(FBuffer);
end;

procedure TUDPReceiverThread.SetBufSize(const Value: Integer);
begin
If FBufSize<> Value then
FBufSize:= Value;
end;

procedure TUDPReceiverThread.UDPRead;
begin
FReceiver.DoUDPRead(FBuffer, FRecvSize, FPeer, FPort);
end;

Var
GWSADATA: TWSADATA;
initialization
WSAStartup(MakeWord(2, 0), GWSADATA);
finalization
WSACleanup;
end.

不错，好象哪个被陈**用来卖钱的就是这个东东,楼主公布出来功德无量呀![]

不会是这个吧! 很早前我就下载过这样的代码了!

这个控件运行编译运行以后有一个奇怪的问题：如果用其中的TScreenEncoder组件，主机没有连结外网时，运行速度非常慢，运行过程大概要2-3分钟，但如果连结了外网，运行速度就非常快，我找不出其中的原因，敬请各位大侠解惑！

严重关注这个帖子。
但是这些不知道如何使用！！！
有没有人详细讲讲使用的方法

真是好样的！！！！！

[]

难道没有能找出其中的原因？？

请教大家，我使用ScreenSpy时，连接和监视都没问题，但是当SER或CLN任意一端的程序关闭的时候都提示错误，什么 CODE 6 的，大家有没有遇到过，怎么解决？
因为我用的是D6吗？

我用这个孔件做的程序在2000和XP下运行都没问题，但一到98下图像就错位，但我把程序退出，再运行一次就好了，不知道什么原因，哪位用过的可以帮我解释解释啊！狂郁闷的说

谢谢提供，学习ing...

不错!要学习学习!