123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218 |
- unit MainUnit;
- interface
- uses
- Windows, Messages, SysUtils, Variants, Classes, Controls, Forms,
- DB, DBClient, ZjGridDBA, ZJGrid, ExtCtrls, ComCtrls, ToolWin, Dialogs,
- ServerServices, AnimateWinService, Menus, StdCtrls, TypeUnit, TypeConfig;
- type
- TfrmMian = class(TForm)
- StatusBar1: TStatusBar;
- CoolBar1: TCoolBar;
- ToolBar1: TToolBar;
- tbOpen: TToolButton;
- tbExit: TToolButton;
- tvTree: TTreeView;
- Splitter1: TSplitter;
- zgClientInfo: TZJGrid;
- zaClientInfo: TZjGridDBA;
- PopupMenu: TPopupMenu;
- muShow: TMenuItem;
- muExit: TMenuItem;
- N1: TMenuItem;
- tbPort: TToolButton;
- tbClose: TToolButton;
- tbDeleteClient: TToolButton;
- procedure FormCreate(Sender: TObject);
- procedure FormDestroy(Sender: TObject);
- procedure tbExitClick(Sender: TObject);
- procedure muExitClick(Sender: TObject);
- procedure muShowClick(Sender: TObject);
- procedure tbOpenClick(Sender: TObject);
- procedure tbPortClick(Sender: TObject);
- procedure tbCloseClick(Sender: TObject);
- procedure tbDeleteClientClick(Sender: TObject);
- private
- FServer: TScServer;
- FAnimateWin: TAnimateWinService;
- procedure InitTV;
- procedure ExitApp;
- procedure RefreshTV;
- procedure AddTVNode(AType, ACount: Integer);
- function ChangePort: string;
- procedure ChangeStatus(const Value: string);
- procedure WMClose(var Message: TWMClose); message WM_CLOSE;
- procedure TrayIconMessage(var Msg: TMessage); message WM_TrayIcon;
- procedure SMClientCount(var Msg: TMessage); message SM_ClientCount;
- procedure SMStatus(var Msg: TMessage); message SM_Status;
- public
- { Public declarations }
- end;
- var
- frmMian: TfrmMian;
- implementation
- {$R *.dfm}
- procedure TfrmMian.FormCreate(Sender: TObject);
- begin
- FServer := TScServer.Create;
- FAnimateWin := TAnimateWinService.Create;
- FAnimateWin.WinControl := Self;
- InitTV;
- zaClientInfo.DataSet := FServer.ClientInfoService.cdsClientInfo;
- // SetWindowLong(application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
- end;
- procedure TfrmMian.FormDestroy(Sender: TObject);
- begin
- FreeAndNil(FServer);
- FAnimateWin.Free;
- end;
- procedure TfrmMian.InitTV;
- var
- vNode: TTreeNode;
- begin
- vNode := tvTree.Items.AddChild(nil, '服务器');
- vNode := tvTree.Items.AddChild(vNode, FServer.ServerIP);
- vNode := tvTree.Items.Add(vNode, FServer.Port);
- tvTree.Items[0].Expand(True);
- end;
- procedure TfrmMian.tbExitClick(Sender: TObject);
- begin
- ExitApp;
- end;
- procedure TfrmMian.muExitClick(Sender: TObject);
- begin
- ExitApp;
- end;
- procedure TfrmMian.ExitApp;
- begin
- FAnimateWin.DelIconFromTray;
- Application.Terminate;
- end;
- procedure TfrmMian.muShowClick(Sender: TObject);
- begin
- Show;
- end;
- procedure TfrmMian.WMClose(var Message: TWMClose);
- begin
- FAnimateWin.MinAnimate;
- FAnimateWin.AddIconToTray;
- Hide;
- end;
- procedure TfrmMian.tbOpenClick(Sender: TObject);
- begin
- if FServer.OpenServer then
- begin
- ChangeStatus('打开');
- tbPort.Enabled := False;
- end;
- end;
- procedure TfrmMian.tbPortClick(Sender: TObject);
- begin
- FServer.Port := ChangePort;
- RefreshTV;
- end;
- function TfrmMian.ChangePort: string;
- begin
- Result := '';
- while Result = '' do
- begin
- {要加空格,否则汉字显示不全,可能是TLabel对文字支持问题}
- if not InputQuery('输入端口号', '值: ', Result) then Exit;
- end;
- end;
- procedure TfrmMian.RefreshTV;
- begin
- tvTree.Items.Clear;
- InitTV;
- end;
- procedure TfrmMian.TrayIconMessage(var Msg: TMessage);
- var
- MousePt: TPoint; //鼠标点击位置
- begin
- if (Msg.LParam = WM_RBUTTONUP) then // 用鼠标右键点击图标
- begin
- GetCursorPos(MousePt); // 获取光标位置
- SetForegroundWindow(Handle); // 弹出菜单自动隐藏
- PopupMenu.Popup(MousePt.X, MousePt.Y); // 在光标位置弹出选单
- end
- else if (Msg.LParam = WM_LBUTTONDBLCLK) then Show;
- end;
- procedure TfrmMian.ChangeStatus(const Value: string);
- begin
- StatusBar1.Panels[0].Text := Format(' 服务器状态:%s', [Value]);
- end;
- procedure TfrmMian.SMClientCount(var Msg: TMessage);
- var
- iV0, iV1, iV2: Integer;
- begin
- iV0 := Msg.WParamHi;
- AddTVNode(Flag_Version_0, iV0);
- end;
- procedure TfrmMian.AddTVNode(AType, ACount: Integer);
- var
- Flag: Boolean;
- sText: string;
- vNode, cNode: TTreeNode;
- begin
- sText := CfgManager.GetAppType(AType) + ':';
- vNode := tvTree.Items.GetFirstNode;
- cNode := vNode.getFirstChild;
- Flag := False;
- while Assigned(cNode) do
- begin
- if Pos(sText, cNode.Text) <> 0 then
- begin
- cNode.Text := Format('%s%d', [sText, ACount]);
- Flag := True;
- Break;
- end;
- cNode := cNode.GetNext;
- end;
- if not Flag then
- begin
- cNode := tvTree.Items.AddChild(vNode, Format('%s%d', [sText, ACount]));
- end;
- end;
- procedure TfrmMian.tbCloseClick(Sender: TObject);
- begin
- FServer.CloseServer;
- tbPort.Enabled := True;
- ChangeStatus('关闭');
- end;
- procedure TfrmMian.tbDeleteClientClick(Sender: TObject);
- begin
- if zgClientInfo.CurRow - zgClientInfo.FixedRowCount <= zaClientInfo.RecordCount - 1 then
- FServer.DeleteClient;
- end;
- procedure TfrmMian.SMStatus(var Msg: TMessage);
- begin
- ChangeStatus('关闭');
- end;
- end.
|