Delphi控件源码

开发平台：
Delphi

ServerDlg.pas：源码内容
							unit ServerDlg;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, WinSock, ScktComp, Menus, TrayIcon, FormSettings,
  RemConMessages, ZLib, MsgSimulator, ComCtrls, ShellAPI;
type
  TServerForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    LogList: TListBox;
    ServerPanel: TPanel;
    Label5: TLabel;
    StartLab: TLabel;
    Label9: TLabel;
    ConLab: TLabel;
    Label11: TLabel;
    NumRecLab: TLabel;
    Label13: TLabel;
    NumSendLab: TLabel;
    Label3: TLabel;
    LastRecLab: TLabel;
    Label4: TLabel;
    NumErrLab: TLabel;
    Panel1: TPanel;
    Label1: TLabel;
    NameLabel: TLabel;
    Label2: TLabel;
    PortEdit: TEdit;
    Panel2: TPanel;
    StartBut: TButton;
    DisconBut: TButton;
    MinimizeBut: TButton;
    ClientBut: TButton;
    ServerSocket1: TServerSocket;
    TrayIcon1: TTrayIcon;
    TrayMenu: TPopupMenu;
    RemoteControl1: TMenuItem;
    N1: TMenuItem;
    Client1: TMenuItem;
    N2: TMenuItem;
    Shutdown1: TMenuItem;
    FormSettings1: TFormSettings;
    MsgSimulator1: TMsgSimulator;
    Label6: TLabel;
    PassEdit: TEdit;
    procedure StartButClick(Sender: TObject);
    procedure DisconButClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure MinimizeButClick(Sender: TObject);
    procedure RemoteControl1Click(Sender: TObject);
    procedure Shutdown1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ServerSocket1Listen(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientError(Sender: TObject;
      Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
      var ErrorCode: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Client1Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure ClientButClick(Sender: TObject);
  protected
    NumRec     : double;
    NumSend    : double;
    NumError   : integer;
    CurMsg     : string;
    LoggedOn   : boolean;
    CurBmp     : TBitmap;
    CurSocket  : TCustomWinSocket;
    CurHandle  : THandle;
    SleepTime  : integer;
    ViewMode   : TViewMode;
    CompMode   : TCompressionLevel;
    procedure  UpdateStats;
    procedure  Log(const s: string);
    procedure  ProcessClick(const Data: string);
    procedure  ProcessDrag(const Data: string);
    procedure  Send_Screen_Update(Socket: TCustomWinSocket);
    procedure  SleepDone(Sender: TObject);
    procedure  ProcessKeys(const Data: string);
    procedure  CreateSleepThread;
    procedure  GetHostNameAddr;
    procedure  ParseComLine;
    function   Get_Process_List: string;
    procedure  CloseWindow(const Data: string);
    procedure  KillWindow(const Data: string);
    function   Get_Drive_List: string;
    function   GetDirectory(const PathName: string): string;
    function   GetFile(const PathName: string): string;
  public
    procedure  EnableButs;
    procedure  ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
    procedure  SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
  end;
var
  ServerForm: TServerForm;
implementation
uses ClientFrm;
{$R *.DFM}
procedure TServerForm.StartButClick(Sender: TObject);
begin
   with ServerSocket1 do begin
      Port := StrToInt(PortEdit.Text);
      Active := True;
   end;
   EnableButs;
end;
procedure TServerForm.DisconButClick(Sender: TObject);
begin
   ServerSocket1.Active := False;
   EnableButs;
end;
procedure TServerForm.EnableButs;
var
   b : boolean;
begin
   b := ServerSocket1.Active;
   StartBut.Enabled := not b;
   PortEdit.Enabled := not b;
   DisconBut.Enabled := b;
   // MinimizeBut.Enabled := b;
end;
procedure TServerForm.GetHostNameAddr;
var
   buf   : array[0..MAX_PATH] of char;
   he    : PHostEnt;
   buf2  : PChar;
   rc    : integer;
begin
   rc := GetHostName(buf, sizeof(buf));
   if rc<>SOCKET_ERROR then begin
      he := GetHostByName(buf);
      if he = nil then begin
         rc := WSAGetLastError;
         NameLabel.Caption := Format('Socket Error %d = %s', [rc, SysErrorMessage(rc)]);
      end else begin
         buf2 := inet_ntoa(PInAddr(he.h_addr^)^);
         NameLabel.Caption := Format('%s  (%s)', [buf, buf2]);
      end;
   end else begin
      NameLabel.Caption := 'Unknown Host';
   end;
end;
procedure TServerForm.FormShow(Sender: TObject);
begin
   EnableButs;
   GetHostNameAddr;
end;
procedure TServerForm.MinimizeButClick(Sender: TObject);
begin
   if ServerSocket1.Active then begin
      TrayIcon1.ToolTip := Application.Title + ' - Port: ' + PortEdit.Text;
   end else begin
      TrayIcon1.ToolTip := Application.Title + ' - Inactive';
   end;
   TrayIcon1.Active := True;
   ShowWindow(Application.Handle, SW_HIDE);
   Hide;
end;
procedure TServerForm.RemoteControl1Click(Sender: TObject);
begin
   TrayIcon1.Active := False;
   ShowWindow(Application.Handle, SW_SHOW);
   Application.Restore;
   Show;
   SetForegroundWindow(Handle);
end;
procedure TServerForm.Shutdown1Click(Sender: TObject);
begin
   RemoteControl1Click(nil);
   Close;
end;
procedure TServerForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
   FormSettings1.SaveSettings;
end;
procedure TServerForm.ServerSocket1Listen(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   StartLab.Caption := CurTime;
   NumRec   := 0;
   NumSend  := 0;
   CurMsg   := '';
   LoggedOn := False;
   UpdateStats;
   Log('Startup at ' + CurTime);
end;
procedure TServerForm.UpdateStats;
begin
   ConLab.Caption := IntToStr(ServerSocket1.Socket.ActiveConnections);
   NumRecLab.Caption := Format('%1.0n', [NumRec]);
   NumSendLab.Caption := Format('%1.0n', [NumSend]);
   NumErrLab.Caption := IntToStr(NumError);
end;
procedure TServerForm.ServerSocket1ClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
   s : string;
begin
   Log(Format('%-20s %s', ['Recv Data', Socket.RemoteAddress]));
   LastRecLab.Caption := CurTime;
   s := Socket.ReceiveText;
   NumRec := NumRec + Length(s);
   UpdateStats;
   CurMsg := CurMsg + s;
   while IsValidMessage(CurMsg) do begin
      s := TrimFirstMsg(CurMsg);
      ProcessMessage(s, Socket);
   end;
end;
procedure TServerForm.ServerSocket1ClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   Log(Format('%-20s %s', ['Connect', Socket.RemoteAddress]));
   ViewMode := vmColor4;
   CompMode := clDefault;
   SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_NORMAL);
   UpdateStats;
end;
procedure TServerForm.ServerSocket1ClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   Log(Format('%-20s %s', ['Disconnect', Socket.RemoteAddress]));
   UpdateStats;
end;
procedure TServerForm.ServerSocket1ClientError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin
   Log(Format('%-20s %d', ['Error', ErrorCode]));
   ErrorCode := 0;
   Inc(NumError);
   UpdateStats;
end;
procedure TServerForm.Log(const s: string);
begin
   LogList.ItemIndex := LogList.Items.Add(s);
end;
procedure TServerForm.ProcessMessage(const Msg: string; Socket: TCustomWinSocket);
var
   MsgNum, x: integer;
   rc       : integer;
   Data     : string;
   bmp      : TBitmap;
   tmp      : string;
begin
   CurSocket := Socket;
   Move(Msg[1], MsgNum, sizeof(integer));
   Data := Copy(Msg, 9, Length(Msg));
   Log(Format('%-20s %d', ['Message', MsgNum]));
   if MsgNum = MSG_LOGON then begin
      LoggedOn := (AnsiCompareText(Data, PassEdit.Text) = 0);
      if LoggedOn then begin
         SendMsg(MSG_LOGON, '1', Socket)
      end else begin
         SendMsg(MSG_LOGON, '0', Socket);
      end;
      exit;
   end;
   if not LoggedOn then begin
      Log('Denied Access!');
      SendMsg(MSG_STAT_MSG, 'Invalid Password', Socket);
      Socket.Close;
      exit;
   end;
   if MsgNum = MSG_REFRESH then begin
      Log('Screen Capture');
      SendMsg(MSG_STAT_MSG, 'Screen Capture', Socket);
      GetScreen(bmp, ViewMode);
      Log('Compressing Bitmap');
      SendMsg(MSG_STAT_MSG, 'Screen Compression', Socket);
      CompressBitmap(bmp, tmp);
      SaveString(tmp, 'Temp1.txt');
      SendMsg(MSG_REFRESH, tmp, Socket);
      CurBmp.Assign(bmp);
      bmp.Free;
   end;
   if MsgNum = MSG_SCREEN_UPDATE then begin
      Send_Screen_Update(Socket);
   end;
   if MsgNum = MSG_CLICK then begin
      SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
      ProcessClick(Data);
      // SleepDone will be called when it is finished
   end;
   if MsgNum = MSG_DRAG then begin
      SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
      ProcessDrag(Data);
      // SleepDone will be called when it is finished
   end;
   if MsgNum = MSG_KEYS then begin
      SendMsg(MSG_STAT_MSG, 'Simulating Input', Socket);
      ProcessKeys(Data);
      // SleepDone will be called when it is finished
   end;
   if MsgNum = MSG_SEVER_DELAY then begin
      Move(Data[1], SleepTime, sizeof(integer));
      SendMsg(MSG_SEVER_DELAY, '', Socket);
   end;
   if MsgNum = MSG_VIEW_MODE then begin
      Move(Data[1], x, sizeof(integer));
      ViewMode := TViewMode(x);
      SendMsg(MSG_VIEW_MODE, '', Socket);
   end;
   if MsgNum = MSG_FOCUS_SERVER then begin
      if TrayIcon1.Active then RemoteControl1Click(nil);
      SetFocus;
      CreateSleepThread;
      // SleepDone will be called when it is finished
   end;
   if MsgNum = MSG_COMP_MODE then begin
      Move(Data[1], x, sizeof(integer));
      CompMode := TCompressionLevel(x);
      SendMsg(MSG_COMP_MODE, '', Socket);
   end;
   if MsgNum = MSG_PRIORITY_MODE then begin
      Move(Data[1], x, sizeof(integer));
      SetThreadPriority(GetCurrentThread, x);
      SendMsg(MSG_PRIORITY_MODE, '', Socket);
   end;
   if MsgNum = MSG_PROCESS_LIST then begin
      SendMsg(MSG_PROCESS_LIST, Get_Process_List, Socket);
   end;
   if MsgNum = MSG_CLOSE_WIN then begin
      CloseWindow(Data);
   end;
   if MsgNum = MSG_KILL_WIN then begin
      KillWindow(Data);
   end;
   if MsgNum = MSG_DRIVE_LIST then begin
      SendMsg(MSG_DRIVE_LIST, Get_Drive_List, Socket);
   end;
   if MsgNum = MSG_DIRECTORY then begin
      SendMsg(MSG_DIRECTORY, GetDirectory(Data), Socket);
   end;
   if MsgNum = MSG_FILE then begin
      SendMsg(MSG_FILE, GetFile(Data), Socket);
   end;
   if MsgNum = MSG_REMOTE_LAUNCH then begin
      SendMsg(MSG_STAT_MSG, 'Launching File: ' + Data, Socket);
      rc := ShellExecute(Handle, 'open', PChar(Data), nil, nil, SW_SHOWNORMAL);
      if rc <= 32 then begin
         Data := Format('ShellExecute Error #%d Launching %s', [rc, Data]);
         SendMsg(MSG_REMOTE_LAUNCH, Data, Socket);
      end else begin
         SendMsg(MSG_REMOTE_LAUNCH, Data, Socket);
      end;
   end;
end;
function EnumWinProc(hw: THandle; lp: LParam): boolean; stdcall;
var
   sl    : TStringList;
   buf   : array[0..MAX_PATH] of char;
   s, iv : string;
begin
   sl := TStringList(lp);
   GetWindowText(hw, buf, sizeof(buf));
   if buf<>'' then begin
      if IsWindowVisible(hw) then iv := '' else iv := '(Invisible)';
      s := Format('%8.8x - %-32s  %s', [hw, buf, iv]);
      sl.AddObject(s, TObject(hw));
   end;
   Result := True;
end;
function TServerForm.Get_Process_List: string;
var
   sl : TStringList;
begin
   sl := TStringList.Create;
   EnumWindows(@EnumWinProc, integer(sl));
   Result := sl.Text;
   sl.Free;
end;
function TServerForm.Get_Drive_List: string;
var
   DriveBits : integer;
   i         : integer;
begin
   Result := '';
   DriveBits := GetLogicalDrives;
   for i := 0 to 25 do begin
      if (DriveBits and (1 shl i)) <> 0 then
         Result := Result + Chr(Ord('A') + i) + ':' + #13#10;
   end;
end;
function TServerForm.GetDirectory(const PathName: string): string;
var
   DirList   : TStringList;
   CommaList : TStringList;
   sr        : TSearchRec;
   s         : string;
   dt        : TDateTime;
begin
   DirList := TStringList.Create;
   CommaList := TStringList.Create;
   if FindFirst(PathName, faAnyFile, sr) = 0 then repeat
      CommaList.Clear;
      s := sr.Name;
      if (s = '.') or (s = '..') then continue;
      if (sr.Attr and faDirectory) <> 0 then s := s + '';
      CommaList.Add(s);
      s := Format('%1.0n', [sr.Size+0.0]);
      CommaList.Add(s);
      dt := FileDateToDateTime(sr.Time);
      s := FormatDateTime('yyyy-mm-dd  hh:nn ampm', dt);
      CommaList.Add(s);
      DirList.Add(CommaList.CommaText);
   until FindNext(sr) <> 0;
   FindClose(sr);
   Result := DirList.Text;
   CommaList.Free;
   DirList.Free;
end;
function TServerForm.GetFile(const PathName: string): string;
var
   fs : TFileStream;
begin
   fs := TFileStream.Create(PathName, fmOpenRead or fmShareDenyWrite);
   SetLength(Result, fs.Size);
   fs.Read(Result[1], fs.Size);
   fs.Free;
end;
procedure TServerForm.CloseWindow(const Data: string);
var
   sl : TStringList;
   i  : integer;
   hw : THandle;
begin
   sl := TStringList.Create;
   EnumWindows(@EnumWinProc, integer(sl));
   i := sl.IndexOf(Data);
   if i<>-1 then begin
      hw := THandle(sl.Objects[i]);
      SendMessage(hw, WM_CLOSE, 0, 0);
      Sleep(SleepTime);
      SendMsg(MSG_PROCESS_LIST, Get_Process_List, CurSocket);
   end;
   sl.Free;
end;
procedure TServerForm.KillWindow(const Data: string);
var
   sl     : TStringList;
   i      : integer;
   hw     : THandle;
   ProcID : integer;
   hProc  : THandle;
begin
   sl := TStringList.Create;
   EnumWindows(@EnumWinProc, integer(sl));
   i := sl.IndexOf(Data);
   if i<>-1 then begin
      hw := THandle(sl.Objects[i]);
      GetWindowThreadProcessId(hw, @ProcID);
      hProc := OpenProcess(PROCESS_ALL_ACCESS, False, ProcID);
      TerminateProcess(hProc, DWORD(-1));
      CloseHandle(hProc);
      Sleep(SleepTime);
      SendMsg(MSG_PROCESS_LIST, Get_Process_List, CurSocket);
   end;
   sl.Free;
end;
procedure TServerForm.SleepDone(Sender: TObject);
begin
   Send_Screen_Update(CurSocket);
end;
procedure TServerForm.Send_Screen_Update(Socket: TCustomWinSocket);
var
   bmp, dif : TBitmap;
   R        : TRect;
   tmp      : string;
begin
   Log('Screen Capture');
   SendMsg(MSG_STAT_MSG, 'Screen Capture', Socket);
   GetScreen(bmp, ViewMode);
   Log('Creating Diff Image');
   dif := TBitmap.Create;
   dif.Assign(bmp);
   R := Rect(0, 0, dif.Width, dif.Height);
   SendMsg(MSG_STAT_MSG, 'Screen Difference', Socket);
   dif.Canvas.CopyMode := cmSrcInvert;
   dif.Canvas.CopyRect(R, CurBmp.Canvas, R);
   Log('Compressing Bitmap');
   SendMsg(MSG_STAT_MSG, 'Screen Compression', Socket);
   CompressBitmap(dif, tmp);
   SendMsg(MSG_SCREEN_UPDATE, tmp, Socket);
   CurBmp.Assign(bmp);
   dif.Free;
   bmp.Free;
end;
function GetMB(but: integer): TMouseButton;
begin
   case but of
      1 : Result := mbLeft;
      2 : Result := mbRight;
      else Result := mbLeft;
   end;
end;
procedure TServerForm.ProcessClick(const Data: string);
var
   x, y, i  : integer;
   num, but : integer;
   p        : TPoint;
begin
   Move(Data[1], x, sizeof(integer));
   Move(Data[1+4], y, sizeof(integer));
   Move(Data[1+8], num, sizeof(integer));
   Move(Data[1+12], but, sizeof(integer));
   // Find the Window Handle
   p := Point(x, y);
   CurHandle := WindowFromPoint(p);
   Assert(CurHandle<>0);
   SetCursorPos(x, y);
   // Create the Messages to send in the Hook procedure
   with MsgSimulator1 do begin
      Messages.Clear;
      for i := 1 to num do
         Add_ClickEx(0, GetMB(but), [], x, y, 1);
      Play;
   end;
   CreateSleepThread;
end;
procedure TServerForm.ProcessDrag(const Data: string);
var
   x, y       : integer;
   time       : integer;
   num, but   : integer;
   p          : TPoint;
   StartPt    : TPoint;
   StopPt     : TPoint;
begin
   Move(Data[1], but, sizeof(integer));
   Move(Data[1+4], num, sizeof(integer));
   Assert(num > 2);
   // Create the Messages to send in the Hook procedure
   // Mouse Down
   Move(Data[(1-1)*12 + 9], x, sizeof(integer));
   Move(Data[(1-1)*12 + 13], y, sizeof(integer));
   Move(Data[(1-1)*12 + 17], time, sizeof(integer));
   SetCursorPos(x, y);
   // Find the Window Handle
   p := Point(x, y);
   CurHandle := WindowFromPoint(p);
   Assert(CurHandle<>0);
   with MsgSimulator1 do begin
      Messages.Clear;
      StartPt.X := x;
      StartPt.Y := y;
      Windows.ScreenToClient(CurHandle, StartPt);
      Move(Data[(num-1)*12 + 9], x, sizeof(integer));
      Move(Data[(num-1)*12 + 13], y, sizeof(integer));
      StopPt.X := x;
      StopPt.Y := y;
      Windows.ScreenToClient(CurHandle, StopPt);
      Add_Window_Drag(CurHandle, StartPt.X, StartPt.Y, StopPt.X, StopPt.Y);
      Play;
   end;
   CreateSleepThread;
end;
procedure TServerForm.ProcessKeys(const Data: string);
begin
   with MsgSimulator1 do begin
      Messages.Clear;
      Add_ASCII_Keys(Data);
      Play;
   end;
   CreateSleepThread;
end;
procedure TServerForm.SendMsg(MsgNum: integer; const MsgData: string; Socket: TCustomWinSocket);
var
   s : string;
begin
   s := IntToByteStr(MsgNum) + IntToByteStr(Length(MsgData)) + MsgData;
   Log(Format('%-20s %-4d %1.0n', ['Send', MsgNum, Length(s)+0.0]));
   Socket.SendText(s);
   NumSend := NumSend + Length(s);
   UpdateStats;
end;
procedure TServerForm.FormCreate(Sender: TObject);
begin
   CurBmp    := TBitmap.Create;
   SleepTime := 50;
   ParseComLine;
end;
procedure TServerForm.FormDestroy(Sender: TObject);
begin
   CurBmp.Free;
end;
type
   TSleepThread = class(TThread)
   public
      SleepTime   : integer;
      procedure   Execute; override;
   end;
procedure TSleepThread.Execute;
begin
   Sleep(SleepTime);
end;
procedure TServerForm.CreateSleepThread;
var
   st : TSleepThread;
begin
   st := TSleepThread.Create(True);
   st.SleepTime := SleepTime;
   st.OnTerminate := SleepDone;
   st.Resume;
end;
procedure TServerForm.Client1Click(Sender: TObject);
begin
   ClientForm.Show;
end;
procedure TServerForm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
var
   rc : integer;
begin
   if ServerSocket1.Socket.ActiveConnections > 0 then begin
      rc := MessageDlg('Clients are still connected, do you want to close?',
         mtWarning, mbYesNoCancel, 0);
      CanClose := (rc = mrYes);
   end;
end;
procedure TServerForm.ParseComLine;
var
   i           : integer;
   s           : string;
   AutoStart   : boolean;
begin
   AutoStart := False;
   for i := 1 to ParamCount do begin
      s := UpperCase(ParamStr(i));
      if Copy(s, 1, 6) = '/PORT:' then begin
         PortEdit.Text := Copy(s, 7, Length(s));
         AutoStart := True;
         StartButClick(nil);
         MinimizeButClick(nil);
      end;
      if s = '/CLIENT' then begin
         MinimizeButClick(nil);
         AutoStart := True;
      end;
   end;
   if not AutoStart then
      Visible := True;
end;
procedure TServerForm.ClientButClick(Sender: TObject);
begin
   ClientForm.Show;
end;
end.

						