servers.pas

三層進銷存 使用接口和連接池 是他人的面试作品 delphi语言编写

unit Servers;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  ComCtrls, ExtCtrls, Grids, DBGrids, Dialogs, jpeg, registry, DB, DBClient,
  inifiles, Menus, ActnList, TrayIcon, Comserv, StdCtrls, Winsock;

type
  Tfrmservers = class(TForm)
    StatusBar: TStatusBar;
    imagetop: TImage;
    Grid: TDBGrid;
    CDSgrid: TClientDataSet;
    DSgrid: TDataSource;
    CDSgridfid: TIntegerField;
    CDSgridfonline: TIntegerField;
    CDSgridfport: TStringField;
    CDSgridfpcname: TStringField;
    CDSgridfpcip: TStringField;
    CDSgridflogintime: TStringField;
    MainMenu1: TMainMenu;
    ActionList1: TActionList;
    A01start: TAction;
    A02stop: TAction;
    A03acct: TAction;
    A04exit: TAction;
    B01stopone: TAction;
    B02stopall: TAction;
    B03linksetting: TAction;
    B04message: TAction;
    C01about: TAction;
    C02help: TAction;
    System1: TMenuItem;
    USer1: TMenuItem;
    About1: TMenuItem;
    StartServerS1: TMenuItem;
    N1: TMenuItem;
    StopServerF1: TMenuItem;
    N2: TMenuItem;
    AcctSettingA1: TMenuItem;
    N3: TMenuItem;
    ExitSystemE1: TMenuItem;
    StopOneO1: TMenuItem;
    N4: TMenuItem;
    StopAllA1: TMenuItem;
    N5: TMenuItem;
    ADOlinkSettingS1: TMenuItem;
    N6: TMenuItem;
    SendMessageM1: TMenuItem;
    AboutSystemA1: TMenuItem;
    N7: TMenuItem;
    HelpH1: TMenuItem;
    tray: TTrayNotifyIcon;
    PopupMenu1: TPopupMenu;
    D01display: TAction;
    DisplayD1: TMenuItem;
    N8: TMenuItem;
    AboutSystemA2: TMenuItem;
    N9: TMenuItem;
    ExitSystemE2: TMenuItem;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure D01displayExecute(Sender: TObject);
    procedure A04exitExecute(Sender: TObject);
    procedure A01startExecute(Sender: TObject);
    procedure A02stopExecute(Sender: TObject);
    procedure B03linksettingExecute(Sender: TObject);
    procedure CDSgridfonlineGetText(Sender: TField; var Text: String;
      DisplayText: Boolean);
  private
    Hostip:string;
    function registpooler:boolean;
    function createadoconn:boolean;
    function creategriddata:boolean;
    { Private declarations }
  public
    Systemname:string;
    sc:string;
    function applyuser(sip:widestring):boolean;
    function exituser(spcname:widestring):Boolean;    
    { Public declarations }
  end;

var
  frmservers: Tfrmservers;

implementation

uses Datamodule, DatabaseLink;

{$R *.dfm}

function Tfrmservers.createadoconn: boolean;
var
  s:string;
  username,password,Servername,Databasename:string;
  ini:Tinifile;
begin
  S:=ExtractfilePath(Application.ExeName);
  if s[length(s)]<>'\' then
    s:=s+'\'+'Databaseset.ini'
    else
    s:=s+'Databaseset.ini';

  try
    ini:=Tinifile.Create(s);
    username:=ini.ReadString('Login','UserName','');
    password:=ini.ReadString('Login','PassWord','');
    Servername:=ini.ReadString('Login','ServerName','');
    HostIP:=ini.ReadString('Login','HostIP','');
    Databasename:=ini.ReadString('Login','DatabaseName','');
    SystemName:=ini.ReadString('Login','Systemname','');
    sc:='Provider=SQLOLEDB.1;'+
        'Password='+password+';'+
        'Persist Security Info=False;'+
        'User ID='+Username+';'+
        'Initial Catalog='+DatabaseName+';'+
        'Data Source='+ServerName+';'+
        'Use Procedure for Prepare=1;'+
        'Auto Translate=True;'+
        'Packet Size=4069;'+
        'WorkStation ID='+HostIP+';'+
        'Use Encryption for Data=False;'+
        'Tag With Column collation when possible=False';
  finally
    ini.Free; 
  end;
end;

function Tfrmservers.creategriddata: boolean;
begin
  CDSgrid.Active:=False;
  CDSgrid.FieldDefs.Clear;
  CDSgrid.FieldDefs.Add('fid',ftinteger);
  CDSgrid.FieldDefs.Add('fonline',ftinteger);
  CDSgrid.FieldDefs.Add('fport',ftString,5);
  CDSgrid.FieldDefs.Add('fpcname',ftString,18);
  CDSgrid.FieldDefs.Add('fpcip',ftString,16);
  CDSgrid.fieldDefs.Add('flogintime',ftString,26);
  CDSgrid.CreateDataSet;
  CDSgrid.Open;
end;

procedure Tfrmservers.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  action:=canone;
  self.Hide;
end;

procedure Tfrmservers.FormCreate(Sender: TObject);
var
  i:integer;
  Panels:Tstatuspanel;
begin
  imagetop.Picture.LoadFromFile(ExtractfilePath(application.ExeName)+'titleGr1.jpg');
  registpooler;
  CreategridData;
  createadoconn;
  tray.Hint:='Multi-tier Distributed Application Services';
  tray.IconVisible:=True;

  Data:=Tdata.Create(application);

  if Data.ADOConnection.Connected then
    begin
      A01start.Enabled:=False;
      A02stop.Enabled:=True;
    end;

  for i:=1 to 2 do
    begin
      panels:=Statusbar.Panels.Add;
      panels.Width:=160;
    end;

  Statusbar.Panels[0].Text:='Server IP: '+Trim(hostIP);
  Statusbar.Panels[1].Text:='Client User Total: '+Trim(inttostr(CDSgrid.RecordCount));
end;

function Tfrmservers.registpooler: boolean;
var
  ADOlinkreg:Treginifile;
begin
  Result:=True;
  try
    adolinkreg:=Treginifile.Create('');
    with ADOlinkreg do
      begin
        Rootkey:=HKEY_CLASSES_ROOT;
        if keyExists('CLSID\{E21C3EEA-650E-47C5-8C5E-5067A36610DE}') then
          begin
            openkey('CLSID',true);
            writeString('{E21C3EEA-650E-47C5-8C5E-5067A36610DE}','Sockets','1');
          end;
      end;
  finally
    Adolinkreg.CloseKey;
    Adolinkreg.Destroy;
  end;
end;

procedure Tfrmservers.D01displayExecute(Sender: TObject);
begin
  self.Show;
end;

procedure Tfrmservers.A04exitExecute(Sender: TObject);
begin
  comServer.UIInteractive:=False;
  if Messagedlg('Exit Mulit-tier,Client can not run!',mtconfirmation,[mbok,mbcancel],0)=mrok then
    begin
      application.Terminate
    end;
end;

procedure Tfrmservers.A01startExecute(Sender: TObject);
begin
  Try
    data:=Tdata.Create(application);
  except
    on Exception do;
  end;

  if Data.ADOConnection.Connected then
    begin
      A01start.Enabled:=False;
      A02stop.Enabled:=True;
    end
    else
    begin
      A01start.Enabled:=True;
      A02stop.Enabled:=False;
    end;
end;

procedure Tfrmservers.A02stopExecute(Sender: TObject);
begin
  if CDSgrid.RecordCount > 0 then
    begin
    application.MessageBox('You can not stop ,Because have client run !',
          'Error',MB_OK+MB_iconstop+MB_applmodal);
    end
    else
    begin
      data.ADOConnection.Connected:=False;
      Data.ADOConnection.ConnectionString:='';
    end;
  if Data.ADOConnection.Connected then
    begin
      A01start.Enabled:=False;
      A02stop.Enabled:=True;
    end
    else
    begin
      A01start.Enabled:=True;
      A02stop.Enabled:=False;
    end;
end;

procedure Tfrmservers.B03linksettingExecute(Sender: TObject);
begin
  if not Assigned(frmDatabaselink) then
  FrmDatabaselink:=TfrmDatabaselink.Create(application);
  frmdatabaselink.ShowModal;
end;

function Tfrmservers.applyuser(sip: widestring): boolean;
var
  NewID:integer;
  computername:string;

    function getcomputer(ip: String): string;
      var
        hostEnt:phostEnt;
        Wsadata:TWSADATA;
        Addr:DWORD;
      begin
        Result:='unKnow';
        If copy(Trim(ip),1,3)<>'192' then exit;
        WSAStartup($101,WSAData);
        Addr:=inet_addr(Pchar(ip));
        hostENT:=Gethostbyaddr(@Addr,sizeof(Addr),pf_inet);
        Result:=hostent.h_name;
        WSACleanup();
    end;

begin
  NewID:=CDSgrid.RecordCount+1;
  computername:=Getcomputer(sip);
  with CDSgrid do
    begin
      AppendRecord([NewID,1,'211',computername,sip,Datetimetostr(now)]);
      first;
    end;
  Statusbar.Panels[1].Text:='Client User Total: '+inttostr(CDSgrid.RecordCount);
end;

function Tfrmservers.exituser(spcname: widestring): Boolean;
begin
  Result:=True;
  CDSgrid.First;
  while not CDSgrid.Eof do
    begin
      if CDSgrid.FieldByName('fpcip').AsString=spcname then
        begin
        CDSgrid.Delete;
        Exit;
        end;
      CDSgrid.Next;
    end;
end;

procedure Tfrmservers.CDSgridfonlineGetText(Sender: TField;
  var Text: String; DisplayText: Boolean);
begin
  if CDSgrid.FieldByName('fonline').AsInteger > 0 then
    text:='Online'
    else
    text:='';
end;

end.