DELPHI异步选择模型UDP

unit U_FrmServer;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Winsock, StdCtrls;

const
WM_WINSOCK_ASYNC_MSG = WM_USER + 123;

type
TTestServer = class(TComponent)
private
FWindow: HWND;
FServerSocket: TSocket;
protected
procedure WndProc(var Msg: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure OpenServer;
end;

TfrmServer = class(TForm)
btnOpenServer: TButton;
procedure btnOpenServerClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FServer: TTestServer;
public
{ Public declarations }
end;

var
frmServer: TfrmServer;
WSData: TWSAData;

implementation

{$R *.DFM}

{ TTestServer }

constructor TTestServer.Create(AOwner: TComponent);
begin
inherited;
FWindow := INVALID_HANDLE_VALUE;
FServerSocket := INVALID_SOCKET;
end;

destructor TTestServer.Destroy;
begin
DeallocateHWnd(FWindow);
closesocket(FServerSocket);
inherited;
end;

procedure TTestServer.OpenServer;
var
addr: TSockAddrIn;
begin
if FWindow = INVALID_HANDLE_VALUE then
FWindow := AllocateHWnd(WndProc);

FServerSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_UDP);
addr.sin_family := AF_INET;
addr.sin_addr.S_addr := INADDR_ANY;
addr.sin_port := htons(9876);

bind(FServerSocket, addr, SizeOf(addr));

WSAAsyncSelect(FServerSocket, FWindow, WM_WINSOCK_ASYNC_MSG, FD_READ or FD_WRITE);
end;

procedure TTestServer.WndProc(var Msg: TMessage);
var
sEvent: TSocket;
nRecv: Integer;
sRecv: string;
begin
if Msg.Msg <> WM_WINSOCK_ASYNC_MSG then
begin
Msg.Result := DefWindowProc(FWindow, Msg.Msg, Msg.WParam, Msg.LParam);
Exit;
end;


//取得有事件发生的套接字
sEvent := Msg.WParam;
if WSAGetSelectError(Msg.lParam) <> 0 then
begin
closesocket(sEvent);
exit;
end;


//处理发生的事件
case WSAGetSelectEvent(Msg.lParam) of
FD_WRITE:
begin

end;
FD_READ:
begin
SetLength(sRecv, 1024);
nRecv := recv(sEvent, sRecv[1], 1024, 0);
if nRecv = -1 then
closesocket(sEvent)
else
begin
SetLength(sRecv, nRecv);
ShowMessage(sRecv);
end;
end;
end;
end;

procedure TfrmServer.btnOpenServerClick(Sender: TObject);
begin
FServer := TTestServer.Create(Self);
FServer.OpenServer;
end;

procedure TfrmServer.FormDestroy(Sender: TObject);
begin
FServer.Free;
end;

initialization
WSAStartup($0202, WSData);

finalization
WSACleanup;

end.