Ver Mensaje Individual
  #4  
Antiguo 28-10-2004
Avatar de AGAG4
AGAG4 AGAG4 is offline
Miembro
 
Registrado: ago 2004
Ubicaciσn: Los Mochis, Sinaloa, Mιxico
Posts: 1.420
Reputaciσn: 21
AGAG4 Va por buen camino
Ya los Encontre y lo muestro por si a alguien le sea de utilidad....
Cσdigo Delphi [-]
unit FireBirdUtils;


interface
  function ServiceStart(sMachine, sService : string ) : boolean;
  function ServiceStop(sMachine, sService : string ) : boolean;
  function IsNT: boolean;
  function FireBirdInstalled : boolean;
  function InterbaseInstalled : boolean;
  function GetSysDirectory: string;
  function StartInterbase: boolean;
  function GetInterbaseGuardianFile: string;
  function ShutDownInterbase: boolean;
  function IsWinNT: Boolean;
  function IsServerRunning: Boolean;
  function InterbaseRunning : boolean;
  function GetServerVersion: string;
  function GetServerVersionInsRun: string;

implementation
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, WinSvc, StdCtrls, registry,IBServices;
Const
  {Constante para FireBird}
  FB_ServerExeName = 'fbserver.exe';
  FB_RegKey = '\Software\Firebird Project\Firebird Server\Instances';
  IB_RegKey = '\Software\Borland\InterBase\CurrentVersion';
  FB_IB_RootDir = 'RootDirectory';
  FB_IB_ServerDir = 'ServerDirectory';
  FB_IB_ServerClass = 'IB_Server';
  FB_ServerClass = 'FB_Server';
  FB_IB_ServiceName = 'InterBaseServer';
  FB_AutoStartName = 'FirebirdServer';
  IB_Version = 'Version';
  FB_Version = 'Version';
  FDBAName = 'SYSDBA';
  FDBAPwd = 'masterkey';
  FDBALoginPrompt = false;
  
var
  VersionInfoAvailable: boolean;
  FIBInfo: TIBServerProperties;
  FServer, FDatabaseName: string;
  FUserName, FUserPwd: string;
  FCharSet: string;
  FSQLDialect: Integer;
  FProtocol: TProtocol;
  LastDBInfoRefresh: TDateTime;

function GetServerVersionInsRun: string;
begin
     result := '';
     try
          result := GetServerVersion;
     except result := '';
     end;
end;

function RefreshIBinfo(AnOption: TPropertyOption): boolean;
begin
  {crιι le composant ΰ la volιe}
     if FIBInfo = nil then FIBInfo := TIBServerProperties.Create(nil);
  {effectue la restauration}
     with FIBInfo, Params do
     try
          ServerName := FServer;
          if FServer = '' then Protocol := Local else Protocol := FProtocol;
          Clear;
          Add('user_name=' + FDBAName);
          Add('password=' + FDBAPwd);
          LoginPrompt := FDBALoginPrompt;
          Options := [AnOption];
          Active := True;
          case AnOption of
               Database:
                    begin
                         FetchDatabaseInfo;
                         LastDBInfoRefresh := Now;
                    end;
               ConfigParameters: FetchConfigParams;
               Version: FetchVersionInfo;
          end;
          Active := False;
          Result := True;
     except
          Result := False;
     end;
end;

  //—————————————————————————————————————————————————————————————————————————————
// Versiσn FireBird
//—————————————————————————————————————————————————————————————————————————————

function GetServerVersion: string;
begin
  if not VersionInfoAvailable then
    VersionInfoAvailable := RefreshIBInfo(Version);
  if VersionInfoAvailable then
    Result := FIBInfo.VersionInfo.ServerVersion
  else Result := '';
end;

//—————————————————————————————————————————————————————————————————————————————
// Parar un servicio en NT
//—————————————————————————————————————————————————————————————————————————————
function ServiceStop(sMachine, sService : string ) : boolean;
var schm, schs   : SC_Handle;
    ss     : TServiceStatus;
    dwChkP : DWord;
begin
  schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);
  if(schm > 0)then begin
   schs := OpenService(schm,PChar(sService),SERVICE_STOP or SERVICE_QUERY_STATUS);
   if(schs > 0)then begin
    if (ControlService(schs,SERVICE_CONTROL_STOP,ss)) then begin
     if (QueryServiceStatus(schs,ss)) then begin
      while (SERVICE_STOPPED <> ss.dwCurrentState) do begin
       dwChkP := ss.dwCheckPoint;
       Sleep(ss.dwWaitHint);
       if (not QueryServiceStatus(schs,ss))then begin
        break;
       end;
       if (ss.dwCheckPoint < dwChkP) then begin
        break;
       end;
      end;
     end;
    end;
    CloseServiceHandle(schs);
   end;
   CloseServiceHandle(schm);
  end;
  Result := (SERVICE_STOPPED = ss.dwCurrentState);
end;

//—————————————————————————————————————————————————————————————————————————————
// Arrancar un servicio en NT
//—————————————————————————————————————————————————————————————————————————————
function ServiceStart(sMachine, sService : string ) : boolean;
var schm, schs   : SC_Handle;
    ss     : TServiceStatus;
    psTemp : PChar;
    dwChkP : DWord;
begin
  ss.dwCurrentState := 0;
  schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);
  if(schm > 0)then begin
   schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);
   if (schs > 0) then begin
    psTemp := Nil;
    if (StartService(schs,0,psTemp)) then begin
     if (QueryServiceStatus(schs,ss)) then begin
      while (SERVICE_RUNNING <> ss.dwCurrentState) do begin
       dwChkP := ss.dwCheckPoint;
       Sleep(ss.dwWaitHint);
       if (not QueryServiceStatus(schs,ss)) then begin
        break;
       end;
       if (ss.dwCheckPoint < dwChkP) then begin
        break;
       end;
      end;
     end;
    end;
    CloseServiceHandle(schs);
   end;
   CloseServiceHandle(schm);
  end;
  Result := SERVICE_RUNNING = ss.dwCurrentState;
end;

//—————————————————————————————————————————————————————————————————————————————
// Saber si FireBird estα en marcha
//—————————————————————————————————————————————————————————————————————————————

function InterbaseRunning : boolean;
begin
     result := boolean(FindWindow('fbServer','FireBird Server')
               or FindWindow('IB_Guard','FireBird Guardian'));
end;
//—————————————————————————————————————————————————————————————————————————————
// Returns true if applications runs on NT/2000
//—————————————————————————————————————————————————————————————————————————————
function IsNT: boolean;
var osv: TOSVERSIONINFO;
begin
     fillchar(osv, sizeof(TOSVERSIONINFO), 0);
     osv.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);
     GetVersionEx(osv);
     if (osv.dwPlatformId = VER_PLATFORM_WIN32_NT) then
          result := true
     else result := false;
end;

function IsServerRunning: Boolean;
//try to find the Firebird server window
begin
     Result := (FindWindow({FB_IB_ServerClass}FB_ServerClass, nil) <> 0);
end;

function IsWinNT: Boolean;
begin
     Result := (Win32Platform = VER_PLATFORM_WIN32_NT);
end;

//—————————————————————————————————————————————————————————————————————————————
// Shuts down Interbase
//—————————————————————————————————————————————————————————————————————————————
function ShutDownInterbase: boolean;
var IBSRVHandle, IBGARHandle: THandle;
begin
     if IsNT then
     begin
          result := ServiceStop('', 'InterBaseGuardian');
     end else
     begin
          IBGARHandle := FindWindow('FB_Guard', 'FireBird Guardian');
          if IBGARHandle > 0 then
          begin
               PostMessage(IBGARHandle, 31, 0, 0);
               PostMessage(IBGARHandle, 16, 0, 0);
          end;
          IBSRVHandle := FindWindow('FB_Server', 'FireBird Server');
          if IBSRVHandle > 0 then
          begin
               PostMessage(IBSRVHandle, 31, 0, 0);
               PostMessage(IBSRVHandle, 16, 0, 0);
          end;
          result := IsServerRunning;
     end;
end;
//—————————————————————————————————————————————————————————————————————————————
// Returns the full name to the Interbase guardian EXE file
//—————————————————————————————————————————————————————————————————————————————
function GetInterbaseGuardianFile: string;
var Filename: string;
     Reg: TRegistry;
begin
     result := '';
     Filename := '';
     Reg := TRegistry.Create(KEY_READ);
     try
          Reg.RootKey := HKEY_LOCAL_MACHINE;
          if Reg.KeyExists('Software\Borland\InterBase\CurrentVersion') then
          begin
               if Reg.OpenKeyReadOnly('Software\Borland\InterBase\CurrentVersion') then
               begin
                    //Filename := FixPath(Reg.ReadString('ServerDirectory')) + 'ibguard.exe';
                    Filename := Reg.ReadString('ServerDirectory') + '\ibguard.exe';
                    Reg.CloseKey;
               end;
          end
          else begin
               if Reg.KeyExists(FB_RegKey) then
               begin
                    if Reg.OpenKeyReadOnly(FB_RegKey) then
                    begin
                         //Filename := FixPath(Reg.ReadString('ServerDirectory')) + 'ibguard.exe';
                         Filename := Reg.ReadString('DefaultInstance') + 'bin\fbguard.exe';
                         Reg.CloseKey;
                    end;
               end;
          end;
     finally
          Reg.free;
     end;
     result := filename;
end;


//—————————————————————————————————————————————————————————————————————————————
// Starts Interbase
//—————————————————————————————————————————————————————————————————————————————

function StartInterbase: boolean;
var Filename: string;
     StartupInfo: TStartupInfo;
     ProcessInformation: TProcessInformation;
begin
     filename := GetInterbaseGuardianFile;
     if FileExists(Filename) then
     begin
          if IsNT then
          begin
               result := ServiceStart('', 'InterBaseGuardian');
          end
          else begin
               Fillchar(StartupInfo, Sizeof(TStartupInfo), 0);
               StartupInfo.cb := sizeof(StartupInfo);
               StartupInfo.lpReserved := nil;
               StartupInfo.lpTitle := nil;
               StartupInfo.lpDesktop := nil;
               StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
               StartupInfo.wShowWindow := SW_SHOWNA;
               StartupInfo.cbReserved2 := 0;
               StartupInfo.lpReserved2 := nil;
               result := CreateProcess(nil, pchar(filename), nil, nil, False,
                    NORMAL_PRIORITY_CLASS,
                    nil, pchar(ExtractFilePath(filename)), StartupInfo, ProcessInformation);
          end;
     end
     else result := false;
end;

function GetSysDirectory: string;
var SysDir: Pchar;
begin
     SysDir := StrAlloc(255);
     try
          fillchar(SysDir^, 255, 0);
          GetSystemDirectory(SysDir, 255); // Get the "windows\system" directory
          result := SysDir;
     finally
          StrDispose(SysDir);
     end;
end;

//—————————————————————————————————————————————————————————————————————————————
// Saber si Interbase estα instalado
//—————————————————————————————————————————————————————————————————————————————
function InterbaseInstalled : boolean;
var Filename : string;
    Running : boolean;
begin
     Running := IsServerRunning;
     if Running = false then
     begin
          filename := GetInterbaseGuardianFile;
          if FileExists(Filename) then
             result := FileExists(IncludeTrailingPathDelimiter(GetSysDirectory)+'gds32.dll')
          else result := false;
     end
     else result := true;
end;

function FireBirdInstalled : boolean;
var Filename : string;
    Running : boolean;
begin
     Running := IsServerRunning;
     if Running = false then
     begin
          filename := GetInterbaseGuardianFile;
          if FileExists(Filename) then
             result := FileExists(IncludeTrailingPathDelimiter(GetSysDirectory)+'gds32.dll')
          else result := false;
     end
     else result := true;
end;

end.

Saludos.
Responder Con Cita