scrspy.pas

DELPHI实现的快速屏幕截图并发送源代码

    MemoryAllowcated:= False;
    // Do release
    ReleaseDC(0, FScreenCanvas.Handle);
    For i:=0 to BlockCount-1 do
      FreeMem(LastScreen[i]);
    SetLength(LastScreen, 0);
    For i:=0 to BlockCount-1 do
    Begin
      ScreenBitmaps[i].ptr:= nil;
      ScreenBitmaps[i].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[i] 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;