mainfrm.pas

NetHook API 对战平台内核库是一套实现时下流行的网络对战平台[如浩方、VS]同样功能的通用内核库

unit MainFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, ComCtrls, jpeg, NhPubUtils, NhcNetManager,
  NhcNetBusiness, NhBaseBizPacket, NhGlobalST, NhGlobalDef, Menus, RVScroll,
  RichView, RVEdit, IrisRichEdit, Buttons, OleCtrls, SHDocVw, MSHTML, ActiveX,
  MmSystem, NhSocketObj, BaseFrm;

type
  TMainForm = class(TBaseForm)
    RunGameGroupBox: TGroupBox;
    RightPanel: TPanel;
    Panel1: TPanel;
    Label1: TLabel;
    Panel2: TPanel;
    Label2: TLabel;
    OnlineUserLabel: TLabel;
    UserListView: TListView;
    Panel3: TPanel;
    ChatMsgGroupBox: TGroupBox;
    Panel4: TPanel;
    SendMsgButton: TButton;
    GameNameCombox: TComboBox;
    RunGameExeEdit: TEdit;
    StartGameButton: TButton;
    SelectExeButton: TButton;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    RunGameParamEdit: TEdit;
    UserNumTimer: TTimer;
    RecvMsgEdit: TIrisRichEdit;
    SendMsgEdit: TIrisRichEdit;
    ToUserCmb: TComboBox;
    Label3: TLabel;
    SelectFont: TSpeedButton;
    ChatFontDialog: TFontDialog;
    ChatIsPrivateCheck: TCheckBox;
    OnlyDisplayPrivateCheck: TCheckBox;
    ClearChatMsgBtn: TSpeedButton;
    BeepOnRecvBroadCheck: TCheckBox;
    SearchGameExeBtn: TButton;
    CheckGameStateTimer: TTimer;
    WebMain: TWebBrowser;
    Panel5: TPanel;
    AbountBtn: TButton;
    SystemSetBtn: TButton;
    ChangeSrvBtn: TButton;
    procedure FormCreate(Sender: TObject);
    procedure SelectExeButtonClick(Sender: TObject);
    procedure StartGameButtonClick(Sender: TObject);
    procedure GameNameComboxChange(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure MainTrayIconDblClick(Sender: TObject);
    procedure SendMsgButtonClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure UserNumTimerTimer(Sender: TObject);
    procedure SelectFontClick(Sender: TObject);
    procedure UserListViewDblClick(Sender: TObject);
    procedure ClearChatMsgBtnClick(Sender: TObject);
    procedure BeepOnRecvBroadCheckClick(Sender: TObject);
    procedure SearchGameExeBtnClick(Sender: TObject);
    procedure UserListViewClick(Sender: TObject);
    procedure UserListViewMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure UserListViewExit(Sender: TObject);
    procedure CheckGameStateTimerTimer(Sender: TObject);
    procedure AbountBtnClick(Sender: TObject);
    procedure ChangeSrvBtnClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure SystemSetBtnClick(Sender: TObject);
    procedure UserListViewColumnClick(Sender: TObject; Column: TListColumn);
    procedure UserListViewAdvancedCustomDrawItem(Sender: TCustomListView;
      Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
      var DefaultDraw: Boolean);
    procedure RecvMsgEditChange(Sender: TObject);
  private
    FDispather: TBcNetEventDisper;
    FLastSendTick: Cardinal;
    FHaveShowDisconnect: Boolean;
    FRunningGameProcessID: Cardinal;

    function GetCurGameID: Integer;
  private
    procedure OnUserEnterNotify(const UserInfo: TBaseUserInfo);
    procedure OnUserLeaveNotify(const UserName: string);
    procedure OnUserEnterGameNotify(const UserName: string; GameID: Integer);
    procedure OnChatNotify(const MsgInfo: TChatMsgInfo);
    procedure OnBattleSvrTcpBroken;
    procedure OnBroadMsgNotify(const BroadMsg: string);
  private
    procedure AddRecvChatMsg(const MsgInfo: TChatMsgInfo);
    procedure DisplaySystemInfo(const Msg: string);

    procedure PlaySoundFromRes(const ResName: string);
  public
    FUserAry: array[1..1024 * 4] of TBaseUserInfo;
    FUserAryUsed: array[1..1024* 4] of Boolean;

    function AllocUserAryIndex: Integer;
    procedure DeAllocUserAryIndex(Index: Integer);

    procedure DisplayGameExeAndParam;
    procedure LockWarIIIUserName(const UserName: string);

    procedure BrowserDirectDisplay(const HtmlText: string);
    procedure BrowserFileDisplay(const HtmlText: string);

    procedure Initialize;
    procedure Finalize;

    property CurGameID: Integer read GetCurGameID;
  end;

var
  MainForm: TMainForm;

implementation

uses Registry, NhcConfig, NetHookLoaderUnit, DateUtils, ProjectUtils,
  NhcSearchGameFrm, UserInfoFrm, NhDebug, LoginFrm, AboutFrm, BackMainFrm,
  SystemSetFrm, ResourceStr;

{$R *.dfm}

var
  FListViewSortColumIndex: Integer;
  FListViewSortFlag: Boolean;

procedure TMainForm.BeepOnRecvBroadCheckClick(Sender: TObject);
begin
  ConfigMgr.BeepOnRecvBroad := BeepOnRecvBroadCheck.Checked;
  ConfigMgr.Save;
end;

procedure TMainForm.BrowserDirectDisplay(const HtmlText: string);
var
  HtmlDoc2: IHTMLDocument2;
  v: Variant;
begin
  WebMain.Navigate('about:blank');
  HtmlDoc2 := WebMain.Document as IHTMLDocument2;
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := HtmlText;
  HtmlDoc2.Write(PSafeArray(TVarData(v).VArray));
  HtmlDoc2.Close;
  HtmlDoc2 := nil;
end;

procedure TMainForm.BrowserFileDisplay(const HtmlText: string);
var
  List: TStringList;
begin
  List := TStringList.Create;
  try
    try
      List.Text := HtmlText;
      List.SaveToFile(GetAppPath + 'Broad.htm');
    except
    end;
  finally
    List.Free;
  end;

  try
    WebMain.Navigate(GetAppPath + 'Broad.htm');
  except
  end;
end;

procedure TMainForm.ChangeSrvBtnClick(Sender: TObject);
var
  NeedTerminate: Boolean;
begin
  if ShowLoginForm(False, True, NeedTerminate) then
  begin
    MainForm.Show;
    SetForegroundWindow(MainForm.Handle);
  end else
  begin
    if NeedTerminate then
    begin
      Application.Terminate;
    end;
  end;
end;

procedure TMainForm.CheckGameStateTimerTimer(Sender: TObject);
begin
  if DllIsRunning = 0 then
  begin
    CheckGameStateTimer.Enabled := False;
    NetMgr.NetBusiness.SendUserEnterGame(0);
  end;
end;

procedure TMainForm.ClearChatMsgBtnClick(Sender: TObject);
begin
  RecvMsgEdit.ReadOnly := False;
  try
    RecvMsgEdit.Text := '';
  finally
    RecvMsgEdit.ReadOnly := True;
  end;
end;

procedure TMainForm.Finalize;
begin
  FDispather.Free;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caHide;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  NhDebug.__SetDebugMsg(False);
  NhDebug.__SetDebugType(False);
  NhDebug.__SetDebugUdpAddr('127.0.0.1', 9900);
  NhDebug.__DebugMsg('Started');

  Initialize;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  Finalize;
end;

procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char);
begin
  // 屏蔽Memo的回车键
  if (Key = #13) and (SendMsgEdit.Focused) then
  begin
    SendMsgButtonClick(SendMsgButton);
    Key := #0;
  end;
end;

procedure TMainForm.GameNameComboxChange(Sender: TObject);
begin
  DisplayGameExeAndParam;
end;

function TMainForm.GetCurGameID: Integer;
begin
  if GameNameCombox.ItemIndex = -1 then
    Result := -1
  else
    Result := NetMgr.NetBusiness.SelfInfo.GameAry[GameNameCombox.ItemIndex].GameID;
end;

procedure TMainForm.Initialize;
  procedure InitializeData;
  begin
    FillChar(FUserAry, SizeOf(FUserAry), 0);
    FillChar(FUserAryUsed, SizeOf(FUserAryUsed), 0);

    FHaveShowDisconnect := False;
    FRunningGameProcessID := 0;
    FListViewSortColumIndex := 0;
    FListViewSortFlag := False;
  end;
  procedure InitializeUI;
  begin
    Self.Width := 740;
    Self.Height := 600;

    Randomize;
    Application.Title := PROGRAM_NAME + ' ' + GetExeStringVer;
    MainForm.Caption := Application.Title;

    BackMainForm.MainTrayIcon.Hint := Application.Title;
    BackMainForm.MainTrayIcon.Visible := True;

    SendMsgEdit.TextFont := ChatFontDialog.Font;
    BeepOnRecvBroadCheck.Checked := ConfigMgr.BeepOnRecvBroad;

    ChatFontToFont(ConfigMgr.ChatFont, ChatFontDialog.Font);
    SendMsgEdit.TextFont := ChatFontDialog.Font;

    UserListView.Clear;
    BrowserFileDisplay(NetMgr.NetBusiness.SelfInfo.BoardMsg);
  end;
  procedure InitializeObjects;
  begin
    FDispather := TBcNetEventDisper.Create;
    FDispather.OnUserEnterNotify := OnUserEnterNotify;
    FDispather.OnUserLeaveNotify := OnUserLeaveNotify;
    FDispather.OnUserEnterGameNotify := OnUserEnterGameNotify;
    FDispather.OnChatNotify := OnChatNotify;
    FDispather.OnBattleSvrTcpBroken := OnBattleSvrTcpBroken;
    FDispather.OnBroadMsgNotify := OnBroadMsgNotify;
  end;
begin
  InitializeData;
  InitializeUI;
  InitializeObjects;
end;

function TMainForm.AllocUserAryIndex: Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 1 to Length(FUserAry) do  // 注意从1开始
  begin
    if not FUserAryUsed[I] then
    begin
      Result := I;
      Break;
    end;
  end;

  if Result <> -1 then
  begin
    FUserAryUsed[Result] := True;
  end;
end;

procedure TMainForm.DeAllocUserAryIndex(Index: Integer);
begin
  if (Index >= Low(FUserAry)) and (Index <= High(FUserAry)) then
    FUserAryUsed[Index] := False;
end;

procedure TMainForm.LockWarIIIUserName(const UserName: string);
var
  R: TRegistry;
  Key: string;
begin
  try
    R := TRegistry.Create;
    try        
      R.RootKey := HKEY_CURRENT_USER;
      Key := 'Software\Blizzard Entertainment\Warcraft III\String\';
      if R.OpenKey(Key, True) then
        R.WriteString('UserLocal', UserName);
    finally
      R.Free;
    end;
  except
  end;
end;

procedure TMainForm.MainTrayIconDblClick(Sender: TObject);
begin
  Application.Restore;
  Self.Show;
  SetForegroundWindow(Self.Handle);
end;

procedure TMainForm.OnBattleSvrTcpBroken;
begin
  if not FHaveShowDisconnect then
  begin
    FHaveShowDisconnect := True;
    MessageBox(Handle, '与服务器连接中断, 请重新启动程序!', '提示信息', MB_ICONWARNING);

    MainForm.Close;
    Application.Terminate;
  end;
end;

procedure TMainForm.OnBroadMsgNotify(const BroadMsg: string);
begin
  if ConfigMgr.BeepOnRecvBroad then
  begin
    PlaySoundFromRes('NewMessage');
  end;

  BrowserFileDisplay(BroadMsg);
end;

procedure TMainForm.OnChatNotify(const MsgInfo: TChatMsgInfo);
begin
  // 如果只显示私聊信息选中，但是消息不是私聊消息则不显示
  if OnlyDisplayPrivateCheck.Checked and not MsgInfo.IsPrivate then
    Exit;

  AddRecvChatMsg(MsgInfo);
end;

procedure TMainForm.OnUserEnterGameNotify(const UserName: string;
  GameID: Integer);
var
  I: Integer;
begin
  Assert(GetCurrentThreadId = MainThreadID);

  for I := 0 to UserListView.Items.Count - 1 do
  begin
    if UserListView.Items[I].Caption = UserName then
    begin
      UserListView.Items[I].SubItems[1] :=