Delphi笔记Indy10.5.5 IdTcpServer 与 IdTcpClient Demo 服务器端

unit UntMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Buttons, ComCtrls, XPMan, ExtCtrls, StdCtrls, Menus, IdContext,
  IdScheduler, IdSchedulerOfThread, IdSchedulerOfThreadDefault, IdBaseComponent,
  IdComponent, IdCustomTCPServer, IdTCPServer, ImgList, IdGlobal, UntGlb,
  IOUtils, IdThread,
  RibbonLunaStyleActnCtrls, ABOUT, ToolWin, PlatformDefaultStyleActnCtrls,
  ActnPopup, ExtDlgs, jpeg, ShellCtrls, DateUtils, IdSchedulerOfThreadPool;

type
  TForm1 = class(TForm)
    stat1: TStatusBar;
    trycn1: TTrayIcon;
    xpmnfst1: TXPManifest;
    mm1: TMainMenu;
    mniN1: TMenuItem;
    mniN2: TMenuItem;
    mniN4: TMenuItem;
    mniN5: TMenuItem;
    mniN7: TMenuItem;
    mniN3: TMenuItem;
    mniN8: TMenuItem;
    il1: TImageList;
    idtcpsrvr1: TIdTCPServer;
    BalloonHint1: TBalloonHint;
    PopActMemo: TPopupActionBar;
    mniNClear: TMenuItem;
    mniN6: TMenuItem;
    mniNSave: TMenuItem;
    PopActBall: TPopupActionBar;
    mniN9: TMenuItem;
    mniN13: TMenuItem;
    mniN10: TMenuItem;
    mniN11: TMenuItem;
    mniN12: TMenuItem;
    il3: TImageList;
    dlgSave1: TSaveTextFileDialog;
    il2: TImageList;
    pgc1: TPageControl;
    ts1: TTabSheet;
    ts2: TTabSheet;
    grp2: TGroupBox;
    mmo1: TMemo;
    grp1: TGroupBox;
    lv1: TListView;
    ts3: TTabSheet;
    ShellListView2: TShellListView;
    ShellTreeView1: TShellTreeView;
    PopupMenu1: TPopupMenu;
    mniN14: TMenuItem;
    mniN15: TMenuItem;
    mniN16: TMenuItem;
    mniN17: TMenuItem;
    mniN18: TMenuItem;
    mniN19: TMenuItem;
    PopupMenu2: TPopupMenu;
    mniN20: TMenuItem;
    mniN21: TMenuItem;
    mniN22: TMenuItem;
    tmr1: TTimer;
    IdSchedulerOfThreadPool1: TIdSchedulerOfThreadPool;
    mniN23: TMenuItem;
    procedure mniN13Click(Sender: TObject);
    procedure mniN7Click(Sender: TObject);
    procedure WndProc(var Msg: TMessage); override;
    procedure N14Click(Sender: TObject);
    procedure mniN2Click(Sender: TObject);
    procedure idtcpsrvr1Execute(AContext: TIdContext);
    procedure FormCreate(Sender: TObject);
    procedure idtcpsrvr1Connect(AContext: TIdContext);
    procedure idtcpsrvr1Disconnect(AContext: TIdContext);
    procedure AddList(AContext: TIdContext);
    procedure DelList(AContext: TIdContext);
    procedure UpdSta;
    procedure WMUSERMSG(var Msg: TMessage); message WM_USERMSG;
    procedure WMUSERFILE(var Msg: TMessage); message WM_USERFILE;
    procedure mniN5Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure DisConnectAllClient;
    procedure mniN8Click(Sender: TObject);
    procedure mniN9Click(Sender: TObject);
    procedure mniN11Click(Sender: TObject);
    procedure mniN12Click(Sender: TObject);
    procedure trycn1DblClick(Sender: TObject);
    procedure PopActMemoPopup(Sender: TObject);
    procedure mniNClearClick(Sender: TObject);
    procedure mniNSaveClick(Sender: TObject);
    procedure dlgSave1CanClose(Sender: TObject; var CanClose: Boolean);
    procedure FormDestroy(Sender: TObject);
    procedure lv1SelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure lv1ItemChecked(Sender: TObject; Item: TListItem);
    procedure mniN14Click(Sender: TObject);
    procedure mniN16Click(Sender: TObject);
    procedure mniN17Click(Sender: TObject);
    procedure mniN18Click(Sender: TObject);
    procedure mniN19Click(Sender: TObject);
    procedure mniN22Click(Sender: TObject);
    procedure tmr1Timer(Sender: TObject);
    procedure mniN23Click(Sender: TObject);
  private
    { Private declarations }
    // 定义一个私有成员，保存连接对象AContext(ListView控件Items成员没有AdddObject方法，无法保存对象)
    FStrings: TStringList;
  public
    { Public declarations }
  end;

  // 这里声明一个自定义类，在Form.Create方法里面使用
type
  TMyContextClass = class(TIdServerContext)
    ClientInfo: TClientInfo;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMUSERFILE(var Msg: TMessage);
var
  ClientIP: string;
  str: string;
  path: string;
  size: Cardinal;
  Persent: Cardinal;
  m: Integer;
begin
  ClientIP := TMyContextClass(Msg.LParam).Binding.PeerIP;
  str := TMyContextClass(Msg.LParam).ClientInfo.ReceivedFileName;
  Persent := TMyContextClass(Msg.LParam).ClientInfo.ReceivedPersent;
  size := TMyContextClass(Msg.LParam).ClientInfo.ReceivedFileSize;
  m := FStrings.IndexOfObject(TMyContextClass(Msg.LParam));
  with mmo1.Lines do
  begin
    case Msg.WParam of
      0:
        begin
          Add(format(LogReceiveFile, [ClientIP, str, size, DateTimeToStr(Now)])
            );
          lv1.Items.BeginUpdate;
          try
            lv1.Items[m].SubItems[4] := LogClientStateBusy;
            // 接收文件时更新状态为  忙
          finally
            lv1.Items.EndUpdate;
          end;
        end;
      1:
        begin
          Add(format(LogReceiveFileOk, [ClientIP, str, DateTimeToStr(Now)]));
          lv1.Items.BeginUpdate;
          try
            lv1.Items[m].SubItems[4] := LogClientStateSleep;
            // 文件接收完毕时更新状态为  空闲
          finally
            lv1.Items.EndUpdate;
          end;
        end;
      2:
        begin
          path := ExtractFilePath(ParamStr(0)) + REV + '\';
          Add(format(LogUerBreakSend, [ClientIP, str, DateTimeToStr(Now)]));
          DeleteFile(path + str);

          lv1.Items.BeginUpdate;
          try
            lv1.Items[m].SubItems[4] := LogClientStateSleep;
            // 用户终止传送时更新状态为  空闲
          finally
            lv1.Items.EndUpdate;
          end;

        end;
      3:
        stat1.Panels[2].Text := format(StaReceivedPersent, [str, Persent]);
    end;
  end;
end;

procedure TForm1.WMUSERMSG(var Msg: TMessage);
begin
  if Msg.Msg = WM_USERMSG then
  begin
    case Msg.WParam of
      ADD_LIST:
        AddList(TMyContextClass(Msg.LParam));
      DEL_LIST:
        DelList(TMyContextClass(Msg.LParam));
      SHOW_R:
        Visible:=True;
    end;
    stat1.Panels[1].Text := format(StaText, [lv1.Items.Count]);
  end;
end;

procedure TForm1.WndProc(var Msg: TMessage);
begin
  if ((Msg.Msg = WM_SYSCOMMAND) and (Msg.WParam = SC_CLOSE)) or
    ((Msg.Msg = WM_SYSCOMMAND) and (Msg.WParam = SC_MINIMIZE)) then
  begin
    Msg.Msg := 0;
    mniN13.Click;
  end;
  inherited;
end;

procedure TForm1.AddList(AContext: TIdContext);
begin
  lv1.Items.BeginUpdate;
  try
    with lv1.Items.Add do
    begin
      Caption := AContext.Binding.PeerIP; // IP
      ImageIndex := 0;
      SubItems.Add(TMyContextClass(AContext).ClientInfo.ClientACTIP ); // 物理地址
      SubItems.Add(TMyContextClass(AContext).ClientInfo.ClientName); // 计算机名
      SubItems.Add(DateTimeToStr(Now)); // 连接时间
      SubItems.Add(TMyContextClass(AContext).ClientInfo.ClientOS); // 操作系统
      SubItems.Add(LogClientStateSleep); // 状态
    end;
    FStrings.AddObject(StringsObjectName, AContext);
  finally
    lv1.Items.EndUpdate;
  end;
  mmo1.Lines.Add(format(LogClientConnected, [AContext.Binding.PeerIP,
      TMyContextClass(AContext).ClientInfo.ClientName, DateTimeToStr(Now)]));
end;

procedure TForm1.DelList(AContext: TIdContext);
var
  i: Integer;
begin
  i := FStrings.IndexOfObject(AContext);
  FStrings.Delete(i);
  lv1.Items.BeginUpdate;
  try
    if Assigned(lv1.Items[i]) then
      lv1.Items.Delete(i);
  finally
    lv1.Items.EndUpdate;
  end;
  mmo1.Lines.Add(format(LogClientdisConnected, [AContext.Binding.PeerIP,
      TMyContextClass(AContext).ClientInfo.ClientName, DateTimeToStr(Now)]));
end;

procedure TForm1.DisConnectAllClient;
var
  i: Integer;
begin
  for i := 0 to FStrings.Count - 1 do
  begin
    TMyContextClass(FStrings.Objects[i]).Connection.Disconnect;
  end;
end;

procedure TForm1.dlgSave1CanClose(Sender: TObject; var CanClose: Boolean);
var
  h: Integer;
begin
  CanClose := False;
  if FileExists(dlgSave1.FileName) then
  begin
    if MessageDlg(format(DlgFileExists, [dlgSave1.FileName]), mtInformation,
      [mbYes, mbNo], 0) = mrYes then
    begin
      DeleteFile(dlgSave1.FileName);
      h := FileCreate(dlgSave1.FileName);
      FileClose(h);
      CanClose := True;
    end;
  end
  else
  begin
    h := FileCreate(dlgSave1.FileName);
    FileClose(h);
    CanClose := True;
  end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := False;
  DisConnectAllClient;
  CanClose := True;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  path: string;
  IniFile: string;
  h: THandle;
  i: Integer;
begin

  // 这里重新赋值 idtcpsrvr1.ContextClass属性。在Context被创建时，将以 TMyContextClass 类来创建。
  // TIdListenerThread.LContext := Server.FContextClass.Create(LPeer, LYarn, Server.Contexts);
  // 详见IdCustomTcPServer.pas单元956行
  idtcpsrvr1.ContextClass := TMyContextClass;
  FStrings := TStringList.Create;
  lv1.Checkboxes := True;
  trycn1.BalloonHint := bhBalloonHint;
  trycn1.BalloonTitle := bhBalloonTitle;
  path := ExtractFilePath(ParamStr(0)) + REV;
  if not DirectoryExists(path) then
    TDirectory.CreateDirectory(path);
  stat1.Panels[0].Text := StaInitText;
  ShellTreeView1.path := ExtractFilePath(ParamStr(0)) + REV;
  // 检查配置文件
  IniFile := ExtractFilePath(ParamStr(0)) + IniFileName;
  if not FileExists(IniFile) then
  begin
    h := FileCreate(IniFile, fmOpenReadWrite);
    try
      i := $10000; // 不自动开启 --默认值
      if FileWrite(h, i, 4) <> 4 then
      begin
        ShowMessage(DlgCreateIniFailed);
        Application.Terminate;
      end;
    finally
      FileClose(h);
    end;
  end
  else
  begin
    h := FileOpen(IniFile, fmOpenReadWrite);
    try
      if FileRead(h, i, 4) = 4 then
      begin
        case i of
          $10000:
            begin
              idtcpsrvr1.Active := False;
              mniN22.Checked := False;
            end;
          $11111:
            begin
              mniN2.Click;
              mniN22.Checked := True;
            end;
        else
          FileClose(h);
          DeleteFile(IniFile);
          h := FileCreate(IniFile, fmOpenReadWrite);
          i := $10000; // 不自动开启 --默认值
          if FileWrite(h, i, 4) <> 4 then
          begin
            ShowMessage(DlgIniFileBreak);
            Application.Terminate;
          end;
        end;
      end;
    finally
      FileClose(h);
    end;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FStrings.Free;
end;

procedure TForm1.idtcpsrvr1Connect(AContext: TIdContext);
// 这里不能直接操作VCL控件，OnConnect，OnDisConnect,OnException,OnExecute都是在线程里面执行
// 要采用SendMessage发送消息通知主线程操作VCL的方法才是可取的；
// 详见IdCustomTcPServer.pas单元961-964行
begin
  // TMyContextClass(AContext).ClientInfo.ClientIP := AContext.Binding.PeerIP;
  // SendMessage(Handle,WM_USERMSG,ADD_LIST,LongInt(AContext )); //通知主线更新VCL控件
end;

procedure TForm1.idtcpsrvr1Disconnect(AContext: TIdContext);
begin
  SendMessage(Handle, WM_USERMSG, DEL_LIST, LongInt(AContext)); // 通知主线更新VCL控件
end;

procedure TForm1.idtcpsrvr1Execute(AContext: TIdContext);
var
  Buf: TDataPack;
  BByte: TIdBytes;
  path: string;
  Files: string;
  h: Integer;
  Received: Cardinal;
begin
  // 接收文件存入当前程序REV子目录下
  path := ExtractFilePath(Application.ExeName) + REV + '\';

  AContext.Connection.IOHandler.ReadBytes(BByte, SizeOf(Buf), False);
  TMyContextClass(AContext).ClientInfo.Isbusy := True;
  BytesToRaw(BByte, Buf, SizeOf(Buf));
  if TMyContextClass(AContext).ClientInfo.ReceivedFileName <> Buf.FileName then
    Move(Buf.FileName,TMyContextClass(AContext).ClientInfo.ReceivedFileName,SizeOf(buf.FileName));
  TMyContextClass(AContext).ClientInfo.ReceivedFileSize := Buf.FileSize;
  case Buf.Command of
    cmdSetName:
      begin
        with TMyContextClass(AContext).ClientInfo do
        begin
          ClientName := Buf.ClientInfo.ClientName;
          ClientOS := Buf.ClientInfo.ClientOS;
          ClientIP := Buf.ClientInfo.ClientIP;
          ClientACTIP:= buf.ClientInfo.ClientACTIP;
          IdleTime := Time;
          Isbusy := False;
        end;
        SendMessage(Handle, WM_USERMSG, ADD_LIST, LongInt(AContext));
      end;
    cmdSendFile:
      begin
        try
          Files := path + Buf.FileName;
          case Buf.Flags of
            0:
              begin
                SendMessage(Handle, WM_USERFILE, 0, LongInt(AContext));
                if FileExists(Files) then
                  DeleteFile(Files);
                h := FileCreate(Files, fmOpenReadWrite);
              end;
            1:
              h := FileOpen(Files, fmOpenReadWrite);
          end;
          FileSeek(h, 0, 2);
          FileWrite(h, Buf.FileData, Buf.ReadBytes);
          Received := GetFileSize(h, nil);
          FileClose(h);
          TMyContextClass(AContext).ClientInfo.ReceivedPersent := Trunc
            ((Received / Buf.FileSize) * 100);
          SendMessage(Handle, WM_USERFILE, 3, LongInt(AContext));
          if Received = Buf.FileSize then
          begin
            SendMessage(Handle, WM_USERFILE, 1, LongInt(AContext));
          end;
        except
          (* 如果出现异常，极大的可能是：
            客户端与服务器端正在进行数据传输的同时，服务器端突然断开连接 *)

          // if not AContext.Connection.IOHandler.Opened then
          // AContext.Connection.IOHandler.InputBuffer.Clear;
        end;
      end;
    cmdUserbreak:
      begin
        SendMessage(Handle, WM_USERFILE, 2, LongInt(AContext));
      end;
  end;

  TMyContextClass(AContext).ClientInfo.IdleTime := Time;
  TMyContextClass(AContext).ClientInfo.Isbusy := False;
end;

procedure TForm1.lv1ItemChecked(Sender: TObject; Item: TListItem);
begin
  if Item.Checked then
    mniN5.Enabled := True
  else
    mniN5.Enabled := False;
end;

procedure TForm1.lv1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  if Selected then
    Item.Checked := True
  else
    Item.Checked := False;

end;

procedure TForm1.mniN11Click(Sender: TObject);
begin
  AboutBox.ShowModal;
end;

procedure TForm1.mniN12Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.mniN13Click(Sender: TObject);
begin
  if Visible then
  begin
    Visible := False;
    trycn1.ShowBalloonHint;
  end;
end;

procedure TForm1.mniN14Click(Sender: TObject);
begin
  ShellListView2.Refresh;
end;

procedure TForm1.mniN16Click(Sender: TObject);
var
  path: string;
begin
  path := ShellTreeView1.path;
  ShellListView2.ViewStyle := vsIcon;
  ShellTreeView1.path := path;
end;

procedure TForm1.mniN17Click(Sender: TObject);
var
  path: string;
begin
  path := ShellTreeView1.path;
  ShellListView2.ViewStyle := vsSmallIcon;
  ShellTreeView1.path := path;
end;

procedure TForm1.mniN18Click(Sender: TObject);
var
  path: string;
begin
  path := ShellTreeView1.path;
  ShellListView2.ViewStyle := vsList;
  ShellTreeView1.path := path;
end;

procedure TForm1.mniN19Click(Sender: TObject);
var
  path: string;
begin
  path := ShellTreeView1.path;
  ShellListView2.ViewStyle := vsReport;
  ShellTreeView1.path := path;
end;

procedure TForm1.N14Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.mniN9Click(Sender: TObject);
begin
  if not Visible then
    Visible := True
  else
    Visible := False;
end;

procedure TForm1.mniNClearClick(Sender: TObject);
begin
  mmo1.ReadOnly := False;
  mmo1.Text := '';
  mmo1.ReadOnly := True;
end;

procedure TForm1.mniNSaveClick(Sender: TObject);
var
  h: THandle;
  TxtFileName: string;
  n, m: Integer;
  tmp: AnsiString;
begin
  if mmo1.Text <> '' then
  begin
    if dlgSave1.Execute then
    begin
      tmp := LogTxt + mmo1.Text;
      n := Length(tmp);
      TxtFileName := dlgSave1.FileName;
      h := FileOpen(TxtFileName, fmOpenReadWrite);
      m := FileWrite(h, tmp[1], n);
      FileClose(h);
      if m = n then
        ShowMessage(DlgLogOk)
      else
        ShowMessage(DlgLogFailed);
    end;
  end;
end;

procedure TForm1.PopActMemoPopup(Sender: TObject);
begin
  if mmo1.Text <> '' then
  begin
    mniNClear.Enabled := True;
    mniNSave.Enabled := True;
  end
  else
  begin
    mniNClear.Enabled := False;
    mniNSave.Enabled := False;
  end;
end;

procedure TForm1.tmr1Timer(Sender: TObject);
var
  i: Integer;
  tmpTime: TTime;
  AContextIdleTime: TTime;
  AContextIsbusy: Boolean;
begin
  tmpTime := Time;
  for i := 0 to FStrings.Count - 1 do
  begin
    AContextIdleTime := TMyContextClass(FStrings.Objects[i])
      .ClientInfo.IdleTime;
    AContextIsbusy := TMyContextClass(FStrings.Objects[i]).ClientInfo.Isbusy;
    if (IncSecond(AContextIdleTime, 60*5) < tmpTime) and (not AContextIsbusy) then
      TMyContextClass(FStrings.Objects[i]).Connection.Disconnect;
  end;
end;

procedure TForm1.trycn1DblClick(Sender: TObject);
begin
  mniN9.Click;
end;

procedure TForm1.mniN22Click(Sender: TObject);
var
  h: THandle;
  i: Integer;
  IniFile: string;
  IsAutoServer: Boolean;
begin
  IniFile := ExtractFilePath(ParamStr(0)) + IniFileName;
  if mniN22.Checked then
  begin
    i := $11111;
    IsAutoServer := True;
  end
  else
  begin
    i := $10000;
    IsAutoServer := False;
  end;

  if not FileExists(IniFile) then
  begin
    ShowMessage(DlgIniNotExists);
    mniN22.Checked := not IsAutoServer;
  end
  else
  begin
    h := FileOpen(IniFile, fmOpenReadWrite);
    if h > 0 then
    begin
      try
        if FileWrite(h, i, 4) <> 4 then
          mniN22.Checked := not IsAutoServer;
      finally
        FileClose(h);
      end;
    end
    else
    begin
      ShowMessage(DlgIniBusy);
      mniN22.Checked := not IsAutoServer;
    end;
  end;
end;

procedure TForm1.mniN23Click(Sender: TObject);
var
  MaxConnection:string;
begin
  MaxConnection:=InputBox(dlgInputBoxCpt,dlgInputBox,'20');//default 20
  ShowMessage(MaxConnection);
end;

procedure TForm1.mniN2Click(Sender: TObject);
begin
  if mniN2.Checked then
  begin
    idtcpsrvr1.Active := True;
    stat1.Panels[0].Text := StaServerStart;
    mmo1.Lines.Add(format(LogServerStart, [DateTimeToStr(Now)]));
  end
  else
  begin

    DisConnectAllClient;
    idtcpsrvr1.Active := False;
    stat1.Panels[0].Text := StaServerClose;
    mmo1.Lines.Add(format(LogServerClose, [DateTimeToStr(Now)]));
  end;

end;

procedure TForm1.mniN5Click(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to lv1.Items.Count - 1 do
  begin
    if lv1.Items[i].Checked then
      TMyContextClass(FStrings.Objects[i]).Connection.Disconnect;
  end;
end;

procedure TForm1.mniN7Click(Sender: TObject);
begin
  Close;
end;

procedure TForm1.mniN8Click(Sender: TObject);
begin
  AboutBox.ShowModal;
end;

procedure TForm1.UpdSta;
begin
  stat1.Panels[1].Text := format(StaText, [lv1.Items.Count]);
end;

end.

program Server;

uses
  Windows,
  Messages,
  Forms,
  UntMain in 'UntMain.pas' { Form1 } ,
  UntGlb in 'UntGlb.pas',
  ABOUT in 'ABOUT.pas' { AboutBox } ;
{$R *.res}

var
  MainForm: HWND;

begin
  MainForm := FindWindow('TForm1', PChar(MainFormCaption));
  if MainForm > 0 then
  begin
    PostMessage(MainForm, WM_USERMSG, SHOW_R, 0);
    Exit;
  end;
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm1, Form1);
  Application.MainForm.Caption := MainFormCaption;
  Application.CreateForm(TAboutBox, AboutBox);
  Application.Run;

end.