main.pas

思微POS连锁超市管理系统 (商业代码),几年前的东西了

//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;
    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 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 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;
//    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.WMNCPaint(var Msg: TWMNCPaint);
begin
  inherited;
  DrawCaptButton(CapStr);
end;

procedure Tfrm_main.WMSetText(var Msg: TWMSetText);
begin
  inherited;
  DrawCaptButton(CapStr);
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.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

          end;
        end;
      end;
  end;
end;

procedure Tfrm_main.SendOnLine;
var
  CLine: array[1..127] of Char;
  tmpStr: string;
  I: Integer;
begin
  tmpStr := '2' + LuckName;
  for i := 1 to Length(tmpStr) do
    CLine[i] := tmpStr[i];
  NMUDP_Chat.SendBuffer(CLine, Length(TmpStr));
end;

procedure Tfrm_main.SendOffLine;
var
  CLine: array[1..127] of Char;
  tmpStr: string;
  I: Integer;
begin
  tmpStr := '3' + LuckName;
  for i := 1 to Length(tmpStr) do
    CLine[i] := tmpStr[i];
  NMUDP_Chat.SendBuffer(CLine, Length(TmpStr));