globalunit.pas

实达企业在线EOL源码

   TGlobal=Class
   private
       FAccessDB       : TAccessDB;
       FAccessDialog   : TAccessDialog;
       FAccessDateTime : TAccessDateTime;
       FAccessFile     : TAccessFile;
       FAccessFinance  : TAccessFinance;
       FAccessForm     : TAccessForm;
       FAccessNum      : TAccessNum;
       FAccessOthers   : TAccessOthers;
       FAccessString   : TAccessString;
       FAccessSystem   : TAccessSystem;
     public
        Constructor  Create ;
        destructor  Destroy;Override;  
     Published
       property AccessDB       : TAccessDB Read FAccessDB;
       property AccessDateTime : TAccessDateTime Read FAccessDateTime;
       property AccessFile     : TAccessFile Read FAccessFile;
       property AccessFinance  : TAccessFinance Read FAccessFinance;
       property AccessForm     : TAccessForm Read FAccessForm;
       property AccessNum      : TAccessNum Read FAccessNum;
       property AccessOthers   : TAccessOthers Read FAccessOthers;
       property AccessString   : TAccessString Read FAccessString;
       property AccessSystem   : TAccessSystem Read FAccessSystem;
       property AccessDialog   : TAccessDialog Read FAccessDialog ;
   end;

function ShowFormOn(AForm: TForm; AControl: TWinControl): Boolean;
function ShowFormIn(AForm: TForm;AControl: TWinControl): boolean;
var
    Global:TGlobal;

implementation

//=====================================================================
 {TGlobal}

function ShowFormOn(AForm: TForm; AControl: TWinControl): Boolean;
var
  P : TPoint;
begin
  Result := False;
  if Assigned(AControl) and Assigned(AForm) then
  begin
    try
      P.X := AControl.Left;
      P.Y := AControl.Top;
      P := AControl.ClientToScreen(P);
      AForm.Left := P.X - 2;
      AForm.Top := P.Y;
      AForm.Width := AControl.ClientWidth;
      AForm.Height := AControl.ClientHeight;
      AForm.ShowModal;
      Result := True;
    except
    end;
  end;
end;

function ShowFormIn(AForm: TForm;AControl: TWinControl): boolean;
begin
  if Assigned(AControl) and Assigned(AForm) then
  begin
    AForm.Left := 0;
    AForm.Top := 0;
    AForm.Width := AControl.ClientWidth ;
    AForm.Height := AControl.ClientHeight ;
    AForm.Parent := AControl;
    AForm.WindowState := wsMaximized;

    AForm.Show;
  end;
  Result := False;
end;

Constructor  TGlobal.Create;
begin
   FAccessDB       := TAccessDB.Create;
   FAccessDateTime := TAccessDateTime.Create;
   FAccessFile     := TAccessFile.Create;
   FAccessFinance  := TAccessFinance.Create;
   FAccessForm     := TAccessForm.Create;
   FAccessNum      := TAccessNum.Create;
   FAccessOthers   := TAccessOthers.Create;
   FAccessString   := TAccessString.Create;
   FAccessSystem   := TAccessSystem.Create;
   FAccessDialog   := TAccessDialog.Create;
end;

destructor  TGlobal.Destroy;
begin
   if Assigned(FAccessDB) then FAccessDB.Free;
   if Assigned(FAccessDateTime) then FAccessDateTime.Free;
   if Assigned(FAccessFile) then FAccessFile.Free;
   if Assigned(FAccessFinance) then FAccessFinance.Free;
   if Assigned(FAccessForm) then FAccessForm.Free;
   if Assigned(FAccessNum) then FAccessNum.Free;
   if Assigned(FAccessOthers) then FAccessOthers.Free;
   if Assigned(FAccessString) then FAccessString.Free;
   if Assigned(FAccessSystem) then FAccessSystem.Free;
   if Assigned(FAccessDialog) then FAccessDialog.Free;

   inherited Destroy;
end;


//=====================================================================
{ TAccessDB }

constructor TAccessDB.Create;
begin
  ISRunTime:=False;
  ErrorCode:=0;
  ErrorMessage:='';
end;

destructor TAccessDB.Destroy;
begin
  inherited;
end;

//创建MSSQL类型别名
Function TAccessDB.CreateMSSQLAlias(AliasName,ServerName,DataBaseName,UserName:string):boolean;
var
  MyList: TStringList;
begin
  MyList := TStringList.Create;
  result:=true;

  IF Session.IsAlias(AliasName) then BEGIN
     Session.DeleteAlias(AliasName);
  END;

  try
    with MyList do
    begin
      Add('SERVER NAME='+ServerName);
      Add('DATABASE NAME='+DataBaseName);
      Add('USER NAME='+UserName);
    end;
    TRY
       Session.AddAlias(AliasName, 'MSSQL', MyList);
       ClearError;
    EXCEPT
      On e:Exception do
      begin
        ProcessError(e);
        Result := False;
      end;
    END;
  finally
    MyList.Free;
  end;
  if result then
     Session.SaveConfigFile;
end;

//创建ACCESS类型别名
Function TAccessDB.CreateACCESSAlias(AliasName,Path:string):boolean;
var
  MyList: TStringList;
begin
  MyList := TStringList.Create;
  result:=true;
  IF Session.IsAlias(AliasName) then BEGIN
     Session.DeleteAlias(AliasName);
  END;

  try
    with MyList do
    begin
      Add('DATABASE NAME='+Path);
    end;
    TRY
      Session.AddAlias(AliasName, 'MSACCESS', MyList);
      ClearError;
    EXCEPT
      On e:Exception do
      begin
        ProcessError(e);
        Result := False;
      end;
    END;
  finally
    MyList.Free;
  end;
  if result then
     Session.SaveConfigFile;
end;

//创建 PARADOX类型别名
Function TAccessDB.CreatePARADOXAlias(AliasName,Path:string):boolean;
var
  MyList: TStringList;
begin
  MyList := TStringList.Create;
  result:=true;
  IF Session.IsAlias(AliasName) then BEGIN
     Session.DeleteAlias(AliasName);
  END;
  try
    with MyList do
    begin
      Add('PATH='+Path);
    end;
    TRY
      Session.AddAlias(AliasName, 'STANDARD', MyList);
      ClearError;
    EXCEPT
      On e:Exception do
      begin
        ProcessError(e);
        Result := False;
      end;
    END;
  finally
    MyList.Free;
  end;
  if result then
     Session.SaveConfigFile;
end;

//创建书签
Function TAccessDB.SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
begin
  Result := False;
  with ADataSet do
    if Active and (ABookmark <> nil) and not (Bof and Eof) and
      BookmarkValid(ABookmark) then
    try
      ADataSet.GotoBookmark(ABookmark);
      Result := True;
      ClearError;
    except
      On e:Exception do
      begin
        ProcessError(e);
        Result := False;
      end;
    end;
end;
//add by masj on 2000.05.25
procedure TAccessDB.ClearError;
begin
    ErrorCode := 0;
    ErrorMessage := '';
end;

function  TAccessDB.DBIsError(var mErrorCode:Word;var mErrorMessage:string):boolean;
begin
  if (ErrorCode=0) and (ErrorMessage='') then result:=false
  else Result:=true;
  mErrorCode:=ErrorCode;
  mErrorMessage:=ErrorMessage;
end;

procedure TAccessDB.ProcessError(E:Exception);
var tmpDlg:TAccessDialog;
ResourceString
  cRunMessage='应用程序异常错误！';
begin

  tmpDlg := TAccessDialog.create;
  if ISRunTime then
  begin
    tmpDlg.ShowError(cRunMessage);
  end
  else begin
    tmpDlg.ShowError(e.Message+' '+e.classname);
  end;

  ErrorCode:=-1;    //返回值为负1时则为不知名的错误
  if e is EUpDateError then
    ErrorCode := EupdateError(e).errorcode;
  if e is EDBClient then
    ErrorCode := EDBClient(e).ErrorCode;
  if e is EDSWriter then
    ErrorCode := EDSWriter(e).ErrorCode;
  if e is EoleSysError then
    ErrorCode := EoleSysError(e).ErrorCode;
  if e is EDBEngineError then
    ErrorCode := EDBEngineError(e).errors[EDBEngineError(e).errorcount-1].ErrorCode;
  ErrorMessage:=e.message;
  tmpDlg.Free;

end;

procedure TAccessDB.DBSetRunState(mIsRunTime:Boolean=True);
begin
  IsRunTime := mIsRunTime;
end;

function  TAccessDB.DBGetRunState:boolean;
begin
  result:=IsRunTime;
end;



//=====================================================================

{ TAccessSystem }

constructor TAccessSystem.Create;
begin

end;

destructor TAccessSystem.Destroy;
begin
  inherited;
end;

function TAccessSystem.Encrypt(const S:ShortString):ShortString;
var
  i   : Byte;
  Key : Word;
begin
  {...Enacrypt a string..}

  Key:=ckeyCode1;
  {$IFDEF WIN32}
     SetLength(Result,Length(S));
  {$ELSE}
     Result[0]:=Char(Length(S));
  {$ENDIF}

  for i:=1 to Length(S) do
  begin
    Result[i]:=Char( Byte(S[i]) XOR (Key SHR 8) );
    Key :=( Byte(Result[i])+Key )*ckeyCode2+ckeyCode3;
  end;
end;

function TAccessSystem.Decrypt(const S:ShortString):ShortString;
var
  i   : Byte;
  Key : Word;
begin
  {...Enacrypt a string..}

  Key:=ckeyCode1;
  {$IFDEF WIN32}
     SetLength(Result,Length(S));
  {$ELSE}
     Result[0]:=Char(Length(S));
  {$ENDIF}

  for i:=1 to Length(S) do
  begin
    Result[i]:=Char( Byte(S[i]) XOR (Key SHR 8) );
    Key :=( Byte(S[i])+Key )*ckeyCode2+ckeyCode3;
  end;
end;

{$IFDEF WIN32}
function RestartDialog(Wnd:HWnd; Reson:Pchar;Flags:Integer):Integer;Stdcall;
external 'Shell32.dll' index 59;
{$ENDIF}

//重新启动Windows操作系统。if Result=True then execute success,else falied.
function TAccessSystem.RestartWindows:Integer;
begin
  {$IFDEF WIN32}
     Result:=RestartDialog(0,Nil,ew_RestartWindows);
  {$ELSE}
     ShowMessage('Some system setting have been changed-windows needs to restart!');
     Result:=ExitWindows(ew_RestartWindows,0);
  {$ENDIF}
end;

//打开链接
procedure TAccessSystem.Link(Url:string);
begin
   ShellExecute(GetDesktopWindow(),nil,pchar(Url),nil,nil,sw_shownormal);
end;

//获得本机名称
Function TAccessSystem.ComputerName : String;
var
   CNameBuffer  : PChar;
  fl_loaded    : Boolean;
  CLen         : ^DWord;
begin
    GetMem(CNameBuffer,255);
    New(CLen);
    CLen^:= 255;
    fl_loaded := GetComputerName(CNameBuffer,CLen^);
    if fl_loaded then
      Result := StrPas(CNameBuffer)
    else
      Result := 'Unkown';
    FreeMem(CNameBuffer,255);
    Dispose(CLen);
end;

// 获得系统的临时目录
Function TAccessSystem.GetTempDirectory: String;
var
  TempDir: array[0..255] of Char;
begin
  GetTempPath(255, @TempDir);
  Result := StrPas(TempDir);
end;

//获得SQLServer服务器名称
Function TAccessSystem.GetServerName(AliasName:string):string;
var
  Strs:TStringList;
begin
  Strs := TStringList.Create;
  try
    session.GetAliasParams(AliasName,Strs);
    Result:=Strs.Values['Server Name'];
  finally
    Strs.Free;
  end;
end;

//返回Windows系统路径，引用了前面的slash函数
Function TAccessSystem.getwinsysdir:string;
var
  p:pchar;
  z:integer;
begin
  z:=255;
  getmem(p,z);
  getsystemdirectory(p,z);
  result:=Global.FAccessString.slash(string(p));
  freemem(p,z);
end;

//返回Windows路径，引用了前面的slash函数
Function TAccessSystem.getwindir:string;
var
  p:pchar;
  z:integer;
begin
  z:=255;
  getmem(p,z);
  getwindowsdirectory(p,z);
  result:=Global.FAccessString.slash(string(p));
  freemem(p,z);
end;

{返回正在使用的EXE文件安装路径}
Function TAccessSystem.getinstalldir:string;
begin
  result:=Global.FAccessString.slash(extractfiledir(paramstr(0)));
end;

{读取一个注册值}
Function TAccessSystem.getregvalue(root:integer;key,value:string):string;
var
  rg:Tregistry;
begin
  rg:=Tregistry.create;
  try
    rg.rootkey:=root;
    if rg.OpenKey(key,false) then