Delphi笔记-Indy10.5.5IdTcpServer与IdTcpClientDemo--服务器端

原作者: [db:作者] 来自: [db:来源] 收藏邀请

代码


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.

代码


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<