ipprocess.pas

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

  begin
    if Trim(CommBlock.AccountName)<>'' then
    begin
      adsAccount.Append;
      adsAccountAccountName.Value := CommBlock.AccountName;
      adsAccount.Post;
    end;
    adsUser.Append;
    adsUserAccountName.Value := CommBlock.AccountName;
    adsUserUserId.Value := CommBlock.UserId;
    adsUserUserIP.Value := CommBlock.UserIP;
    adsUserOnLine.Value := True;
    adsUser.Post;
  end else begin
    if Not(adsUser.Locate('AccountName;UserId',VarArrayOf([CommBlock.AccountName,CommBlock.UserId]),[])) then
    begin
      adsUser.Append;
      adsUserAccountName.Value := CommBlock.AccountName;
      adsUserUserId.Value := CommBlock.UserId;
      adsUserUserIP.Value := CommBlock.UserIP;
      adsUserOnLine.Value := True;
      adsUser.Post;
    end else begin
      adsUser.Edit;
      adsUserUserIP.Value := CommBlock.UserIP;
      adsUserUserId.Value := CommBlock.UserId;
      adsUserOnLine.Value := True;
      adsUser.Post;
    end;
  end;
  if adsUser.Locate('AccountName;UserId',VarArrayOf([CommBlock.AccountName,CommBlock.DestId]),[]) then
  begin
    adsMsg.Append;
    adsMsgAccountName.Value := CommBlock.AccountName;
    adsMsgUserId.Value := CommBlock.DestId;
    adsMsgDestId.Value := CommBlock.UserId;
    adsMsgMsg.Value := CommBlock.Msg;
    adsMsgMsgDateTime.Value := CommBlock.MsgDateTime;
    adsMsgModuleID.Value := CommBlock.ModuleID;
    adsMsgBillNo.Value := CommBlock.BillNo;
    adsMsgCopyTo.Value := OnlineMark;
    adsMsgCommand.Value := CommBlock.Command;
    adsMsg.Post;
  end;
end;

procedure TFmMsgServer.ServerExecute(AThread: TIdPeerThread);
var
  ActClient, RecClient: PClient;
  CommBlock, NewCommBlock: TCommBlock;
  RecThread: TIdPeerThread;
  UserMark :String;
     Found :Boolean;
         i :Integer;
  SendUsered:Boolean;
begin
  if not AThread.Terminated and AThread.Connection.Connected then
  begin
  end else begin
    exit;
  end;
  AThread.Connection.ReadBuffer (CommBlock, SizeOf (CommBlock));
  ActClient := PClient(AThread.Data);
  ActClient.Account := CommBlock.AccountName;
  ActClient.UserId := CommBlock.UserId;
  ActClient.UserIP := CommBlock.UserIp;
  UserMark := CommBlock.AccountName+'::'+CommBlock.UserId;
  Found := False;
  For i:=0 to userList.Count-1 do
  begin
    if userList[i]=UserMark then Found:=True;
  end;
  if Not(Found) then
    userList.Add(UserMark);
  if CommBlock.Msg<>'_GetMsg$GetMsg_' then
  begin
    DrawList(CommBlock);
    ProcessMsg(CommBlock,False);
  end;
  if adsAccount.Locate('AccountName',CommBlock.AccountName,[]) then
  if adsUser.Locate('AccountName;UserID',VarArrayOf([CommBlock.AccountName,CommBlock.UserId]),[]) then
  begin
    adsMsg.Close;
    adsMsg.CommandText := 'Select * from TcpMsg Where CopyTo=0';
    adsMsg.Open;
    adsMsg.First;
    SendUsered := False;
    if Not(adsMsg.IsEmpty) then
    begin
      While Not(adsMsg.Eof) do
      begin
        NewCommBlock.AccountName := adsUserAccountName.Value;
        NewCommBlock.UserId := adsMsgDestId.Value;
        NewCommBlock.UserIP := adsUserUserIP.Value;
        NewCommBlock.DestId := adsMsgUserId.Value;
        NewCommBlock.Online := False;
        NewCommBlock.CopyTo := True;
        NewCommBlock.Command := adsMsgCommand.Value;
        NewCommBlock.Msg := adsMsgMsg.Value;
        NewCommBlock.MsgDateTime := adsMsgMsgDateTime.Value;
        NewCommBlock.ModuleID := adsMsgModuleId.Value;
        NewCommBlock.BillNo := adsMsgBillNo.Value;
        adsMsg.Edit;
        adsMsgCopyTo.Value := True;
        adsMsg.Post;
        if adsUserOnline.Value then
        begin
          if Not(SendUsered) then
            RefreshClientUser(NewCommBlock);
          SendUsered := True;
          with Clients.LockList do
          try
            for i := 0 to Count-1 do
            begin
              RecClient := Items[i];
           //   if LowerCase(Trim(RecClient.UserId))=LowerCase(Trim(CommBlock.UserId)) then
              begin
                RecThread := RecClient.Thread;
                RecThread.Connection.WriteBuffer(NewCommBlock, SizeOf(NewCommBlock), True);
              end;
            end;
          finally
            Clients.UnlockList;
          end;
        end;
        adsMsg.Next;
        end;
      end;
   end;
End;

procedure TFmMsgServer.ServerDisconnect(AThread: TIdPeerThread);
var
  ActClient :PClient;
   ListItem :TListItem;
          i :integer;
   UserMark :String;
begin
  ActClient := PClient(AThread.Data);
  ListItem := ListView.Items.Add;
  ListItem.Caption := ActClient^.Account;
  ListItem.SubItems.Add(ActClient^.UserId);
  ListItem.SubItems.Add(ActClient^.UserIP);
  ListItem.SubItems.Add('离线 ['+DateTimetoStr(now)+']');
  ListItem.SubItems.Add('');
  ListItem.SubItems.Add('Logout...');
  UserMark := ActClient^.Account+'::'+ActClient^.UserId;
  For i:=0 to userList.Count-1 do
  begin
    if userList[i]=UserMark then
      UserList.Delete(i);
  end;
  if adsAccount.Locate('AccountName',ActClient^.Account,[]) then
  if adsUser.Locate('UserId',ActClient^.UserId,[]) then
  begin
    adsUser.Edit;
    adsUserOnline.Value := False;
    adsUser.Post;
    adsMsg.Append;
    adsMsgAccountName.Value := ActClient^.Account;
    adsMsgUserId.Value := ActClient^.UserId;
    adsMsgDestId.Value := '';
    adsMsgMsg.Value := 'Logout...';
    adsMsgMsgDateTime.Value := Now;
    adsMsgModuleID.Value := '';
    adsMsgBillNo.Value := '';
    adsMsgCopyTo.Value := True;
    adsMsgCommand.Value := False;
    adsMsg.Post;
  end;
  try
    Clients.LockList.Remove(ActClient);
  finally
    Clients.UnlockList;
  end;
  FreeMem(ActClient);
  AThread.Data := nil;
end;

procedure TFmMsgServer.SendClick(Sender: TObject);
var   NewCommBlock :TCommBlock;
                 i :Integer;
         RecClient :PClient;
         RecThread :TIdPeerThread;
begin
  if Trim(SendText.Text)='' then Exit;
  NewCommBlock.AccountName := 'Sys$Msg';
  NewCommBlock.UserId := 'Sys$Msg';
  NewCommBlock.UserIp := ThisIP.LocalIP;
  NewCommBlock.MsgDateTime := Now;
  NewCommBlock.Msg := SendText.Text;
  NewCommBlock.Command := False;
  NewCommBlock.CopyTo := False;
  NewCommBlock.Online := True;
  NewCommBlock.ModuleID := '';
  NewCommBlock.BillNo := '';
  NewCommBlock.DestId := CbxUserList.Items[CbxUserList.ItemIndex];
  DrawList(NewCommBlock);
  if CbxAccountList.Items[CbxAccountList.ItemIndex]<>'' then
     NewCommBlock.AccountName := CbxAccountList.Items[CbxAccountList.ItemIndex];
  if CbxUserList.Items[CbxUserList.ItemIndex]='All' then
     NewCommBlock.UserId := 'All'
   else
     NewCommBlock.UserId := CbxUserList.Items[CbxUserList.ItemIndex];
  NewCommBlock.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.UserId))) or (NewCommBlock.UserId='All') then
        begin
          RecThread := RecClient.Thread;
          RecThread.Connection.WriteBuffer(NewCommBlock, SizeOf(NewCommBlock), True);
        end;
      end;
    finally
      Clients.UnlockList;
    end;
  end;
  SendText.Clear;
  SendText.SetFocus;
end;

procedure TFmMsgServer.btnParamSettingClick(Sender: TObject);
begin
  with TFmSetting.Create(self) do
  begin
    ShowModal;
    Free;
  end;
end;

Function TFmMsgServer.ConnectDB: Boolean;
const
	sLinkError = '网络连接失败，请检查服务器及网络连接！'+#13+#13+'以下是错误信息：'+#13;
  sConn1 = 'Provider=SQLOLEDB.1;Password=%s;Persist Security Info=false;User ID=%s;Initial Catalog=%s;Data Source=%s';
  sConn2 = 'Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=%s;Data Source=%s';
var IniFile: TiniFile;
    str, sDBName, sDBServer, sUser, sPassword: String;
begin
  Result := false;
  IniFile := TiniFile.Create(AppPath+'MsgSvr.INI');
  sDBName   := IniFile.ReadString('Database', 'DBName', '');
  sDBServer := IniFile.ReadString('Database', 'Server', '');
  sUser     := IniFile.ReadString('Database', 'User', '');
  sPassword := IniFile.ReadString('Database', 'Password', '');
  IniFile.Free;
  if (sDBName='')or(sDBServer='') then Exit;
  if sPassword<>'' then begin//如果使用SQL SERVER验证
    str := Format(sConn1, [sPassword, sUser, sDBName, sDBServer]);
  end else begin //如果使用NT验证
    str := Format(sConn2, [sDBName, sDBServer]);
  end;
	AdoConn.Close;
  AdoConn.ConnectionString := str;
  try
	  AdoConn.Open;
    adsMsg.Open;
    adsUser.Open;
    adsAccount.Open;
    Result := true;
  Except
  	on E:Exception do begin
	  	Application.MessageBox(PChar(sLinkError+E.Message), '连接失败', MB_OK+MB_ICONERROR);
  	  Exit;
    end;
  end;
end;

procedure TFmMsgServer.CheckAutoRun(bSetAutoRun: Integer=0);
var Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  Reg.OpenKey('\SOFTWARE\CommSoft\MsgServer', true);
  if not Reg.ValueExists('AutoRun') then
    bSetAutoRun := 1;
  if bSetAutoRun=0 then
    AutoRun := Reg.ReadBool('AutoRun')
  else begin
    AutoRun := bSetAutoRun>0;
    Reg.WriteBool('AutoRun', AutoRun);
  end;
  Reg.CloseKey;
  Reg.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run', true);
  if AutoRun then
    Reg.WriteString('MsgServer', ParamStr(0)+' autoload')
  else
    Reg.DeleteValue('MsgServer');
  Reg.CloseKey;
  Reg.Free;
end;

end.