Net Send Mailslot selbst verarbeiten!

[alzaimar]

Hier mal eine uralte Unit von mir, die Mails mit einer bekannten maximalen Länge verschicken kann:
Instanziiere einen TMailReceiver in den Anwendungen, die Mails empfangen sollen und weise das den 'SlotName' sowie das OnMailReceived-Ereignis zu. Starte den Receiver mit 'Start', beende ihn mit 'Stop'.

Verschicke eine Mail an einen Computer mit 'SendMail'. Wenn Du als Computernamen '*' angibst, wird die Mail an alle Rechner verschickt.

Die Unit ist gefühlte 79 Jahre alt und stammt noch aus den Anfängen meiner Delphi-Zeit. Ich würde mich freuen, wenn Jemand diese Unit auf Vordermann bringt und verbessert.

Delphi-Quellcode:

unit csMail;

interface
uses Classes;
Type
  TMailReceiveEvent = Procedure (Sender : TObject; aMessage : TStrings) of Object;
  TMailReceiver = Class (TThread)
  private
    fMaxLength : Integer;
    fHandle : THandle;
    fOnMail : TMailReceiveEvent;
    fMessage : String;
    fSlotName: String;
    procedure DoOnMailReceived;
  Protected
    Procedure Execute; Override;
  Public
    Constructor Create (aSlotName : String; aMaxLength : Integer);
    Destructor Destroy; Override;
    Procedure Start;
    Procedure Stop;
    Property OnMailReceived : TMailReceiveEvent Read fOnMail Write fOnMail;
    Property SlotName : String Read fSlotName;
    End;

Procedure SendMail (aComputer, aSlotName, aMessage : String);
Function CsGetComputerName:String;

implementation
uses windows, SysUtils;

Function CsGetComputerName:String;
var
  le: DWORD;

begin
   le:=63;
   SetLength(result,le);
   if GetComputerName(PChar(result),le) then
     SetLength(result, le)
   else
     result:= '??';
End;

///////////////////////////////////////////////////////////////////////////////
// SendMail: Send a Mail 'aMessage' to the Mailslot 'aSlotName' on the       //
//   Machine 'aComputer'                                                     //
///////////////////////////////////////////////////////////////////////////////
Procedure SendMail (aComputer, aSlotName, aMessage : String);
var
  Bytes: DWord;
  aPath : String;
  aHandle : THandle;

begin
  aPath := '\\' + aComputer + '\mailslot\' + aSlotName;
  aHandle := CreateFile(PChar(aPath), GENERIC_WRITE, FILE_SHARE_READ, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
  try
    if aHandle = INVALID_HANDLE_VALUE then
      Raise EInOutError.CreateFmt('Cannot create mailslot %s\%s',[aComputer,aSlotName])
    else
      If not WriteFile(aHandle, Pointer(aMessage)^, Length(aMessage), Bytes, nil)
        Then Raise EInOutError.CreateFmt('Cannot write to mailslot %s\%s',[aComputer,aSlotName]);
  finally
    if aHandle <> INVALID_HANDLE_VALUE Then
      CloseHandle(aHandle);
    end;
end;

{ TMailReceiver }

///////////////////////////////////////////////////////////////////////////////
// Object : TMailReceiver                                                    //
///////////////////////////////////////////////////////////////////////////////
constructor TMailReceiver.Create(aSlotName : String; aMaxLength : Integer);
Var
  aPath : String;

begin
  Inherited Create (True);
  fSlotName := aSlotName;
  fMaxLength := aMaxLength;
  aPath := '\\.\mailslot\' + aSlotName;
  fHandle := CreateMailSlot(PChar(aPath), 0, MAILSLOT_WAIT_FOREVER, nil);
end;

destructor TMailReceiver.Destroy;
begin
  Terminate;
  CloseHandle (fHandle);
end;

procedure TMailReceiver.DoOnMailReceived;
Var
  s : TStringList;

begin
  if Assigned (fOnMail) And (Length (fMessage)>0 ) Then begin
    s := TStringList.Create;
    Try
      s.Text := fMessage;
      fOnMail (Self, s);
    Finally
      s.free
      end
    End;
end;

procedure TMailReceiver.Execute;
Var
  aSize : DWord;

begin
  While Not Terminated Do Begin
    SetLength (fMessage, fMaxLength);
    if ReadFile(fHandle, PChar(fMessage)^, fMaxLength, aSize, nil) Then
      If not terminated Then
        SetLength (fMessage, aSize);
    if not terminated then
      Synchronize (DoOnMailReceived);
    End
end;

procedure TMailReceiver.Start;
begin
  Resume;
end;

procedure TMailReceiver.Stop;
begin
  Try
    Terminate;
    SetMailslotInfo (fHandle,0);
  Except
    End;
end;

end.