Delphi组播控件forD6

    写了一个局域网版的五子棋，用到了组播技术，整理了一个控件代码，希望对初次使用组播技术的人有帮助。在D6下调试通过。

unit MulticastSocket;

{
    * 多址广播控件
    * 本文件提取自 U_UDPSock.pas
    * 整理于2001年11月17~2001年11月18日
    * 关于 NB30 单元，主要用于
    *   "取得本地计算机所有的MAC地址"
    *   procedure LocalMAC(slMac : TStringList);
    * 所以被我注释掉了
    * 并不影响使用
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  WinSock, activeX;//, NB30;

const
  MINBUFFERSIZE = 2048;
  DEFAULTBUFFERSIZE = 16384;
  MAXBUFFERSIZE = 63488; //62*1024
  MULTICAST_TTL = IP_DEFAULT_MULTICAST_TTL;
  MAX_MULTICAST_TTL = 128;

type
  PIP_mreq = ^TIP_mreq;
  TIP_mreq = record
     imr_multiaddr  : in_addr;
     imr_interface  : in_addr;
  end;

  TAPInAddr = Array [0..10] of PInAddr; // array of pInaddr
  PAPInAddr = ^TAPInaddr;               // pointer of Array

  (*
  PASTAT = ^TASTAT;
  TASTAT = record
    adapter : TAdapterStatus;
    name_buf : TNameBuffer;
  end;
  *)

  TUDPOnRecv = procedure (buffer: Pointer; len: integer; fromIP: string; fromPort: u_Short) of Object;

  //接收数据线程
  TUDPRecvThd = class(TThread)
    private
      fSocks : TSocket;
      fBufSize : integer;
      fOnRecv : TUDPOnRecv;
    protected
      procedure Execute ; override;
    public
      constructor Create(var Socks : TSocket; OnRecv : TUDPOnRecv; BufSize : integer);
  end;

type
  TMulticastSocket = class(TComponent)
  private
    { Private declarations }
    fActived    : Boolean;      {是否激活}

    fsock       : TSocket;      {socket}
    fRecvThd    : TUDPRecvThd;  {接收线程}
    fMCReq      : TIP_mreq;     {记录加入的组地址，释放资源时用}
    fSendBufSize: integer;      {发送缓冲区大小}
    fRecvBufSize: integer;      {接收缓冲区大小}
    fLocalIP    : String;       {本地IP地址}
    fAddrTo     : TSockAddr;    {发送IP地址}
    fCanRead    : Boolean;      {可以读取数据}
    fCanWrite   : Boolean;      {可以发送数据}
    fTTL        : integer;      {Time To Live,生存时间,即可以跨越的网关数}
    fGroupAddress:String;       {组地址}
    fGroupPort  : integer;      {组端口}
    //fRecvState  : Boolean;      {接收线程是否启动}
    fOnRecv     : TUDPOnRecv;   {响应的事件}

    {组地址}
    procedure SetGroupAddress(addr:String);
    {组端口}
    procedure SetGroupPort(port:integer);
    {读}
    procedure SetCanRead(CanRead:Boolean);
    {写}
    procedure SetCanWrite(CanWrite:Boolean);
    {发送缓冲区大小}
    procedure SetSendBufSize(SendBufSize:integer);
    {接收缓冲区大小}
    procedure SetRecvBufSize(RecvBufSize:integer);
    {本地IP地址}
    procedure SetLocalIP(addr:String);
    {是否激活}
    procedure SetActived(const Value: Boolean);
    {Time To Live,生存时间,即可以跨越的网关数}
    procedure SetTTL(const Value: integer);

    {改变响应事件的限制}
    //procedure SetOnRecv(const Value: Boolean);
    procedure SetOnRecv(const Value: TUDPOnRecv);

    {Local IP set valid?}
    {参数为''的话，就得到默认IP}
    function  LocalIPValid(var LocalIP:String) : Boolean;

    {设置Socket可以接收数据}
    function  EnabledListen:Boolean;
    {设置Socket不能接收数据}
    procedure DisabledListen;
    {设置Socket可以发送数据}
    function  EnabledSend:Boolean;
  protected
    { Protected declarations }
  public
    { Public declarations }
    function    Close:Boolean;
    function    Send(buffer : Pointer; len : integer ; Flag : integer = 0) : Boolean;
    function    AddToGroup : integer;
    procedure   StartReceive;

    {取得本地计算机所有的IP地址}
    procedure LocalIPs(slIPs : TStringList);
    {取得本地计算机所有的MAC地址}
    //procedure LocalMAC(slMac : TStringList);

    function  Connect:Boolean;
    function  DisConnect:Boolean;
  published
    { Published declarations }
    property    LocalAddress : String read fLocalIP write SetLocalIP nodefault;
    property    CanRead  : Boolean read fCanRead  write SetCanRead  default true;
    property    CanWrite : Boolean read fCanWrite write SetCanWrite default true;
    property    TTL : integer read fTTL write SetTTL default MULTICAST_TTL;
    property    SendBufSize: integer read fSendBufSize write SetSendBufSize default DEFAULTBUFFERSIZE;
    property    RecvBufSize: integer read fRecvBufSize write SetRecvBufSize default DEFAULTBUFFERSIZE;
    property    GroupAddress:String read fGroupAddress write SetGroupAddress nodefault;
    property    GroupPort:integer read fGroupPort write SetGroupPort default 6000;
    property    Actived:Boolean read fActived write SetActived default False;

    property    OnDataArrive:TUDPOnRecv read fOnRecv write SetOnRecv nodefault;

    constructor Create(AOwner:TComponent);override;
    destructor  Destroy;override;
  end;

procedure Register;

implementation

var
  wsData : TWSAData;

procedure Register;
begin
  RegisterComponents('FastNet', [TMulticastSocket]);
end;

{ TMulticastSocket }

function TMulticastSocket.AddToGroup:integer;
var
  nReuseAddr : integer;
  SockAddrLocal : TSockAddr;
  pPE : PProtoEnt;
begin
  Result:=-1;

  pPE := GetProtoByName('UDP');
  //Create Socket
  fSock := Socket(AF_INET, SOCK_DGRAM, pPE.p_proto);
  if fSock = INVALID_SOCKET then
    Exit;

  nReuseAddr := 1;
  if SetSockOpt(fSock, SOL_SOCKET, SO_REUSEADDR, @nReuseAddr, SizeOf(integer)) = SOCKET_ERROR then
  begin
    CloseSocket(fSock);
    Exit;
  end;

  //Set Local Address and bind
  FillChar(SockAddrLocal, SizeOf(SockAddrLocal), 0);
  SockAddrLocal.sin_family := AF_INET;
    //发送用0
    //SockAddrLocal.sin_port := htons(0);
  SockAddrLocal.sin_port := htons(fGroupPort);
  SockAddrLocal.sin_addr.S_addr := Inet_Addr(PChar(fLocalIP));
  if Bind(fSock, SockAddrLocal, SizeOf(SockAddrLocal)) = SOCKET_ERROR then
  begin
    CloseSocket(fSock);
    Exit;
  end;

    if fCanWrite then
        if not EnabledSend then
            Exit;

    if fCanRead then
        if not EnabledListen then
            Exit;

    Result:=0;
end;

function TMulticastSocket.Close: Boolean;
begin
    //MulticastReceiver
    //Exception will be? :( I don't know
    //释放接收数据线程
    if fRecvThd <> nil then
    begin
        fRecvThd.Suspend;
        //fRecvThd.Free;
        fRecvThd := nil;
    end;

    DisabledListen;
    //Close Socket
    CloseSocket(fSock);
    Result:=True;
end;

?/P>