delphpi tcp 服务和客户端 例子

//服务器端
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,Winapi.WinSock;

type
  clients = record
    soc :TSocket;
    add :sockaddr_in;
  end;
  pclients = ^clients;

  TForm1 = class(TForm)
    btn1: TButton;
    mmo1: TMemo;
    procedure btn1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    s :TSocket;
    acThreadID :DWORD;
  end;

  procedure ServerAccept(s :TSocket);stdcall;
  procedure SocketWorkThread(ns :TSocket);stdcall;
const
  buflen=;
var
  Form1: TForm1;

   clientslist :TList;

implementation

{$R *.dfm}

procedure  SocketWorkThread(ns :TSocket);stdcall;
var
   recvbuf :array[..buflen -] of Char;
   rtn,k :Integer;
   rs :string[buflen];
   rs2:string;
   error :string;
begin
   try
     while true do
     begin
       rtn := recv(ns,recvbuf,buflen,);
       if rtn <  then
       begin
         for k :=  to clientslist.Count - do
         begin
           if ns = pclients(clientslist.Items[k]).soc then
           begin
               freemem(clientslist.Items[k]); //zl 我自己增加的，感觉要释放下
               clientslist.Delete(k);
               Break;
           end
           else
             Continue;
         end;
         CLOSESOCKET(ns);
         error := IntToHex(ns,)+'退出';
         Form1.mmo1.Lines.Add(error);
         ExitThread();
       end;
       //rs := PChar(@recvbuf);
       rs2 := StrPas(recvbuf);
       //ShowMessage('rs=='+rs);
       Form1.mmo1.Lines.Add(rs2);
     end;
   except
   end;
end;

procedure  ServerAccept(s :TSocket);stdcall;
var
   ra :sockaddr_in;
   ra_len :integer;
   recev :TSocket;
   ThreadID :DWORD;
   ip :string;
   newclient :pclients;
begin
   ra_len := SizeOf(ra);
   try
     while True do
     begin
       recev := accept(s,@ra,@ra_len);
       if recev = - then
       begin
         ExitThread();
       end;
       ip := IntToHex(recev,)+'-'+ IntToStr(Ord(ra.sin_addr.S_un_b.s_b1))+'.'+
                 IntToStr(Ord(ra.sin_addr.S_un_b.s_b2))+'.'+
                 IntToStr(Ord(ra.sin_addr.S_un_b.s_b3))+'.'+
                 IntToStr(Ord(ra.sin_addr.S_un_b.s_b4));
       Form1.mmo1.Lines.Add(ip);
       GetMem(newclient,SizeOf(clients));
       newclient.soc := recev;
       newclient.add := ra;
       clientslist.Add(newclient);
       CreateThread(nil,,@SocketWorkThread,Pointer(recev),,ThreadID);
     end;
   except
   end;
end;

procedure TForm1.btn1Click(Sender: TObject);
var
 wsa:TWSAData;
 wsstatus:Integer;
  sa:sockaddr_in;
begin
  wsstatus := WSAStartup($,wsa);
  if wsstatus<>  then
   begin
     ShowMessage('初始化socket出错！');
     Exit;
   end;

   s := Socket(AF_INET,SOCK_STREAM,);
   if s <  then
   begin
     ShowMessage('创建socket出错！');
     WSACleanup;
     Exit;
   end;

   sa.sin_port := htons(StrToInt(''));
   sa.sin_family := AF_INET;
   sa.sin_addr.S_addr := INADDR_ANY;
   wsstatus := bind(s,sa,SizeOf(sa));
   if wsstatus <>  then
   begin
     ShowMessage('绑定socket出错');
     WSACleanup;
     Exit;
   end;

   wsstatus := listen(s,);
   if   wsstatus <>  then
   begin
     ShowMessage('监听出错！');
     WSACleanup;
     Exit;
   end;

   clientslist := TList.Create;
   CreateThread(nil,,@ServerAccept,Pointer(s),,acThreadID);
   btn1.Enabled := False;
   form1.Caption:= '服务端已启动';
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  clientslist.Free; //zl 我自己增加的，感觉要释放
end;

end.

//客户端

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs,Winapi.WinSock, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    btnCon: TButton;
    btnSend: TButton;
    btnDis: TButton;
    mmo1: TMemo;
    edtSend: TEdit;
    procedure btnConClick(Sender: TObject);
    procedure btnDisClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
  private
    { Private declarations }
  public
    s:TSocket;
  end;
procedure Receive(server :TSocket);stdcall;
const buflen = ;
var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure Receive(server :TSocket);stdcall;
var
   recbuf:array[..buflen -] of Char;
   rtn :Integer;
   rs :string;
begin
   while True do
   begin
       rtn := recv(server,recbuf,buflen,);
       if rtn <  then
       begin
           closesocket(server);
           ExitThread();
       end;
           rs := pchar(@recbuf);
       Form1.mmo1.Lines.Add(rs);
   end;
end;

procedure TForm1.btnConClick(Sender: TObject);
var
   sa :TWSAData;
   wstates :Integer;
   ad :sockaddr_in;
   threadid :DWORD;
begin
     wstates := WSAStartup($,sa);
     if   wstates <>  then
     begin
         ShowMessage('socket初始化出错！');
         Exit;
     end;

     s := socket(PF_INET,SOCK_STREAM,IPPROTO_IP);
     if s = INVALID_SOCKET then
     begin
         ShowMessage('建立socket出错！');
         WSACleanup;
         Exit;
     end;

     ad.sin_family := PF_INET;
     ad.sin_port := htons(StrToInt(''));
     ad.sin_addr.S_addr := inet_addr(PAnsiChar('127.0.0.1'));
     wstates := connect(s,ad,SizeOf(ad));
     if wstates <>  then
     begin
       ShowMessage('连接错误');
       WSACleanup;
       btnCon.Enabled := false;
       Exit;
     end;

   CreateThread(nil,,@Receive,Pointer(s),,threadid);
end;

procedure TForm1.btnDisClick(Sender: TObject);
begin
  try
    closesocket(s);
    WSACleanup;
  finally
    btnCon.Enabled := True;
  end;
end;

procedure TForm1.btnSendClick(Sender: TObject);
var
   sendbuf :array[..buflen -] of Char;
   sendLen :Integer;
   i :Integer;
begin
   if edtSend.Text <> '' then
   begin
     FillChar(sendbuf,,); //此处重要： 否则接收端 容易出现个别乱码现象

       for i :=  to Length(edtSend.Text) - do
           sendbuf[i] := (edtSend.Text)[i+];
       sendLen := send(s,sendbuf,buflen,);

       if sendLen <  then
       begin
           ShowMessage('发送出错');
           WSACleanup;
           btnCon.Enabled := False;
           Exit;
       end;
   end;
end;

end.