ipprocess.pas

来自「群星医药系统源码」· PAS 代码 · 共 594 行 · 第 1/2 页

unit IpProcess;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Mask, RzEdit, RzLabel, ImgList, IdBaseComponent,
  IdComponent, IdIPWatch, ComCtrls, RzListVw, ExtCtrls, DB, ADODB, RzButton,
  Sockets, IdAntiFreezeBase, IdAntiFreeze, IdUDPBase, IdUDPServer,
  IdThreadMgr, IdThreadMgrDefault, IdTCPServer, RzPanel, RzTray, Menus,
  RzCmboBx, RzDBCmbo, Buttons,GlobalUnit,IniFiles, Registry;

type
  TFmMsgServer = class(TForm)
    ThisIP: TIdIPWatch;
    ImgList: TImageList;
    Server: TIdTCPServer;
    IdThread: TIdThreadMgrDefault;
    TrayICo: TRzTrayIcon;
    PopExit: TPopupMenu;
    N1: TMenuItem;
    RzPanel2: TRzPanel;
    ListView: TRzListView;
    RzPanel1: TRzPanel;
    RzLabel1: TRzLabel;
    RzLabel3: TRzLabel;
    Send: TRzBitBtn;
    SendText: TRzEdit;
    EdIP: TRzEdit;
    adsMsg: TADODataSet;
    DsUser: TDataSource;
    adsUser: TADODataSet;
    AdoConn: TADOConnection;
    adsAccount: TADODataSet;
    DsAccount: TDataSource;
    adsAccountAccountName: TStringField;
    adsUserUsrUnique: TAutoIncField;
    adsUserAccountName: TStringField;
    adsUserUserId: TStringField;
    adsUserUserIP: TStringField;
    adsUserOnline: TBooleanField;
    adsMsgMsgUnique: TAutoIncField;
    adsMsgAccountName: TStringField;
    adsMsgUserId: TStringField;
    adsMsgMsg: TStringField;
    adsMsgMsgDateTime: TDateTimeField;
    adsMsgModuleID: TStringField;
    adsMsgBillNo: TStringField;
    adsMsgDestId: TStringField;
    adsMsgCopyTo: TBooleanField;
    adsMsgCommand: TBooleanField;
    RzLabel2: TRzLabel;
    RzLabel4: TRzLabel;
    CbxAccountList: TRzComboBox;
    CbxUserList: TRzComboBox;
    btnParamSetting: TRzBitBtn;
    procedure FormCreate(Sender: TObject);
    procedure BtnExitClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure ServerConnect(AThread: TIdPeerThread);
    procedure ServerExecute(AThread: TIdPeerThread);
    procedure ServerDisconnect(AThread: TIdPeerThread);
    procedure SendClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure ProcessMsg(CommBlock:TCommBlock;OnlineMark:Boolean);
    procedure DrawList(CommBlock:TCommBlock);
    procedure RefreshClientUser(var GetList:TCommBlock);
    Procedure ComSendBillTo(AccountName,UserId,DestId,Msg,ModuleId,BillNo:String;Command:Boolean);
    procedure btnParamSettingClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
    AppPath: String;
    UserList :TStrings;
    AllowClose, bActived: Boolean;
    Function  ConnectDB: Boolean;
  protected
    procedure OnAppMessage(var Msg : TMsg ; Var Handled : Boolean);
  public
    AutoRun: Boolean;
    procedure CheckAutoRun(bSetAutoRun: Integer=0);
  end;

var
  FmMsgServer :TFmMsgServer;
  Clients: TThreadList;
  MessageID: UINT;

implementation

uses SettingFM;

{$R *.dfm}
//处理应用程序所收到的消息
procedure TFmMsgServer.OnAppMessage(var Msg : TMsg ; Var Handled : Boolean);
begin
  if Msg.Message = MessageID then
  begin
    Application.ShowMainForm := true;
    Application.Restore;
    show;
//    WindowState := wsMaximized;
    BringToFront;
    SetFocus;
    Handled := true;
  end;
end;

procedure TFmMsgServer.FormCreate(Sender: TObject);
begin
  Application.OnMessage:= OnAppMessage;
  CheckAutoRun;
  AppPath := ExtractFilePath(Application.ExeName);
  while not ConnectDB do
  begin
    with TFmSetting.Create(self) do
    begin
      if ShowModal=mrCancel then
      begin;
        Free;
        Application.Terminate;
        Exit;
      end;
      Free;
    end;
  end;
  AllowClose := False;
  ThisIP.Active := True;
  EdIP.Text := ThisIP.LocalIP;
  ThisIP.Active := False;
  userList := TStringList.Create;
  Clients := TThreadList.Create;
  Server.Active := True;
end;

procedure TFmMsgServer.FormShow(Sender: TObject);
begin
//
end;

procedure TFmMsgServer.FormActivate(Sender: TObject);
var str: String;
begin
  if bActived then Exit;
  str := LowerCase(ParamStr(1));
  if str='autoload' then begin
  	Application.Minimize;
    Application.ShowMainForm := false;
    ShowWindow(Application.Handle, SW_HIDE);
  end;
  bActived := true;
end;

//Port:=47110 发送转单消息给客户端
Procedure TFmMsgServer.ComSendBillTo(AccountName,UserId,DestId,Msg,ModuleId,BillNo:String;Command:Boolean);
var   NewCommBlock :TCommBlock;
                 i :Integer;
         RecClient :PClient;
         RecThread :TIdPeerThread;
begin
  NewCommBlock.UserId := UserId;
  NewCommBlock.UserIp := ThisIP.LocalIP;
  NewCommBlock.DestId := DestId;
  NewCommBlock.MsgDateTime := Now;
  NewCommBlock.Msg := Msg;
  NewCommBlock.Command := Command;
  NewCommBlock.CopyTo := False;
  NewCommBlock.Online := True;
  NewCommBlock.ModuleID := ModuleId;
  NewCommBlock.BillNo := BillNo;
  NewCommBlock.AccountName := AccountName;
  DrawList(NewCommBlock);
  NewCommBlock.DestId := DestId;
  with Clients.LockList do
  begin
    try
      for i := 0 to Count-1 do
      begin
        RecClient := Items[i];
//        if LowerCase(Trim(RecClient.UserId))=LowerCase(Trim(NewCommBlock.DestId)) then
        begin
          RecThread := RecClient.Thread;
          RecThread.Connection.WriteBuffer(NewCommBlock, SizeOf(NewCommBlock), True);
        end;  
      end;
    finally
      Clients.UnlockList;
    end;
 end;
end;

procedure TFmMsgServer.BtnExitClick(Sender: TObject);
begin
  if UserList.Count>0 then
  begin
    MessageBox(handle,PAnsiChar('共有：'+IntToStr(UserList.Count)+'个用户在线,不能退出系统!'),'提示',MB_ICONINFORMATION+MB_OK);
    Exit;
  end;
  if Application.MessageBox('如果退出消息处理服务器，你的整个系统都将无法接收/发送消息！是否返回？'#13'按[是]返回，按[否]确认退出！', '消息', MB_YESNO+MB_ICONWARNING)=IDYES then
    Exit;
  Try
    Clients.Free;
    Server.Active := False;
  Except
  end;
  AllowClose := True;
  Close;
end;

procedure TFmMsgServer.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  CanClose := AllowClose;
  if not CanClose then
    Application.Minimize;
end;

procedure TFmMsgServer.ServerConnect(AThread: TIdPeerThread);
var
  NewClient: PClient;
begin
  GetMem(NewClient,SizeOf(TClient));
  NewClient.Thread := AThread;
  AThread.Data := TObject(NewClient);
  try
    Clients.LockList.Add(NewClient);
  finally
    Clients.UnlockList;
  end;
end;

procedure TFmMsgServer.DrawList(CommBlock:TCommBlock);
var ListItem:TListItem;
begin
  ListItem := ListView.Items.Add;
  ListItem.Caption := CommBlock.AccountName;
  ListItem.SubItems.Add(CommBlock.UserId);
  ListItem.SubItems.Add(CommBlock.UserIp);
  ListItem.SubItems.Add('在线 ['+DateTimeToStr(Now)+']');
  ListItem.SubItems.Add(CommBlock.DestId);
  ListItem.SubItems.Add(CommBlock.Msg);
  ListItem.SubItems.Add('已转发');
end;

procedure TFmMsgServer.RefreshClientUser(var GetList:TCommBlock);
var Row:integer;
    bkMrk:TBookMark;
      i:integer;
    Found:Boolean;
begin
  if adsUser.IsEmpty then
  begin
    GetList.UserList.Count := 0;
    Exit;
  end;
  bkMrk := adsUser.GetBookmark;
  adsUser.First;
  Row:=0;
  Found := False;
  for i:=0 to CbxUserList.Count-1 do
  begin
    if CbxUserList.Items[i]='All' then
      Found := True;
  end;
  if Not(Found) then CbxUserList.Add('All');
  While Not(adsUser.Eof) do
  begin
    if adsUserAccountName.Value=GetList.AccountName then
    begin
      GetList.UserList.User[Row] := adsUserUserId.Value;
      Found := False;
      for i:=0 to CbxAccountList.Count-1 do
      begin
        if CbxAccountList.Items[i]=adsUserAccountName.Value then
          Found := True;
      end;
      if Not(Found) then CbxAccountList.Add(adsUserAccountName.Value);
      Found := False;
      for i:=0 to CbxUserList.Count-1 do
      begin
        if CbxUserList.Items[i]=adsUserUserId.Value then
          Found := True;
      end;
      if Not(Found) then CbxUserList.Add(adsUserUserId.Value);
    end;
    adsUser.Next;
    Inc(Row);
  end;
  adsUser.GotoBookmark(bkMrk);
  adsUser.FreeBookmark(bkMrk);
  GetList.UserList.Count := Row;
  CbxAccountList.ItemIndex := 0;
  CbxUserList.ItemIndex := 0;
end;

procedure TFmMsgServer.ProcessMsg(CommBlock:TCommBlock;OnlineMark:Boolean);
begin
  if Not(adsAccount.Locate('AccountName',CommBlock.AccountName,[])) then