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
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
if FIBInfo = nil then FIBInfo := TIBServerProperties.Create(nil);
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;
function GetServerVersion: string;
begin
if not VersionInfoAvailable then
VersionInfoAvailable := RefreshIBInfo(Version);
if VersionInfoAvailable then
Result := FIBInfo.VersionInfo.ServerVersion
else Result := '';
end;
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;
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;
function InterbaseRunning : boolean;
begin
result := boolean(FindWindow('fbServer','FireBird Server')
or FindWindow('IB_Guard','FireBird Guardian'));
end;
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;
begin
Result := (FindWindow(FB_ServerClass, nil) <> 0);
end;
function IsWinNT: Boolean;
begin
Result := (Win32Platform = VER_PLATFORM_WIN32_NT);
end;
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;
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 := 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 := Reg.ReadString('DefaultInstance') + 'bin\fbguard.exe';
Reg.CloseKey;
end;
end;
end;
finally
Reg.free;
end;
result := filename;
end;
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); result := SysDir;
finally
StrDispose(SysDir);
end;
end;
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.