main.pas

局域网聊天程序

//www.delphibox.com

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, CheckLst, ComCtrls, Buttons, ExtCtrls, NMUDP, Menus, Inifiles, fStrRep,
  StdActns, ActnList;

type
  Tfrm_main = class(TForm)
    Panel_main: TPanel;
    RE_Chat: TRichEdit;
    CLB_UserList: TCheckListBox;
    Panel_Bottom: TPanel;
    Edit_Chat: TEdit;
    NMUDP_Chat: TNMUDP;
    Edit_LuckName: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Edit_Who: TEdit;
    PM_UserList: TPopupMenu;
    PopItem_PasteUserName: TMenuItem;
    Panel1: TPanel;
    Panel_Set: TPanel;
    btnMenu: TSpeedButton;
    Panel_Send: TPanel;
    SB_Send: TSpeedButton;
    Panel5: TPanel;
    SB_1: TSpeedButton;
    Panel2: TPanel;
    SB_Exit: TSpeedButton;
    N1: TMenuItem;
    PopItem_IP: TMenuItem;
    PM_REdit: TPopupMenu;
    ActionList1: TActionList;
    EditCopy1: TEditCopy;
    EditSelectAll1: TEditSelectAll;
    N2: TMenuItem;
    N3: TMenuItem;
    EditFont1: TAction;
    FontDialog1: TFontDialog;
    N4: TMenuItem;
    N5: TMenuItem;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure NMUDP_ChatDataSend(Sender: TObject);
    procedure NMUDP_ChatDataReceived(Sender: TComponent; NumberBytes: Integer;
      FromIP: String; Port: Integer);
    procedure FormShow(Sender: TObject);
    procedure BB_SendClick(Sender: TObject);
    procedure Edit_ChatKeyPress(Sender: TObject; var Key: Char);
    procedure CLB_UserListDblClick(Sender: TObject);
    procedure FormDblClick(Sender: TObject);
    procedure Edit_LuckNameKeyPress(Sender: TObject; var Key: Char);
    procedure PopItem_PasteUserNameClick(Sender: TObject);
    procedure CLB_UserListMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure SB_SendClick(Sender: TObject);
    procedure RE_ChatChange(Sender: TObject);
    procedure SB_1Click(Sender: TObject);
    procedure SB_ExitClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure CLB_UserListClickCheck(Sender: TObject);
    procedure PopItem_IPClick(Sender: TObject);
    procedure btnMenuClick(Sender: TObject);
    procedure NMUDP_ChatInvalidHost(var handled: Boolean);
    procedure EditFont1Execute(Sender: TObject);
  private
    sCommand:Integer;
    LuckName:String;
    //move like NT
    FisDown:Boolean;
    FDetax,FDetaY:Integer;
    FP,FOldP:TPoint;
    //Draw a CaptionBtn
    CapStr:String;
    CaptionBtn:TRect;
    procedure DrawCaptButton(CapStr:String);
    procedure WMNCPaint(var Msg:TWMNCPaint);message WM_NCPaint;
    procedure WMNCActivate(var Msg:TWMNCActivate);message WM_NCActivate;
    procedure WMSetText(var Msg:TWMSetText);message WM_SetText;
    procedure WMNCHitTest(var Msg:TWMNCHitTest);message WM_NCHittest;
    procedure WMNCLButtonDown(var Msg:TWMNCLButtonDown);message WM_NCLButtonDown;
//    function GetVerInfo : DWORD;
    function Emote:Boolean;
    procedure SendOffLine;
    procedure SendOnLine;
    { Private declarations }
  public
    HostName:String;
    HostPort:Integer;
    function GetExePath:String;
    { Public declarations }
  end;

var
  frm_main: Tfrm_main;

implementation

uses setup;

const
  htCaptionBtn=htSizeLast+1;

{$R *.DFM}

function Tfrm_main.GetExePath:String;
begin
  Result:=ExtractFilePath(ParamStr(0));
  if Result[Length(Result)]<>'\' then
    Result:=Result+'\';
end;

procedure Tfrm_main.DrawCaptButton(CapStr:String);
var
  xFrame,yFrame,xSize,ySize:Integer;
  R:TRect;
begin
  xFrame:=GetSystemMetrics(SM_CXFRAME);
  yFrame:=GetSystemMetrics(SM_CYFRAME);
  xSize:=GetSystemMetrics(SM_CXSIZE);
  ySize:=GetSystemMetrics(SM_CYSIZE);
  //按钮属性调整->>
  CaptionBtn:=Bounds(Width-xFrame-5*xSize+4,yFrame+2,xSize+13,ySize-4);
  Canvas.Handle:=GetWindowDC(Self.Handle);
  Canvas.Font.Name:='宋体';
  Canvas.Font.Color:=clBlack;
  Canvas.Pen.Color:=clYellow;
  Canvas.Brush.Color:=clBtnFace;
  try
    DrawButtonFace(Canvas,CaptionBtn,1,bsAutoDetect,False,False,False);
    R:=Bounds(Width-xFrame-5*xSize+5,yFrame+3,xSize+10,ySize-7);
    with CaptionBtn do
      Canvas.TextRect(R,R.Left+2,R.Top,CapStr);
  finally
    ReleaseDC(Self.Handle,Canvas.Handle);
    Canvas.Handle:=0;
  end;
end;

procedure Tfrm_main.WMNCActivate(var Msg: TWMNCActivate);
begin
inherited;
  DrawCaptButton(CapStr);
end;

procedure Tfrm_main.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
  with Msg do
  begin
    if PtInRect(CaptionBtn,Point(xPos-Left,yPos-Top)) then
      Result:=htCaptionBtn;
//    if htCaption=Result then
//      Result:=htClient;
  end;
end;

procedure Tfrm_main.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
inherited;
  if(Msg.HitTest=htCaptionBtn)then
    if CapStr='←→' then
    begin
      CapStr:='→←';
      inherited;
      DrawCaptButton(CapStr);
//      frm_main.FormStyle:=fsStayOnTop;
      SetWindowPos(frm_main.Handle,Hwnd_Topmost,0,0,0,0,
                  (SWP_NOMOVE or SWP_NOSIZE));
    end else
    begin
      CapStr:='←→';
      inherited;
      DrawCaptButton(CapStr);
//      frm_main.FormStyle:=fsNormal;
      SetWindowPos(frm_main.Handle,Hwnd_Notopmost,0,0,0,0,
                  (SWP_NOMOVE or SWP_NOSIZE));
    end;
end;

procedure Tfrm_main.WMNCPaint(var Msg: TWMNCPaint);
begin
inherited;
  DrawCaptButton(CapStr);
end;

procedure Tfrm_main.WMSetText(var Msg: TWMSetText);
begin
inherited;
  DrawCaptButton(CapStr);
end;

procedure Tfrm_main.FormResize(Sender: TObject);
begin
  Perform(WM_NCACTIVATE,Word(Active),0);

  Edit_Chat.Width:=RE_Chat.Width;
end;

{function Tfrm_main.GetVerInfo : DWORD;
var
  verInfo : TOSVERSIONINFO;
begin
  verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  if GetVersionEx(verInfo) then
    Result := verInfo.dwPlatformID;
    {Returns:
      VER_PLATFORM_WIN32s             Win32s on Windows 3.1
      VER_PLATFORM_WIN32_WINDOWS        Win32 on Windows 95
      VER_PLATFORM_WIN32_NT           Windows NT }
//end;

procedure Tfrm_main.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FisDown:=True;
  GetCursorPos(FOldP);
end;

procedure Tfrm_main.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not FisDown then exit;
  GetCursorPos(Fp);
  FDetaX:=Fp.x-Foldp.x;
  FDetaY:=FP.y-FOldP.y;
  SetBounds(Left+FDetaX,Top+FDetaY,Width,Height);
  GetCursorPos(FOldP);
end;

procedure Tfrm_main.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FisDown:=false;
end;

procedure Tfrm_main.FormCreate(Sender: TObject);
begin
  CapStr:='←→';
  Panel_Bottom.Align:=alBottom;
  Panel_main.Align:=alClient;
  CLB_UserList.Align:=alRight;
  RE_Chat.Align:=alClient;
end;

procedure Tfrm_main.NMUDP_ChatDataSend(Sender: TObject);
begin
  Edit_Chat.Clear;
end;

procedure Tfrm_main.NMUDP_ChatDataReceived(Sender: TComponent;
  NumberBytes: Integer; FromIP: String; Port: Integer);
var
  C:array[1..255] of Char;
  I,tmpi:Integer;
  tmpStr:String;
  OnLine:Boolean;
begin
  NMUDP_Chat.ReadBuffer(C,I);
  sCommand:=strtoint(C[1]);
  case sCommand of
  1:begin  //收消息
      With TInifile.Create(GetExePath+'Chat.ini')do
        if ReadBool('HateIP',FromIP,False)then exit;
      for tmpi:=2 to I do
        tmpStr:=tmpStr+C[tmpi];
      RE_Chat.Lines.Add(tmpStr);
//      RE_Chat.Lines.Add(fromIP);
    end;
  2:begin  //上线
      OnLine:=True;
      for tmpi:=2 to I do
        tmpStr:=tmpStr+C[tmpi];
      with TInifile.Create(GetExePath+'Chat.ini')do
      begin
        if ReadString('ChatIP',FromIP,'')='' then OnLine:=False;
        if not OnLine then
        begin
          CLB_UserList.Items.Add(tmpStr);
          CLB_UserList.Checked[CLB_UserList.Items.IndexOf(tmpStr)]:=ReadBool('HateIP',FromIP,False);
          WriteString('ChatIP',tmpStr,FromIP);
          WriteString('ChatIP',FromIP,tmpStr);
          SendOnLine;
        end;
      end;
    end;
  3:begin  //下线
      OnLine:=True;
      for tmpi:=2 to I do
        tmpStr:=tmpStr+C[tmpi];
      with TInifile.Create(GetExePath+'Chat.ini')do
      begin
        if ReadString('ChatIP',FromIP,'')='' then OnLine:=False;
        if OnLine then
        begin
          DeleteKey('ChatIP',FromIP);
          DeleteKey('ChatIP',tmpStr);
        end;
        try
          CLB_UserList.Items.Delete(CLB_UserList.Items.IndexOf(tmpStr));
        finally