📄 uclmain.pas

📁 delphi中的SOCKET使用的简单程序
💻 PAS
字号:
unit uClMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ScktComp, Buttons, ShellApi, ComCtrls, ExtCtrls, Menus;

type
  TfmClient = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    ListView1: TListView;
    Memo1: TMemo;
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Button1: TButton;
    Edit2: TEdit;
    Edit3: TEdit;
    ClientSocket1: TClientSocket;
    Panel2: TPanel;
    BitBtn1: TBitBtn;
    Panel3: TPanel;
    edtMsg: TEdit;
    Button2: TButton;
    edtDir: TEdit;
    Memo2: TMemo;
    PopupMenu1: TPopupMenu;
    N1: TMenuItem;
    StatusBar1: TStatusBar;
    procedure Button1Click(Sender: TObject);
    procedure ClientSocket1Connect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Disconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure ClientSocket1Lookup(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure ClientSocket1Write(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Connecting(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure Button2Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure ListView1DblClick(Sender: TObject);
    procedure N1Click(Sender: TObject);
  private
    FCurrDir: string;
    procedure AddFileList(sRecText: string);
  public
    { Public declarations }
  end;

var
  fmClient: TfmClient;

implementation

uses  uWaitMsg, StrUtils;

{$R *.dfm}

procedure TfmClient.Button1Click(Sender: TObject);
begin
  if Self.Button1.Tag=0 then
  begin
    Self.ClientSocket1.Host:=Self.Edit2.Text;
    Self.ClientSocket1.Port:=strtoint(Self.Edit3.Text);
    Self.ClientSocket1.Open;
  end else
    Self.ClientSocket1.Close;
end;

procedure TfmClient.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Self.StatusBar1.Panels[0].Text:= format('连接成功%s(%d):', [Socket.RemoteHost, Socket.SocketHandle]);

//  fmWaitMsg.Label1.Caption:='连接成功！';
//  fmWaitMsg.Hide;

  Self.Button1.Caption:='DisConncet';
  Self.Button1.Tag:=1;
end;

procedure TfmClient.ClientSocket1Disconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Self.StatusBar1.Panels[0].Text:= format('断开连接%s(%d):', [Socket.RemoteHost, Socket.SocketHandle]);

  Self.Button1.Caption:='Connect';
  Self.Button1.Tag:=0;
end;

procedure TfmClient.ClientSocket1Error(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
var
  strErr :string;
begin
  fmWaitMsg.Hide;

  case ErrorEvent of
   eeConnect: strErr :='与 ' +clientsocket1.host+ ' 的连接产生连接错误';
   eeDisconnect: strErr :='与 ' +clientsocket1.host+ ' 的连接产生关闭错误';
   eeReceive: strErr :='与 ' +clientsocket1.host+ ' 的连接产生接收错误';
   eeSend: strErr :='与 ' +clientsocket1.host+ ' 的连接产生发送错误';
   eeAccept: strErr :='与 ' +clientsocket1.host+ ' 的连接产生链入错误';
  else
    strErr :='与 ' +clientsocket1.host+ ' 的连接产生普通错误';
  end;
  Application.MessageBox(pchar(strErr),'系统提示：',MB_OK+MB_ICONWARNING);
  ErrorCode:=0 ;               //本句消除产生的错误 避免源代码产生错误提示
end;

procedure TfmClient.ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
var
  sRecText: string;

{  GetBuf   : TSendBuf;
  GetLen   : Integer;
  GetVerb  : Integer;
  LeadBuf  : TLeadBuf;
  DataBuf  : TDataBuf;
  SendBuf  : TSendBuf;
  SendSize : Integer;
  ReadLen  : Integer;
  DbBuf    : TDataBuf; }
begin
  sRecText:= Socket.ReceiveText;
  Self.Memo1.Lines.Add(format('%s(%d):', [Socket.RemoteHost, Socket.SocketHandle]));
  Self.Memo1.Lines.Add(sRecText);
  //
  {if LeftStr(sRecText, 11) = '#ShareFile#' then
  begin
    Delete(sRecText, 1, 11);
    Self.AddFileList(sRecText);
  end; 

  ////////////////////////////////////////////////////////////////////////////
  SendSize:=0;
  //GetVerb:=vsNone;
  GetLen:=ClientSocket.Socket.ReceiveBuf(GetBuf, SendLen);
  if GetLen<LeadLen then
  begin
    Self.StatusBarEx.Panels[1].Text:='收到无效数据包，传送终止！';
    ResetSocketData(P);
    Exit;
  end;
  P:=Socket.Data;
  ExtractBuf(GetBuf, GetLen, LeadBuf, DataBuf);
  GetVerb:=ClientExtractVerb(LeadBuf);
  //Self.Memo1.Lines.Add(inttostr(GetVerb));
  case GetVerb of
    //请求发送部分
    vsRefuse: begin
      Self.StatusBarEx.Panels[1].Text:='';
      MyShowMessage('对方计算机拒绝了你的请求！');
      Self.BnOK.Enabled:=True;
      Self.ClientSocket.Close;
     end;
    vsAgree: begin
      Screen.Cursor:=crHourGlass;
      Self.StatusBarEx.Panels[1].Text:='对方同意你的请求，开始传送...';
      P^.FileName:='temp.gzp';
      P^.FS := TFileStream.Create(Self.TempPath+'\temp.gzp', fmOpenRead);
      P^.FSEnabled := True;
      P^.FileSize := P^.FS.Size;
      P^.LeftSize := P^.FS.Size;
      P^.ProgressBar.Min := 0;
      P^.ProgressBar.Max := P^.FS.Size;
      P^.ProgressBar.Position := 0;
      MakeFileInfoBuf(P, SendBuf, SendSize);   //制作文件信息
     end;
    //传送文件部分
    vsFileInfoOK: begin                        //文件信息确认后开始发送第一个包
      if P^.FSEnabled then
      try
        case P^.LeftSize of                    //确定每次读多少来发送
          0:          ReadLen := 0;
          1..DataLen: ReadLen := P^.LeftSize;
        else
          ReadLen := DataLen;
        end;
        if ReadLen > 0 then
          P^.FS.ReadBuffer(DbBuf, ReadLen);
        P^.LeftSize := P^.LeftSize - ReadLen;
        MakeVerbBuf(vcFirstBuf, SendBuf, SendSize);
        MakeSendBuf(DbBuf, ReadLen, SendBuf, SendSize);
        P^.ProgressBar.Position := P^.ProgressBar.Position + ReadLen;
      except
        MakeVerbBuf(vcFail, SendBuf, SendSize);
      end else
        MakeVerbBuf(vcFail, SendBuf, SendSize);
     end;
    vsFirstBufOK, vsCommonBufOK:begin
      if P^.FSEnabled then
      try
        if P^.LeftSize > DataLen then
          ReadLen := DataLen
        else
          ReadLen := P^.LeftSize;
        if ReadLen > 0 then
          P^.FS.ReadBuffer(DbBuf, ReadLen);
        P^.LeftSize := P^.LeftSize - ReadLen;
        if P^.LeftSize = 0 then
          MakeVerbBuf(vcLastBuf, SendBuf, SendSize)
        else
          MakeVerbBuf(vcCommonBuf, SendBuf, SendSize);
        MakeSendBuf(DbBuf, ReadLen, SendBuf, SendSize);
        P^.ProgressBar.Position := P^.ProgressBar.Position + ReadLen;
      except
        MakeVerbBuf(vcFail, SendBuf, SendSize);
      end else
        MakeVerbBuf(vcFail, SendBuf, SendSize);
     end;
    vsLastBufOK: begin                              //文件成功收到最后一个包
      MakeVerbBuf(vcComplete, SendBuf, SendSize);
      Self.StatusBarEx.Panels[1].Text:='案卷上报成功完成！';
     end;
    //处理异常部分
    vsIDError: begin
      Self.StatusBarEx.Panels[1].Text:='收到非法数据包，传送终止！';
     end;
    vsNone: begin
      Self.StatusBarEx.Panels[1].Text:='收到无效数据包，传送终止！';
     end;
    vsFail: begin
      Self.StatusBarEx.Panels[1].Text:='对方操作失败，传送终止！';
     end;
    vsEchoCancel: begin
      Self.StatusBarEx.Panels[1].Text:='对方响应取消，传送终止！';
     end;
    vsEchoFail: begin
      Self.StatusBarEx.Panels[1].Text:='对方响应失败，传送终止！';
     end;
  end;
  if SendSize > 0 then
    ClientSocket.Socket.SendBuf(SendBuf, SendSize);    //发送应答包
    
  //终止动作，关闭文件等
  if (GetVerb=vsLastBufOK) or (GetVerb=vsIDError) or (GetVerb=vsNone) or
     (GetVerb=vsEchoCancel) or (GetVerb=vsEchoFail) then
  begin
    Screen.Cursor:=crDefault;
    ResetSocketData(P);
    Self.BnOK.Enabled:=True;
    Self.ClientSocket.Close;
  end;  }
end;

procedure TfmClient.ClientSocket1Write(Sender: TObject; Socket: TCustomWinSocket);
begin
  Self.Memo1.Lines.Add('OnWrite:'+Socket.RemoteAddress);
end;

procedure TfmClient.ClientSocket1Lookup(Sender: TObject; Socket: TCustomWinSocket);
begin
  Self.StatusBar1.Panels[0].Text:= format('正在查找对方计算机%s(%d):', [Socket.RemoteHost, Socket.SocketHandle]);
//  fmWaitMsg.Label1.Caption:='正在找对方计算机。。。';
//  fmWaitMsg.Show;
end;

procedure TfmClient.ClientSocket1Connecting(Sender: TObject; Socket: TCustomWinSocket);
begin
  Self.StatusBar1.Panels[0].Text:= format('正在建立连接%s(%d):', [Socket.RemoteHost, Socket.SocketHandle]);
//  fmWaitMsg.Label1.Caption:='已找到，正在连接。。。';
//  fmWaitMsg.Show;
end;

procedure TfmClient.Button2Click(Sender: TObject);
begin
  if not Self.ClientSocket1.Active then Exit;
  Self.ClientSocket1.Socket.SendText(Self.edtMsg.Text);
  Self.edtMsg.Text:='';
end;

procedure TfmClient.BitBtn1Click(Sender: TObject);
begin
  if not Self.ClientSocket1.Active then Exit;

  Self.ListView1.Clear;
  FCurrDir:= Self.edtDir.Text;
  Self.ClientSocket1.Socket.SendText('#ShareFile#'+FCurrDir);
end;

procedure TfmClient.AddFileList(sRecText: string);
var
  fNewItem: TListItem;
  //ssList: TStrings;
  iPos: Integer;
  sItem: string;
begin
  while sRecText<> '' do
  begin
    iPos:= Pos(';', sRecText);
    if iPos = 0 then
    begin
      sItem:= sRecText;
      sRecText:= '';
    end else
    begin
      sItem:= LeftStr(sRecText, iPos-1);
      Delete(sRecText, 1, iPos);
    end;

    if Trim(sItem) = '' then Continue;
    if LeftStr(sItem, 11) = '#ShareFile#' then Delete(sItem, 1, 11);

    fNewItem:= Self.ListView1.Items.Add;
    fNewItem.Caption:= LeftStr(sItem, 4);
    Delete(sItem, 1, 5);
    fNewItem.SubItems.Add(sItem);
  end;
end;

procedure TfmClient.ListView1DblClick(Sender: TObject);
var
  sItemName: string;
  function GetParentDir(sDir: string): string;
  var
    i, iLen: Integer;
  begin
    iLen:= Length(sDir);
    for i:= Length(sDir) downto 4 do
    begin
      Dec(iLen);
      if sDir[i] = '\' then Break;
    end;
    Result:= LeftStr(sDir, iLen);
  end;
begin
  if Self.ListView1.Selected.Caption <> '目录' then
  begin
    ShowMessage('当前不是目录，不能展开，只能下载啊！');
    Exit;
  end;

  sItemName:= Self.ListView1.Selected.SubItems[0];
  //Self.Memo2.Lines.Add('sItemName:'+sItemName);
  if sItemName = '..' then
  begin
    //返回父目录
    FCurrDir:= GetParentDir(FCurrDir);
    //Self.Edit1.Text:=
    //Self.Memo2.Lines.Add('上级目录：'+GetParentDir(FCurrDir));
  end else
  begin
    if FCurrDir <> '' then
    begin
      if RightStr(FCurrDir, 1) <> '\' then
        FCurrDir:= FCurrDir + '\';
      FCurrDir:= FCurrDir + sItemName;
    end else
      FCurrDir:= sItemName;
    //Self.Memo2.Lines.Add('打开目录：'+FCurrDir);
  end;

  Self.edtDir.Text:= FCurrDir;
  Self.ListView1.Clear;
  //Self.Memo2.Lines.Add('发送目录：'+FCurrDir);
  Self.ClientSocket1.Socket.SendText('#ShareFile#'+FCurrDir);
end;

procedure TfmClient.N1Click(Sender: TObject);
begin
  ShowMessage('下载选择的目录和文件！');
end;

end.
💿 文件大小 436 K
👤 上传用户 liyusheng1983
📂 所属分类 Delphi控件源码
🏷️ 相关标签

#delphi #SOCKET #程序
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -