mailslot.pas

用于局域网的内部通信

{*******************************************************}
{                                                       }
{             MailSlot邮槽发送接收组件                  }
{                                                       }
{                yzhshi 2003.09.21                      }
{                                                       }
{       FWS组件，可免费使用  [e-mail]           }
{                                                       }
{                                                       }
{*******************************************************}

unit MailSlot;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, extctrls;

type
  TOnNewMessage = procedure(Sender: TObject; ASender, AReceiver, AText: String) of object;

  TMailSlotServer = class(TComponent)
  private
    FMailSlotName: String;                                  {MailSlot的名称}
    FSlotHandle: Thandle;                                   {MailSlot的句柄}
    FTimer: TTimer;                                         {定时读取MailSlot}
    FOnNewMessage: TOnNewMessage;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open;
    procedure Close;
  protected
    procedure OnTimer(Sender: TObject);
  published
    property MailSlotName: string read FMailSlotName write FMailSlotName;
    property OnNewMessage: TOnNewMessage read FOnNewMessage write FOnNewMessage;
  end;

  TMailSlotClient = class(TComponent)
  private
    FMailSlotName: string;
    FSender: String;                                        {发送人}
    FReceiver: String;                                      {接收人}
  public
    constructor Create(AOwner: TComponent); override;
    function Send(AText: string): boolean;
  published
    property MailSlotName: string read FMailSlotName write FMailSlotName;
    property Sender: String read FSender write FSender;
    property Receiver: String read FReceiver write FReceiver;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('MailSlot', [TMailSlotServer, TMailSlotClient]);
end;

{===============================================================================}
constructor TMailSlotServer.Create(AOwner: TComponent);
begin
  inherited;
  FMailSlotName := 'messngr';
  FTimer := TTimer.Create(nil);
  FTimer.Enabled := False;
  FTimer.OnTimer := OnTimer;
  FTimer.Interval := 500;
end;

destructor TMailSlotServer.Destroy;
begin
  Close;
  FTimer.Free;
  inherited;
end;

{打开邮槽}
procedure TMailSlotServer.Open;
begin
  FSlotHandle := CreateMailSlot(PChar('\\.\mailslot\' + MailSlotName), 0, MAILSLOT_WAIT_FOREVER, nil);
  if FSlotHandle = INVALID_HANDLE_VALUE then
    raise Exception.Create('TMailSlotServer:邮槽创建失败！');

  FTimer.Enabled := True;
end;

{关闭邮槽}
procedure TMailSlotServer.Close;
begin
  FTimer.Enabled := False;
  if FSlotHandle <> 0 then
    CloseHandle(FSlotHandle);
  FSlotHandle := 0;
end;

{读取邮槽信息}
procedure TMailSlotServer.OnTimer(Sender: TObject);
var
  lNextSize, lMsgCount, lByteRead: DWord;
  lReceiveBuffer: PChar;                                    {接收的Buffer}
  lSender, lReceiver, lText: String;
  i, j: Integer;
begin
  if not GetMailSlotInfo(FSlotHandle, nil, DWORD(lNextSize), @lMsgCount, nil) then
  begin
    Close;
    raise Exception.Create('TMailSlotServer:获取邮槽信息失败！');
  end;

  if lNextSize <> MAILSLOT_NO_MESSAGE then
  begin
    lReceiveBuffer := AllocMem(lNextSize);
    try
      if ReadFile(FSlotHandle, lReceiveBuffer[0], lNextSize, lByteRead, nil) then
      begin
        {分解，得到发送者、接收者、发送内容}
        j := 0;
        lSender := '';
        lReceiver := '';
        lText := '';

        for i := 0 to lByteRead - 1 do
        begin
          if lReceiveBuffer[i] = #0 then
          begin
            j := j + 1;
            Continue;
          end;
          case j of
            0: lSender := lSender + lReceiveBuffer[i];
            1: lReceiver := lReceiver + lReceiveBuffer[i];
          else
            lText := lText + lReceiveBuffer[i];
          end;
        end;

        if Assigned(OnNewMessage) then
          OnNewMessage(Self, lSender, lReceiver, lText);
      end
      else
      begin
        Close;
        raise Exception.Create('TMailSlotServer:读取邮槽信息失败！');
      end;
    finally
      FreeMem(lReceiveBuffer);
    end;
  end;

  if lMsgCount > 1 then
    OnTimer(Sender);
end;

{===============================================================================}
constructor TMailSlotClient.Create(AOwner: TComponent);
var
  LogName: PChar;
  Len: Cardinal;
begin
  inherited;
  FMailSlotName := 'messngr';
  FReceiver := '';

  GetMem(LogName, 255);
  Len := 255;
  GetUserName(LogName, Len);                                //WNetGetUser(nil, LogName, Len);也可以
  FSender := String(LogName);
  FreeMem(LogName);
end;

{-------------------------------------------------------------------------------}
function TMailSlotClient.Send(AText: string): Boolean;
var
  lFileHandle: THandle;
  lSendText: String;
  lWriteLength: DWord;
begin
  if FReceiver = '' then
    FReceiver := '.';
  lFileHandle := CreateFile(PChar('\\' + FReceiver + '\mailslot\' + FMailSlotName), GENERIC_WRITE,
    FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if lFileHandle <> INVALID_HANDLE_VALUE then
  begin
    lSendText := FSender + #0 + FReceiver + #0 + AText + #0;
    Result := WriteFile(lFileHandle, Pointer(lSendText)^, Length(lSendText), lWriteLength, nil);
    CloseHandle(lFileHandle);
  end
  else
    Result := False;
end;


end.