client_chatform.pas

Delphi快速开发Web Server

unit Client_ChatForm;

interface

uses
  Windows, Messages, SysUtils,
  Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls,
  //new for smilies support ...
  URxRichEd,
  USmilies,
  Shellapi,
  ImgList,
  tools,
  //....

  rtcInfo, rtcConn, rtcFunction;

type
  TChatForm = class(TForm)
    mainPanel: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    btnSend: TBitBtn;
    eEnter: TMemo;
    ilsSmilies: TImageList;
    Panel4: TPanel;
    btnBuzz: TSpeedButton;
    btnSmiley: TSpeedButton;
    p_smilies: TPanel;
    s1: TSpeedButton;
    s2: TSpeedButton;
    s3: TSpeedButton;
    s4: TSpeedButton;
    s5: TSpeedButton;
    s6: TSpeedButton;
    s7: TSpeedButton;
    s8: TSpeedButton;
    s9: TSpeedButton;
    s10: TSpeedButton;
    s11: TSpeedButton;
    s12: TSpeedButton;
    s13: TSpeedButton;
    s14: TSpeedButton;
    s15: TSpeedButton;
    s16: TSpeedButton;
    s17: TSpeedButton;
    s18: TSpeedButton;
    s19: TSpeedButton;
    s20: TSpeedButton;
    s21: TSpeedButton;
    s22: TSpeedButton;
    s23: TSpeedButton;
    s24: TSpeedButton;
    s25: TSpeedButton;
    s26: TSpeedButton;
    s27: TSpeedButton;
    s28: TSpeedButton;
    s29: TSpeedButton;
    s30: TSpeedButton;
    s31: TSpeedButton;
    s32: TSpeedButton;
    s33: TSpeedButton;
    s34: TSpeedButton;
    s35: TSpeedButton;
    s36: TSpeedButton;
    s37: TSpeedButton;
    s38: TSpeedButton;
    s39: TSpeedButton;
    s40: TSpeedButton;
    s41: TSpeedButton;
    s42: TSpeedButton;
    s43: TSpeedButton;
    s44: TSpeedButton;
    s45: TSpeedButton;
    s46: TSpeedButton;
    s47: TSpeedButton;
    btnBuzz2: TSpeedButton;
    //............................
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnSendClick(Sender: TObject);
    procedure eEnterChange(Sender: TObject);
    procedure eEnterKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure eEnterKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure rtfChatURLClick(Sender: TObject; const URLText: String;
      Button: TMouseButton);
    procedure btnBuzzClick(Sender: TObject);
    procedure btnSmileyClick(Sender: TObject);
    procedure p_smiliesClick(Sender: TObject);
    procedure p_sm_Click(Sender: TObject);
    procedure btnBuzz2Click(Sender: TObject);

  private
    { Private declarations }
    users:string;

    //new for smilies support
    FSmilies:         TRTFSmilies;
    rtfChat :TRxRichedit;
    //....

    class procedure closeForm(obj:TChatForm);

  public
    { Public declarations }

    class function getForm(fname:string; beep:boolean=False):TChatForm;
    class function isFormOpen(fname:string):boolean;

    class procedure enableAllForms;
    class procedure disableAllForms;
    class procedure closeAllForms;

    procedure AddMessage(const uname,text:string; message_typ :integer);
  end;

type
  TSendMsg=procedure(to_user,msg:string) of object;

var
  SendMsg:TSendMsg=nil;

const
  //rtc_message_typ ......................
  RTC_ADDMSG_SELF = 0;
  RTC_ADDMSG_FRIEND = 1;
  RTC_ADDMSG_ERROR = 2;
  RTC_ADDMSG_LOGIN = 3;
  RTC_ADDMSG_LOGOUT = 4;

implementation

{$R *.dfm}

const
  //chat-colors, you can alter wiht dialogbox, if you want ...
  CChatSays     = clBlack;
  CChatIam      = clNavy;
  CChatSystem   = clRed;
  CChatLogin    = clGreen;
  CChatLogout   = clMaroon;

var
  List:TStringList;

class function TChatForm.isFormOpen(fname:string):boolean;
  begin
  Result:=List.IndexOf(UpperCase(fname))>=0;
  end;

class function TChatForm.getForm(fname:string; beep:boolean=False):TChatForm;
  var
    i:integer;
  begin
  i:=List.IndexOf(UpperCase(fname));
  if i>=0 then
    begin
    Result:=TChatForm(List.Objects[i]);
    if beep then
      if not Result.Active then
        eingang;
    end
  else
    begin
    if beep then eingang;

    Result:=TChatForm.Create(nil);
    Result.Caption:=fname+' - Message';
    Result.users:=fname;
    Result.Show;
    List.AddObject(UpperCase(fname),Result);
    end;
  end;

class procedure TChatForm.closeForm(obj:TChatForm);
  var
    i:integer;
  begin
  for i:=0 to List.Count-1 do
    if List.Objects[i]=obj then
      begin
      List.Delete(i);
      Break;
      end;
  end;

class procedure TChatForm.enableAllForms;
  var
    i:integer;
  begin
  for i:=0 to List.Count-1 do
    with TChatForm(List.Objects[i]) do
      begin
      eEnter.ReadOnly:=False;
      eEnter.Color:=clWindow;
      btnSend.Enabled:=eEnter.Lines.Text<>'';
      end;
  end;

class procedure TChatForm.disableAllForms;
  var
    i:integer;
  begin
  for i:=0 to List.Count-1 do
    with TChatForm(List.Objects[i]) do
      begin
      eEnter.ReadOnly:=True;
      eEnter.Color:=clBtnFace;
      btnSend.Enabled:=False;
      end;
  end;

class procedure TChatForm.closeAllForms;
  var
    i:integer;
  begin
  for i:=0 to List.Count-1 do
    List.Objects[i].Free;
  List.Clear;
  end;

procedure TChatForm.FormClose(Sender: TObject; var Action: TCloseAction);
  begin
  Action:=caFree;
  closeForm(self);
  end;

procedure TChatForm.btnSendClick(Sender: TObject);
  var
    s:string;
  begin
  s:=eEnter.Lines.Text;
  if s<>'' then
    begin
    if not assigned(SendMsg) then
      raise Exception.Create('SendMsg procedure not assigned!');
    SendMsg(users, s);
    eEnter.Lines.Clear;
    btnSend.Enabled:=False;
    eEnter.SetFocus;
    end;
  end;

procedure TChatForm.eEnterChange(Sender: TObject);
  begin
  btnSend.Enabled:=eEnter.Lines.Text<>'';
  end;

procedure StartUp;
  begin
  List:=TStringList.Create;
  end;

procedure ShutDown;
  begin
  TChatForm.CloseAllForms;
  List.Free;
  end;

procedure TChatForm.eEnterKeyPress(Sender: TObject; var Key: Char);
begin
  // 'Eat' the return key
  if Key = #13 then
    Key := #0;
  end;


procedure TChatForm.AddMessage(const uname, text: string; message_typ :integer);
  begin
  if text = '' then Exit;

  rtfChat.Lines.BeginUpdate();
  rtfChat.Paragraph.FirstIndent := 0;
  case message_typ of
    RTC_ADDMSG_SELF:   FSmilies.AddColor(uname + ': ' + text, CChatIam);
    RTC_ADDMSG_FRIEND: FSmilies.AddColor(uname + ': ' + text, CChatSays);
    RTC_ADDMSG_ERROR:  begin
                       FSmilies.AddColor(uname + ': '+ text, CChatSystem);
                       click;
                       end;
    RTC_ADDMSG_LOGIN:  begin
                       FSmilies.AddColor(uname + ': '+ text, CChatLogin);
                       eingang;
                       end;
    RTC_ADDMSG_LOGOUT: begin
                       FSmilies.AddColor(uname + ': '+ text, CChatLogout);
                       door;
                       end;
    end;
  rtfChat.Lines.EndUpdate();

  if pos(':BUZZ)', text) > 0 then
    doorbell;
  end;

//new for support smilies ......................................................
procedure TChatForm.FormCreate(Sender: TObject);
var
  i :integer;
begin
  //create rtcChatEdit ........................
  rtfChat:= TRxRichedit.create(self);
  rtfChat.parent:= panel2;
  with rtfChat do begin
    align:= alclient;
    color:= $00CEFCFD;
    readonly:= true;
    scrollbars:= ssVertical;
    OnUrlClick:= rtfChatURLClick;
 end;


  //assign smiley-panel-images
  for i:= 1 to 47 do begin
    with TSpeedButton(findcomponent('s' + inttostr(i))) do
      begin
       ilsSmilies.getbitmap(i-1, Glyph);
      end;
  end;

  // Initialize smilies
  FSmilies            := TRTFSmilies.Create();
  FSmilies.ImageList  := ilsSmilies;
  FSmilies.RichEdit   := rtfChat;

  // Code=Index (multiple codes per index thus possible)
  with FSmilies.Smilies do begin
    Clear();
    Add(':)=0');    Add(':-)=0');
    Add(':D=1');    Add(':-D=1');   Add(':>=1');    Add(':->=1');
    Add(';)=2');    Add(';-)=2');
    Add(':O=3');    Add(':-O=3');
    Add(':P=4');    Add(':-P=4');
    Add('(H)=5');
    Add(':@=6');    Add(':-@=6');
    Add(':$=7');    Add(':-$=7');
    Add(':S=8');    Add(':-S=8');
    Add(':(=9');    Add(':-(=9');   Add(':<=9');    Add(':-<=9');
    Add(':''(=10');
    Add(':|=11');   Add(':-|=11');
    Add('(6)=12');
    Add('(A)=13');
    Add('(L)=14');
    Add('(U)=15');
    Add('(M)=16');
    Add('(@)=17');
    Add('(&)=18');
    Add('(S)=19');
    Add('(*)=20');
    Add('(~)=21');
    Add('(E)=22');
    Add('(8)=23');
    Add('(F)=24');
    Add('(W)=25');
    Add('(O)=26');  Add('(0)=26');
    Add('(K)=27');
    Add('(G)=28');
    Add('(^)=29');
    Add('(P)=30');
    Add('(I)=31');
    Add('(C)=32');
    Add('(T)=33');
    Add('({)=34');
    Add('(})=35');
    Add('(B)=36');
    Add('(D)=37');
    Add('(Z)=38');
    Add('(X)=39');
    Add('(Y)=40');
    Add('(N)=41');
    Add(':[=42');   Add(':-[=42');
    Add('(?)=43');
    Add('(%)=44');
    Add('(#)=45');
    Add('(R)=46');
  end;

  // This is absolutely needed! Without this, the RichEdit won't scroll
  // to the end automatically! Don't ask me why though...
  rtfChat.HideSelection   := False;
  rtfChat.HideScrollBars  := True;
end;
//..............................................................................


procedure TChatForm.FormDestroy(Sender: TObject);
begin
  // Destroy smilies
  FSmilies.Free;
  FSmilies:=nil;
end;

procedure TChatForm.eEnterKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_RETURN then
    if Shift  = [ssShift] then begin
      // Insert line break when Shift-return is pressed
      eEnter.SelText := #13#10;
    end else begin
      // Click 'Send' button when return is pressed
      if btnSend.Enabled then
        btnSend.Click();
    end;
end;

procedure TChatForm.rtfChatURLClick(Sender: TObject; const URLText: String;
  Button: TMouseButton);
begin
  ShellExecute(Application.Handle, 'open',
               PChar(UrlText), nil, nil,
               SW_ShowNormal);
end;

procedure TChatForm.btnBuzzClick(Sender: TObject);
  var
    s:string;
  begin
  p_smilies.Visible:=False;
  s:= ':BUZZ)';
  if s<>'' then
    begin
    if not assigned(SendMsg) then
      raise Exception.Create('SendMsg procedure not assigned!');
    SendMsg(users, s);
    eEnter.SetFocus;
    end;
  end;

procedure TChatForm.btnSmileyClick(Sender: TObject);
  begin
  if not p_smilies.visible then
    begin
    p_smilies.Top:=mainPanel.Top-p_smilies.Height-6;
    if p_smilies.Top<0 then p_smilies.Top:=0;
    p_smilies.Left:=6;
    p_smilies.Show;
    p_smilies.BringToFront;
    end
  else
    p_smilies.Hide;
  end;

procedure TChatForm.p_smiliesClick(Sender: TObject);
  begin
  p_smilies.hide;
  end;

procedure TChatForm.p_sm_Click(Sender: TObject);
var
  t,p,a :integer;
  s,s2 :string;
begin
  t:= (sender as TComponent).tag;
  s2:=inttostr(t-1);
  for a:=0 to FSmilies.Smilies.Count-1 do
    begin
    s:= FSmilies.Smilies[a];
    p:= pos('=', s);
    if Copy(s, p+1, length(s)-p+1)=s2 then
      begin
      s:= copy(s, 1, p-1);
      Break;
      end;
    end;
  eEnter.Lines.Text:= eEnter.lines.text +  s + ' ';
  eEnter.SelStart:= length(eEnter.lines.text) + 1;
  eEnter.SetFocus;
  p_smilies.Hide;
end;

procedure TChatForm.btnBuzz2Click(Sender: TObject);
  begin
  eEnter.Lines.Text:= eEnter.lines.text +  ':BUZZ) ';
  eEnter.SelStart:= length(eEnter.lines.text) + 1;
  eEnter.SetFocus;
  p_smilies.Hide;
  end;

initialization
StartUp;
finalization
ShutDown;
end.