main.pas

用于局域网的内部通信

unit Main;

interface

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

type
  TFrmMain = class(TForm)
    Panel1: TPanel;
    MainMenu1: TMainMenu;
    F1: TMenuItem;
    StopMessenger: TMenuItem;
    StartMessenger: TMenuItem;
    Start: TMenuItem;
    Stop: TMenuItem;
    Exit: TMenuItem;
    M1: TMenuItem;
    H1: TMenuItem;
    A1: TMenuItem;
    N1: TMenuItem;
    Enter1: TMenuItem;
    Panel2: TPanel;
    GroupBox2: TGroupBox;
    reHistory: TRichEdit;
    Panel3: TPanel;
    GroupBox1: TGroupBox;
    reText: TRichEdit;
    Panel4: TPanel;
    GroupBox4: TGroupBox;
    edtSender: TEdit;
    Panel5: TPanel;
    GroupBox3: TGroupBox;
    cbReceiver: TComboBox;
    cbWorkgroup: TComboBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    cbUsers: TComboBox;
    miIP: TMenuItem;
    miMachine: TMenuItem;
    N4: TMenuItem;
    Timer1: TTimer;
    Timer2: TTimer;
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure bbtnSendClick(Sender: TObject);
    procedure cbReceiverExit(Sender: TObject);
    procedure reHistoryKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure StartMessengerClick(Sender: TObject);
    procedure StopMessengerClick(Sender: TObject);
    procedure StartClick(Sender: TObject);
    procedure StopClick(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure cbWorkgroupChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure cbUsersChange(Sender: TObject);
    procedure cbReceiverChange(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure Timer2Timer(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, NetFunctions;

var
  MailSlotServer: TMailSlotServer;
  MailSlotClient: TMailSlotClient;

procedure TFrmMain.FormShow(Sender: TObject);
var
  Workgroups: TStringList;
begin
  {MailSlot服务端}
  MailSlotServer := TMailSlotServer.Create(Self);
  MailSlotServer.OnNewMessage := MailSlotServerNewMessage;
  {MailSlot客户端}
  MailSlotClient := TMailSlotClient.Create(Self);
  edtSender.Text := MailSlotClient.Sender;

  StartClick(nil);

  Workgroups := TStringList.Create;
  if GetServerList(Workgroups) then begin
    cbWorkgroup.Items.Assign(Workgroups); cbWorkgroup.ItemIndex := 0;
  end;
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
begin
  MailSlotServer.Close;
  MailSlotServer.Destroy;
  StartMessengerClick(nil);
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.reHistoryKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Enter1.Checked or ((not Enter1.Checked) and (Shift = [ssCtrl])) then begin
    if Key = 13 then begin
      Key := 0;
      SendMsg;
    end;
  end
end;

procedure TFrmMain.SendMsg;
var
  astart, aend: Integer;
begin
  MailSlotClient.Sender := edtSender.Text;
  if miIP.Checked then
    MailSlotClient.Receiver := cbReceiver.Text
  else if miMachine.Checked then
    MailSlotClient.Receiver := cbUsers.Text;

  if MailSlotClient.Send(reText.Text) then
  begin
    astart := reHistory.SelStart;
    reHistory.Lines.Add('发送人：' + edtSender.Text + '；发送时间：' + FormatDateTime('yyyy-mm-dd HH:MM:SS', Now));
    reHistory.Lines.Add('接收人：' + MailSlotClient.Receiver);
    reHistory.Lines.Add(reText.Text);
    reHistory.Lines.Add('');
    reHistory.SelStart := reHistory.Perform(EM_LINEINDEX, reHistory.Lines.Count, 0);
    reHistory.Perform(EM_SCROLLCARET, 0, 0);

    { 发送文本的颜色 }
    aend := reHistory.SelStart;
    reHistory.SelStart := astart;
    reHistory.SelLength := aend - astart;
    reHistory.SelAttributes.Color := clBlue;
    reHistory.SelStart := aend;
  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.StartMessengerClick(Sender: TObject);
begin
  WinExec('cmd.exe /c net start Messenger', SW_HIDE);
end;

procedure TFrmMain.StopMessengerClick(Sender: TObject);
begin
  WinExec('cmd.exe /c net stop Messenger', SW_HIDE);
end;

procedure TFrmMain.StartClick(Sender: TObject);
begin
  try
    MailSlotServer.Open;
    Start.Enabled := False;
    Stop.Enabled := True;
  except
    Start.Enabled := True;
    Stop.Enabled := False;
    Application.MessageBox('启动失败！', '错误', 48 + mb_ok);
  end;
end;

procedure TFrmMain.StopClick(Sender: TObject);
begin
  MailSlotServer.Close;
  Start.Enabled := True;
  Stop.Enabled := False;
end;

procedure TFrmMain.A1Click(Sender: TObject);
begin
  ShowMessage('如果启动时显示"启动失败！"，'#13'可以先通过"信使"->"停止信使服务"，'#13'然后再"文件"->"启动"看看。');
end;

procedure TFrmMain.cbWorkgroupChange(Sender: TObject);
var
  UserList: TStringList;
begin
  UserList := TStringList.Create;
  Screen.Cursor := crHourGlass;
  if GetUsers(cbWorkgroup.Text, UserList) then begin
    cbUsers.Items.Assign(UserList); cbUsers.ItemIndex := 0;
  end;
  Screen.Cursor := crDefault;
end;

procedure TFrmMain.FormCreate(Sender: TObject);
var
  WSAData: TWSAData;
begin
  WSAStartup(2, WSAData);
end;

procedure TFrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  WSACleanup;
end;

procedure TFrmMain.cbUsersChange(Sender: TObject);
begin
  Timer2.Enabled := False;
  Timer1.Enabled := False;
  Timer1.Enabled := True;
end;

procedure TFrmMain.cbReceiverChange(Sender: TObject);
begin
  Timer1.Enabled := False;
  Timer2.Enabled := False;
  Timer2.Enabled := True;
end;

procedure TFrmMain.Timer1Timer(Sender: TObject);
var
  HostEnt: PHostEnt;
  sComputerName, sIP: string;
begin
  Timer1.Enabled := False;
  sComputerName := cbUsers.Text;
  HostEnt := GetHostByName(PChar(sComputerName));
  Screen.Cursor := crHourGlass;
  if HostEnt <> nil then
  begin
    with HostEnt^ do
      sIP := Format('%d.%d.%d.%d', [Byte(h_addr^[0]), Byte(h_addr^[1]), Byte(h_addr^[2]), Byte(h_addr^[3])]);
  end;
  cbReceiver.text:=sIP;
  Screen.Cursor := crDefault;
end;

procedure TFrmMain.Timer2Timer(Sender: TObject);
var
  HostEnt: PHostEnt;
  InetAddr: DWORD;
  sIP: string;
begin
  Timer2.Enabled := False;
  sIP := cbReceiver.Text;
  Screen.Cursor := crHourGlass;
  try
    InetAddr := inet_addr(PChar(sIP));
    HostEnt := GetHostByAddr(@InetAddr, Length(sIP), PF_INET);
    cbUsers.Text := HostEnt.h_name;
  except
    ShowMessage('非法IP!');
  end;
  Screen.Cursor := crDefault;
end;

end.