almailslot.pas

局域网消息广播

{
  ALMailSlot v1.06

  (C)1999-2000 Andrew Leigh
  http://www.alphalink.com.au/~leigh/components

  Description:
    ALMailSlot is a component which allows applications to send messages across
    a network using mailslots.

  History:
    v1.0  26-Jun-1999 Inital release.
    v1.01 08-Aug-1999 Made the thread execution procedure more time efficient.
    v1.02 03-Oct-1999 Fixed problem when sending multiple lines of text that
                      contained carriage returns.
    v1.03 28-Nov-1999 Fixed memory leak when receiving messages due to not
                      closing a handle. Only allow 8 characters to be used for
                      the MailBox property. Removed 'Time' parameter from the
                      new message event and replaced it with 'UserName'.
    v1.04 16-Dec-1999 When the component checks for new messages, it will now
                      read all messages from the queue instead of one message.
    v1.05 13-Aug-2000 Fixed problem with altering Active property at run-time.
                      When the Active property is set back to true after being
                      false, the component will now successfully receive new
                      messages.
    v1.06 16-Sep-2000 I had forgotten to reset the buffer length after getting
                      the computer name in the constructor, so sometimes the
                      username was not retrieved properly. This has been fixed.
}

unit ALMailSlot;

interface

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

type
  TALMailSlot = class;
  TNewMessage = procedure(Sender: TObject; Computer, UserName, Text: String) of Object;

  TCheckThread = class(TThread)
  private
    MailSlot: TALMailSlot;
  protected
    procedure Execute; override;
  end;

  TALMailSlot = class(TComponent)
  private
    fMailBox: String;
    fActive: Boolean;
    CheckThread: TCheckThread;
    LocalHandle, RemoteHandle: THandle;
    LocalPath, RemotePath: String;
    fCheckInterval: Integer;
    MessageSize, MessageCount: DWord;
    InMessage: TStringList;
    OutMessage: TStringList;
    fComputer: String;
    fUserName: String;
    fNewMessage: TNewMessage;
    CheckThreadRunning: Boolean;
    fThreadPriority: TThreadPriority;
    procedure StartThread;
    procedure SetActive(const Value: Boolean);
    procedure ReadMessage;
    procedure MailStrings(Recipient: String);
    procedure SetMailBox(const Value: String);
    procedure SetThreadPriority(const Value: TThreadPriority);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SendMessage(Recipient, Text: String);
    procedure Broadcast(Text: String);
    property Computer: String                 read fComputer;
    property UserName: String                 read fUserName;
  published
    property MailBox: String                  read fMailBox         write SetMailBox;
    property Active: Boolean                  read fActive          write SetActive         default False;
    property CheckInterval: Integer           read fCheckInterval   write fCheckInterval    default 1000;
    property ThreadPriority: TThreadPriority  read fThreadPriority  write SetThreadPriority default tpNormal;
    property OnNewMessage: TNewMessage        read fNewMessage      write fNewMessage;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('ALComps', [TALMailSlot]);
end;

{ TALMailSlot }

constructor TALMailSlot.Create(AOwner: TComponent);
var
  Temp: Array[0..255] of Char;
  Size: DWord;
begin
  inherited;

  fMailBox := 'MailBox';
  fActive := False;
  fCheckInterval := 1000;
  fThreadPriority := tpNormal;

  OutMessage := TStringList.Create;
  InMessage := TStringList.Create;
  Size := 255;
  GetComputerName(Temp, Size);
  fComputer := StrPas(Temp);
  Size := 255;
  GetUserName(Temp, Size);
  fUserName := StrPas(Temp);

  CheckThreadRunning := False;
end;

destructor TALMailSlot.Destroy;
begin
  if fActive then
    Active := False;

  InMessage.Free;
  OutMessage.Free;

  inherited;
end;

procedure TALMailSlot.SendMessage(Recipient, Text: String);
begin
  InMessage.Text := Text;
  with InMessage do
  begin
    Insert(0, 'Message');
    Insert(1, fUserName);
    Insert(2, fComputer);
  end;
  MailStrings(Recipient);
end;

procedure TALMailSlot.Broadcast(Text: String);
begin
  InMessage.Text := Text;
  with InMessage do
  begin
    Insert(0, 'Message');
    Insert(1, fUserName);
    Insert(2, fComputer);
  end;
  MailStrings('*');
end;

procedure TALMailSlot.MailStrings(Recipient: String);
var
  Bytes: DWord;
begin
  RemotePath := '\\' + Recipient + '\mailslot\' + fMailBox;
  RemoteHandle := CreateFile(PChar(RemotePath), GENERIC_WRITE, FILE_SHARE_READ, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  try
    if RemoteHandle = INVALID_HANDLE_VALUE then
      Exit
    else
      WriteFile(RemoteHandle, Pointer(InMessage.Text)^, Length(InMessage.Text), Bytes, nil);
  finally
    CloseHandle(RemoteHandle);
  end;
end;

procedure TALMailSlot.SetActive(const Value: Boolean);
begin
  if fActive <> Value then
  begin
    fActive := Value;
    if fActive and CheckThreadRunning then
      Exit
    else if fActive and not(csDesigning in ComponentState) then
      StartThread
    else if not fActive and not(csDesigning in ComponentState) then
    begin
      CheckThreadRunning := False;
      CheckThread.Terminate;
      CheckThread.WaitFor;
      CloseHandle(LocalHandle);
      CheckThread.Free;
      CheckThread := nil;
    end;
  end;
end;

procedure TALMailSlot.StartThread;
begin
  LocalPath := '\\.\mailslot\' + fMailBox;
  LocalHandle := CreateMailSlot(PChar(LocalPath), 0, 0, nil);
  if LocalHandle = INVALID_HANDLE_VALUE then
    fActive := False
  else
  begin
    if not(csDesigning in ComponentState) then
    begin
      CheckThread := TCheckThread.Create(True);
      CheckThread.MailSlot := Self;
      CheckThread.Priority := fThreadPriority;
      CheckThreadRunning := True;
      CheckThread.Resume;
    end;
  end;
end;

procedure TALMailSlot.ReadMessage;
var
  NewMessage, TempComputer, TempUserName: String;
  Bytes: DWord;
begin
  SetLength(NewMessage, MessageSize);
  ReadFile(LocalHandle, PChar(NewMessage)^, MessageSize, Bytes, nil);
  OutMessage.Clear;
  OutMessage.Text := NewMessage;
  if (OutMessage[0] = 'Message') and Assigned(fNewMessage) then
  begin
    TempComputer := OutMessage[2];
    TempUserName := OutMessage[1];
    OutMessage.Delete(0); OutMessage.Delete(0); OutMessage.Delete(0);
    fNewMessage(Self, TempComputer, TempUserName, OutMessage.Text);
  end;
end;

procedure TALMailSlot.SetMailBox(const Value: String);
begin
  if fMailBox <> Value then
  begin
    if Length(Value) > 8 then
    begin
      MessageDlg('MailBox name cannot be greater than 8 characters long.', mtWarning, [mbOk], 0);
      Exit;
    end;
    fMailBox := Value;
    if fActive then
    begin
      SetActive(False);
      SetActive(True);
    end;
  end;
end;

procedure TALMailSlot.SetThreadPriority(const Value: TThreadPriority);
begin
  if fThreadPriority <> Value then
  begin
    fThreadPriority := Value;
    if not(csDesigning in ComponentState) and (CheckThread <> nil) then
      CheckThread.Priority := fThreadPriority;
  end;
end;

{ TCheckThread }

procedure TCheckThread.Execute;
var
  ThreadWaitInterval, NextTime: Integer;
begin
  if MailSlot.fCheckInterval > 1000 then
    ThreadWaitInterval := 1000
  else
    ThreadWaitInterval := MailSlot.fCheckInterval;

  if ThreadWaitInterval = 1000 then
  begin
    NextTime := MaxInt;
    while not Terminated do
    begin
      if NextTime >= MailSlot.fCheckInterval then
      begin
        GetMailSlotInfo(MailSlot.LocalHandle, nil, MailSlot.MessageSize, @MailSlot.MessageCount, nil);
        while MailSlot.MessageCount > 0 do
        begin
          Synchronize(MailSlot.ReadMessage);
          GetMailSlotInfo(MailSlot.LocalHandle, nil, MailSlot.MessageSize, @MailSlot.MessageCount, nil);
        end;
        NextTime := 0;
      end;
      Sleep(1000);
      Inc(NextTime, 1000);
    end;
  end
  else
  begin
    while not Terminated do
    begin
      GetMailSlotInfo(MailSlot.LocalHandle, nil, MailSlot.MessageSize, @MailSlot.MessageCount, nil);
      while MailSlot.MessageCount > 0 do
      begin
        Synchronize(MailSlot.ReadMessage);
        GetMailSlotInfo(MailSlot.LocalHandle, nil, MailSlot.MessageSize, @MailSlot.MessageCount, nil);
      end;
      Sleep(ThreadWaitInterval);
    end;
  end;
end;

end.