//服务器端
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.