settingfm.pas

来自「群星医药系统源码」· PAS 代码 · 共 311 行

unit SettingFM;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Mask, RzEdit, RzLabel, ExtCtrls, RzPanel, DB, ADODB, ComObj,
  RzButton, RzBckgnd, RzCmboBx, RzCommon, RzSelDir, IniFiles, RzRadChk;

type
  TFmSetting = class(TForm)
    RzPanel1: TRzPanel;
    ADOCon: TADOConnection;
    Query: TADOQuery;
    RzGroupBox1: TRzGroupBox;
    RzLabel1: TRzLabel;
    RzLabel2: TRzLabel;
    RzLabel3: TRzLabel;
    edtLoginName: TRzEdit;
    edtPassword: TRzEdit;
    edtServer: TRzComboBox;
    RzLabel4: TRzLabel;
    edtDBName: TRzEdit;
    RzPanel2: TRzPanel;
    btnOK: TRzBitBtn;
    btnClose: TRzBitBtn;
    SelectDirDlg: TRzSelDirDialog;
    ckAutoRun: TRzCheckBox;
    procedure btnOKClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ckAutoRunClick(Sender: TObject);
  private
    sAppPath: String;
//    function CreateDB(sDBName, sDataFile, sLogFile, sDBLogon, sLogonPass: String): Boolean;
    Function GetSQLServerList(SvrList: TStrings): Boolean;
    function CreateMsgTable: Boolean;
    function ExistsTable(sTableName: string): Boolean;
  public
    { Public declarations }
  end;

var
  FmSetting: TFmSetting;

const
  MsgDBVer = 0;

implementation

uses IpProcess;

{$R *.dfm}

procedure TFmSetting.FormCreate(Sender: TObject);
var IniFile: TIniFile;
begin
  ckAutoRun.Checked := FmMsgServer.AutoRun;
  sAppPath := ExtractFilePath(Application.ExeName);
  IniFile := TIniFile.Create(sAppPath+'MsgSvr.INI');
  edtDBName.Text := IniFile.ReadString('Database', 'DBName', '');
  edtServer.Text := IniFile.ReadString('Database', 'Server', '');
  edtLoginName.Text := IniFile.ReadString('Database', 'User', '');
  edtPassword.Text  := IniFile.ReadString('Database', 'Password', '');
  IniFile.Free;
end;

procedure TFmSetting.FormShow(Sender: TObject);
begin
  GetSQLServerList(edtServer.Items);
end;

procedure TFmSetting.btnOKClick(Sender: TObject);
const
  sLinkErr = '连接失败！请检查服务器或网络连接！'#13;
  sExistsDB = 'SELECT 1 FROM   master..sysdatabases WHERE  name = ''%s''';
	sqCreateDB = 'CREATE DATABASE %s ON (NAME=MsgDB_Data, FILENAME=''%s'', SIZE=20, FILEGROWTH=10) '
              +'LOG ON (NAME=MsgDB_LOGON, FILENAME = ''%s'',SIZE=20MB, FILEGROWTH=5MB)';

var IniFile: TIniFile;
  sServer, sDBName, sLogName, sPassword, ConnPerfix, ConnAftFix, str, sDir, sFile1, sFile2: string;
begin
  sDBName := edtDBName.Text;
  sServer := edtServer.Text;
  sLogName := edtLoginName.Text;
  sPassword := edtPassword.Text;
  if sServer='' then
  begin
    Application.MessageBox('请选择服务器名！', '提示', MB_ICONINFORMATION);
    exit;
  end;
  if sLogName<>'' then begin//如果使用SQL SERVER验证
    ConnPerfix := 'Provider=SQLOLEDB.1;Password='+sPassword+';Persist Security Info=false;User ID='+sLogName+';Initial Catalog=';
    ConnAftFix := ';Data Source='+edtServer.Text;                //这一段为True则保存密码
  end else begin //如果使用NT验证
	  ConnPerfix := 'Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=';
  	ConnAftFix := ';Data Source='+edtServer.Text;
  end;
  ADOCon.Close;
  ADOCon.ConnectionString := ConnPerfix+'Master'+ConnAftfix;
  try
    ADOCon.Open;
  except
    on E:Exception do begin
	  	Application.MessageBox(PChar(sLinkErr+E.Message), '连接失败', MB_OK+MB_ICONERROR);
  	  Exit;
    end;
  end;

  Query.Close;
  query.SQL.Clear;
  Query.SQL.Add(Format(sExistsDB, [edtDBName.text]));
  Query.Open;
  if Query.IsEmpty then //如果数据库不存在，
  begin
    if Application.MessageBox('数据库不存在，要新建一个数据库吗？','提示',MB_YesNo + MB_ICONQUESTion) = IDYes then
    Begin
      if SelectDirDlg.Execute then //建立数据库
      Begin
        sDir:= SelectDirDlg.Directory;
        if sDir[Length(sDir)]<>'\' then
          sDir := sDir+'\';
        sFile1 := sDir+sDBName+'.mdf';
        sFile2 := sDir+sDBName+'_Log.ldf';
        str := Format(sqCreateDB, [sDBName, sFile1, sFile2]);
        Query.Close;
        Query.SQL.Text := str;
        try
          Query.ExecSQL;
        except
          Application.MessageBox('数据库建立失败！请检查服务器或网络连接！','警告',MB_OK+MB_ICONINFORMATION);
          exit;
        end;
      end;
    end;
  end;

  ADOCon.Close;
  ADOCon.ConnectionString := ConnPerfix+sDBName+ ConnAftfix;
  ADOCon.Open;
  Query.Close;
  if not ExistsTable('MsgSvrInfo') then
  begin
    if not CreateMsgTable then //建立数据表
    begin
      Application.MessageBox('创建数据表失败！请重新创建数据库！','警告',MB_OK+MB_ICONINFORMATION);
      exit;
    end;
  end;
  IniFile := TIniFile.Create(sAppPath+'MsgSvr.INI');
  IniFile.WriteString('Database', 'DBName', edtDBName.Text);
  IniFile.WriteString('Database', 'Server', edtServer.Text);
  IniFile.WriteString('Database', 'User', edtLoginName.Text);
  IniFile.WriteString('Database', 'Password', edtPassword.Text);
  IniFile.Free;
  ModalResult := mrOK;
end;
(*
//sDBName:数据库文名； sDataFile:数据库文件名； sLogFile：日志文件名； sDBLogon:登录名； sLogonPass:登录密码
function TFmSetting.CreateDB(sDBName, sDataFile, sLogFile, sDBLogon, sLogonPass: String): Boolean;
const
	sqCreateDB = 'CREATE DATABASE %s ON (NAME=MsgDB_Data, FILENAME=''%s'', SIZE=20, FILEGROWTH=10) '
              +'LOG ON (NAME=MsgDB_LOGON, FILENAME = ''%s'',SIZE=20MB, FILEGROWTH=5MB)';

	sLinkError = '网络连接失败，请检查服务器及网络连接！'+#13+#13+'以下是错误信息：'+#13;
var
  ConnPerfix, ConnAftFix, str: String;
begin
	Result := false;
  if sDBLogon<>'' then begin//如果使用SQL SERVER验证
    ConnPerfix := 'Provider=SQLOLEDB.1;Password='+sLogonPass+';Persist Security Info=false;User ID='+sDBLogon+';Initial Catalog=';
    ConnAftFix := ';Data Source='+edtServer.Text;                //这一段为True则保存密码
  end else begin //如果使用NT验证
	  ConnPerfix := 'Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=';
  	ConnAftFix := ';Data Source='+edtServer.Text;
  end;
	ADOCon.Close;
  ADOCon.ConnectionString := ConnPerfix+'Master'+ConnAftfix;
  try
	  ADOCon.Open;
  Except
  	on E:Exception do begin
	  	Application.MessageBox(PChar(sLinkError+E.Message), '连接失败', MB_OK+MB_ICONERROR);
  	  Exit;
    end;
  end;
  Query.Close;
  Query.SQL.Text := 'SELECT COUNT(1) FROM sysdatabases WHERE NAME='''+sDBName+'''';
  Query.Open;
  if Query.Fields[0].AsInteger>0 then begin
    result := false;
    Exit;
  end;
  str := Format(sqCreateDB, [sDBName, sDataFile, sLogFile]);
  Query.Close;
  Query.SQL.Text := str;
  Query.ExecSQL;
  result := true;
end;
*)
Function TFmSetting.GetSQLServerList(SvrList: TStrings): Boolean;
var
  SQLServer: Variant;
  ServerList: Variant;
  i, k: integer;
begin
  Result := true;
  try
    SQLServer := CreateOleObject('SQLDMO.Application');
    ServerList := SQLServer.ListAvailableSQLServers;
    SvrList.Clear;
    k := ServerList.Count;
    for i := 1 to k do
      SvrList.Add(ServerList.Item(i));
    SQLServer := NULL;
    serverList := NULL;
  Except
    Result := false;
  end;
end;

procedure TFmSetting.btnCloseClick(Sender: TObject);
begin
  Close;
end;

function TFmSetting.CreateMsgTable: Boolean;
const
  sCreateMsgSvrInfo = 'CREATE TABLE MsgSvrInfo(DBVersion int) insert MsgSvrInfo values(0)';
  sCreateTcpAccount = 'CREATE TABLE TcpAccount(AccountName	varchar(32) not null, CONSTRAINT PK_TcpAccount PRIMARY KEY(AccountName))';
  sCreateTcpMsg = 'CREATE TABLE TcpMsg('
      +'  MsgUnique	int IDENTITY(1,1) NOT NULL,'
      +'  AccountName	varchar(32) NOT NULL,'
      +'  UserId	varchar(20) COLLATE Chinese_PRC_CI_AS NULL ,'
      +'  Msg		varchar(200) COLLATE Chinese_PRC_CI_AS NULL ,'
      +'  MsgDateTime	datetime NOT NULL Default GetDate(),'
      +'  ModuleID	varchar(40),'
      +'  BillNo	varchar(40),'
      +'  DestId	varchar(20),'
      +'  CopyTo	bit NOT NULL default 0,'
      +'  Command	bit NOT NULL default 0, CONSTRAINT PK_TcpMsg PRIMARY KEY(MsgUnique))';
 sCreateTcpuser = 'CREATE TABLE TcpUser ('
      +' UsrUnique	int IDENTITY(1,1) NOT NULL,'
      +' AccountName	varchar(32) NOT NULL,'
      +' UserId	varchar(20) NOT NULL,'
      +' UserIP	varchar(15),'
      +' Online	BIT NOT NULL,'
      +'CONSTRAINT PK_TcpUser PRIMARY KEY(UsrUnique))';
begin
  result := false;

  Query.Close;
  Query.SQL.Text := sCreateMsgSvrInfo;
  Query.ExecSQL;
  if not ExistsTable('TcpAccount') then
  begin
    Query.Close;
    Query.SQL.Clear;
    Query.SQL.Add(sCreateTcpAccount);
    Query.ExecSQL;
  end;

  if not ExistsTable('TcpMsg') then
  begin
    Query.Close;
    Query.SQL.Clear;
    Query.SQL.Add(sCreateTcpMsg);
    Query.ExecSQL;
  end;

  if not ExistsTable('TcpUser') then
  begin
    Query.Close;
    Query.SQL.Clear;
    Query.SQL.Add(sCreateTcpuser);
    Query.ExecSQL;
  end;

  result := true;
end;

function TFmSetting.ExistsTable(sTableName: string): Boolean; //判断表是否存在
const
  Sql = 'SELECT Name FROM sysobjects WHERE  Name = ''%s'' AND type = ''U''';
begin
  result := false;
  if sTablename = '' then exit;
  Query.Close;
  Query.SQL.Clear;
  Query.SQL.Add(Format(Sql, [sTableName]));
  Query.Open;
  if Query.FieldByName('Name').AsString = '' then
    result := false
  else
    result := true;
end;

procedure TFmSetting.ckAutoRunClick(Sender: TObject);
var i: Integer;
begin
  if not self.Visible then Exit;
  if ckAutoRun.Checked then
    i := 1
  else
    i := -1;
  FmMsgServer.CheckAutoRun(i);
end;

end.