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

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

代码


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 
                       
                    
                     
                      



鲜花




握手




雷人




路过




鸡蛋

该文章已有0人参与评论

请发表评论

全部评论

专题导读

More+

10-27 六六分期app的软件客服如何联系？(六六分期

11-06 可心卡盟:win10系统火狐flash插件崩溃怎么

11-06 亲亲特价:怎么删除回收站图标

11-06 济南大学虚拟社区:鲁大师节能降温的具体办

11-06 xlueops.exe:无线网络安装向导

11-06 女斗合众国:win7系统cf与主机连接不稳定怎

11-06 0xc000022-[cf烟雾头]cf怎么调烟雾头

11-06 qizideyouhuo:应用程序无法正常启动0xc0000

11-06 ipz-185:win7系统vcf文件怎么打开

11-06 傻哥蹦迪:win10系统s4怎么打开usb调试

11-06 八神浩树gtaste:回收站清空了怎么恢复

11-06 妖尾之黑色守护:win10系统电脑没有1440x900

11-06 校园至尊魔王小说:win7系统浏览网页时字体

11-06 女斗合众国:win10系统访问共享文件夹提示请

11-06 tokyo hot n0654:恢复win7系统默认字体一招

11-06 雨酷仙境:设置win7系统转移临时文件夹腾出

11-06 阿穆纳伊之杖:win7系统开始菜单在右边还原

11-06 tunespotting:win10系统火狐flash插件总是

11-06 甘尔葛分析师：计谋网站seo关键词暴涨有什

11-06 蔡贵霖: 计谋网站seo关键词暴涨有什么秘密

11-06 博益网首页:ao3网页版进入不了解决方法

11-06 漏斗子专栏: 网站数据分析小白易懂精华篇

11-06 见证双虹怎么做:win7系统开启telnet命令的

11-06 颾狐蝶蜋:系统资源不足无法完成请求的服务

11-06 国光中学校歌:提交网站到alexa查询详细步骤

11-06 西安有情天:静态网页和动态网页的区别

11-06 红木雅尚斋:外部链接构造对网站的好处

11-06 前官礼遇：防止域名劫持–增强域安全性的10

11-06 密传二转答案: 中文分词算法有哪些

11-06 金泉家园邮编:百度快照劫持的表现及应对方

DesignPattern----12.Structural.Flyweight.Pattern(DelphiSample)发布时间：2022-07-18

Delphi下的GDI+编程[8]绘制弧形-DrawArc发布时间：2022-07-18

剪的笔顺,诠释剪的笔画,认识剪的部首

六六分期app的软件客服如何联系？(六六分期

2023-10-27

florent37/ViewAnimator: A fluent Android

2022-08-15

florent37/Shrine-MaterialDesign2: implem

2022-08-17

CVE-2020-36276

2022-09-23

SimpleSoftwareIO/simple-sms: Send and re

2022-08-13

阅读排行榜

1 六六分期app的软件客服如何联系？(六六分期

六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期

阅读：19199|2023-10-27

2 可心卡盟:win10系统火狐flash插件崩溃怎么

今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知

阅读：9989|2022-11-06

3 亲亲特价:怎么删除回收站图标

今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道

阅读：8328|2022-11-06

4 济南大学虚拟社区:鲁大师节能降温的具体办

今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要

阅读：8697|2022-11-06

5 xlueops.exe:无线网络安装向导

我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多

阅读：8640|2022-11-06

6 女斗合众国:win7系统cf与主机连接不稳定怎

今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不

阅读：9659|2022-11-06

7 0xc000022-[cf烟雾头]cf怎么调烟雾头

电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很

阅读：8625|2022-11-06

8 qizideyouhuo:应用程序无法正常启动0xc0000

我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法

阅读：7999|2022-11-06

9 ipz-185:win7系统vcf文件怎么打开

今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win

阅读：8657|2022-11-06

10 傻哥蹦迪:win10系统s4怎么打开usb调试

今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎

阅读：7536|2022-11-06

扫描微信二维码

查看手机版网站

随时了解更新最新资讯

139-2527-9053

在线客服（服务时间 9:00～18:00）

在线QQ客服

地址：深圳市南山区西丽大学城创智工业园

电邮：jeky_zhao#qq.com

移动电话：139-2527-9053

客服电话

电子邮件

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

请发表评论

全部评论

上一篇：

下一篇：

PacktPublishing/Python-Machine-Learning-

sussillo/hfopt-matlab: A parallel, cpu-b

鲁东大学一米网:Win7系统USB驱动器RAM的操

emersion/go-ostatus: An OStatus library

CVE-2022-22982