main.pas

利用Windows的 “邮槽” 功能进行局域网内通讯。

{*******************************************************}
{                                                       }
{           MailSlot邮槽发送接收测试程序                }
{                                                       }
{                yzhshi 2003.09.21                      }
{                                                       }
{       FWS组件，可免费使用  [e-mail]           }
{                                                       }
{                                                       }
{*******************************************************}
(*------------------------------------------------------------------------------
说明：
   本程序为组件MailSlot.pas(TMailSlotServer、TMailSlotClient)的测试程序。
   采用动态创建TMailSlotServer 和 TMailSlotClient 两个控件的方式，因此可以不用安装控件就可以编译。

   本程序可以免费使用。有任何建议可以给我发email 或者到大富翁论坛(www.Delphibbs.com)去讨论。

   因为写的很仓促，所以控件的图标选择不是很恰当，如果那位使用了，并且找到了很好很合适表达意思的图标。
请更换一下，同时如果可能，请将图标发给我一份。更换方法，使用Image Editor打开MailSlot.dcr就可以了。

    同时，如果您修改了MailSlot的源码，也可以给我发一份，我也做更新。   
-------------------------------------------------------------------------------*)
unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Buttons, ExtCtrls;

type
  TFrmMain = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    bbtnSend: TBitBtn;
    bbtnExit: TBitBtn;
    pnlChat: TPanel;
    reText: TRichEdit;
    reHistory: TRichEdit;
    Panel3: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    cbReceiver: TComboBox;
    edtSender: TEdit;
    chkEnter: TCheckBox;
    procedure FormDestroy(Sender: TObject);
    procedure bbtnSendClick(Sender: TObject);
    procedure reTextKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure cbReceiverExit(Sender: TObject);
    procedure bbtnExitClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    procedure MailSlotServerNewMessage(Sender: TObject; ASender, AReceiver, AText: String);
    Procedure SendMsg;
  public
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;

implementation

{$R *.DFM}

uses
  MailSlot;

var
  MailSlotServer: TMailSlotServer;
  MailSlotClient: TMailSlotClient;

procedure TFrmMain.FormShow(Sender: TObject);
begin
  {MailSlot服务端}
  MailSlotServer := TMailSlotServer.Create(Self);
  MailSlotServer.OnNewMessage := MailSlotServerNewMessage;
  try
    MailSlotServer.Open;
  except
    Application.MessageBox('不能打开邮件槽，系统将不能接收到其他计算机发送的消息！', '错误', 48 + mb_ok);
  end;

  {MailSlot客户端}
  MailSlotClient := TMailSlotClient.Create(Self);
  edtSender.Text := MailSlotClient.Sender;
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
begin
  MailSlotServer.Close;
  MailSlotServer.Destroy;
end;

procedure TFrmMain.MailSlotServerNewMessage(Sender: TObject; ASender,
  AReceiver, AText: String);
begin
  reHistory.Lines.Add('发送人：' + ASender + '；发送时间：' + FormatDateTime('yyyy-mm-dd HH:MM:SS', Now));
  reHistory.Lines.Add('接收人：' + AReceiver);
  reHistory.Lines.Add(AText);
  reHistory.Lines.Add('');

  reHistory.SelStart := reHistory.Perform(EM_LINEINDEX, reHistory.Lines.Count, 0);
  reHistory.Perform(EM_SCROLLCARET, 0, 0);
end;

procedure TFrmMain.bbtnSendClick(Sender: TObject);
begin
  SendMsg;
end;

procedure TFrmMain.reTextKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if chkEnter.Checked or ((not chkEnter.Checked) and (Shift = [ssCtrl])) then
  begin
    if Key = 13 then
    begin
      Key := 0;
      SendMsg;
    end;
  end
end;

procedure TFrmMain.SendMsg;
begin
  MailSlotClient.Sender := edtSender.Text;
  MailSlotClient.Receiver := cbReceiver.Text;
  if MailSlotClient.Send(reText.Text) then
  begin
    {
    reHistory.Lines.Add('发送人：' + edtSender.Text + '；发送时间：' + FormatDateTime('yyyy-mm-dd HH:MM:SS', Now));
    reHistory.Lines.Add('接收人：' + cbReceiver.Text);
    reHistory.Lines.Add(reText.Text);
    reHistory.Lines.Add('');
    reHistory.SelStart := reHistory.Perform(EM_LINEINDEX, reHistory.Lines.Count, 0);
    reHistory.Perform(EM_SCROLLCARET, 0, 0);
    }
  end
  else
    reHistory.Lines.Add('发送失败！');

  reText.Clear;
  reText.SetFocus;
end;

procedure TFrmMain.cbReceiverExit(Sender: TObject);
begin
  if cbReceiver.Items.IndexOf(cbReceiver.Text) = -1 then
    cbReceiver.Items.Add(cbReceiver.Text);
end;

procedure TFrmMain.bbtnExitClick(Sender: TObject);
begin
  Close;
end;


end.