Fb/Ib Kurulumu veya çalışıyor mu?

serkan · Mesaj gönderen **serkan** » 06 Ağu 2005 04:07

arkadaşlar kolay gelsin...
Firebird kullanan bir projeyi çalıştırdığımızda bilgisayarda firebird kurulu değilse veya server çalışmıyorsa windows hata mesajları veriyor ve makinaya restart atana kadarda iflah olmuyor...acaba program açılırken ana formun oncrate olayına yazılacak bir kodla bunu kontrol edip ''Veritabanı Bağlantısı Kurulamıyor!Lütfen bilgi işlem departmanını arayınız'' gibi bir msj.verdirebilirmiyiz..
teşekkürler...

Uğur1982 · Mesaj gönderen **Uğur1982** » 06 Ağu 2005 04:15

merhaba;

Böyle yapılabilir gibi..

Kod: Tümünü seç

try
  ----
  veritabanı
  bağlantı kodların--
  -----
except //hata oluşmuşsa
  Showmessage('Veritabanı Bağlantısı Kurulamıyor!Lütfen bilgi işlem departmanını arayınız' );
  Exit;

end;

iyi günler...

Mesaj gönderen **rsimsek** » 06 Ağu 2005 10:29

try / except ile kontrol edilebilir fakat başka sebeplerden de exception alabilirsiniz. Mesela veritabanı dosyası silinmiş bulunamıyor vb. Arama yaparsan kurulu ve çalışır durumda olduğunu kontrol eden kodalara ulaşabilirsin

coskundeniz · Mesaj gönderen **coskundeniz** » 19 Ağu 2005 02:19

Merhabalar

Aşağıdaki kod, IB/FB için her türlü ihtiyacını karşılar.

Kod: Tümünü seç

unit IBFBSrvUnit;

interface

uses Sysutils, Windows, Registry, ShellAPI, WinSvc;

const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;
  ENGINE_ID = 1;
  INDEX_SERVER_ID = 2;
  STOP_LISTS_ID = 21;
  NEUTRAL_STOP_LIST_ID = 211;
  ENGLISH_STOP_LIST_ID = 212;
  MORPHOLOGY_ID = 3;
  SOUNDEX_ID = 4;
  THESAURUS_ID = 5;
  THES_PROJ_ID = 51;
  THES_DIC_ID = 52;
  LOGIN_ID = 6;
  FILTER_ID = 7;
  THES_DIC_OFFSET = 10000;

function GetSysDirectory: string;
function GetIBRootDir: string;
function IsNT: boolean;
function IsAdmin: Boolean;
function ServiceCreate(sMachine, sService, sDisplayName, sBinFile: string; StartType: integer): boolean;
function ServiceDelete(sMachine, sService: string): boolean;
function ServiceStart(sMachine, sService: string): boolean;
function ServiceStop(sMachine, sService: string): boolean;
function GetInterbaseGuardianFile: string;
function GetInterbaseIsqlFilePath: string;
function InterbaseRunning: boolean;
function ShutDownInterbase: boolean;
function StartInterbase: boolean;
function InterbaseInstalled: boolean;


function GetFBRootDir: string;
function GetFireBirdGuardianFile: string;
function GetFireBirdIsqlFilePath: string;
function FireBirdRunning: boolean;
function ShutDownFireBird: boolean;
function StartFireBird: boolean;
function FireBirdInstalled: boolean;


implementation

//—————————————————————————————————————————————————————————————————————————————
// Returns the system directory for the current running OS
//—————————————————————————————————————————————————————————————————————————————

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;

//—————————————————————————————————————————————————————————————————————————————
// Returns the Interbase installation path
//—————————————————————————————————————————————————————————————————————————————

function GetIBRootDir: string;
var Reg: TRegistry;
begin
  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
            if Reg.ValueExists('RootDirectory') then begin
                result := Reg.ReadString('RootDirectory');
              end;
            Reg.CloseKey;
          end else result := '';
      end else result := '';
  finally
    Reg.free;
  end;
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;

//—————————————————————————————————————————————————————————————————————————————
// Returns true if the current user is an administrator
//—————————————————————————————————————————————————————————————————————————————

function IsAdmin: Boolean;
var
  hAccessToken: THandle;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWORD;
  psidAdministrators: PSID;
  x: Integer;
  bSuccess: BOOL;
begin
  if IsNT then begin
      Result := False;
      bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken);
      if not bSuccess then begin
          if GetLastError = ERROR_NO_TOKEN then
            bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken);
        end;
      if bSuccess then begin
          GetMem(ptgGroups, 1024);
          bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize);
          CloseHandle(hAccessToken);
          if bSuccess then begin
              AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID,
                DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
              for x := 0 to ptgGroups.GroupCount - 1 do begin
                  if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then begin
                      Result := True;
                      Break;
                    end;
                end;
{$R+}
              FreeSid(psidAdministrators);
            end;
          FreeMem(ptgGroups);
        end;
    end else result := true; // If not running on Windows NT then admin = ok
end;

//—————————————————————————————————————————————————————————————————————————————
// Creates an NT Service
//—————————————————————————————————————————————————————————————————————————————

function ServiceCreate(sMachine, sService, sDisplayName, sBinFile: string; StartType: integer): boolean;
var schm, schs: SC_Handle;
begin
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CREATE_SERVICE);
  if (schm > 0) then begin
      schs := CreateService(schm, PChar(sService), pchar(sDisplayName), SERVICE_ALL_ACCESS,
        SERVICE_INTERACTIVE_PROCESS or SERVICE_WIN32_OWN_PROCESS, StartType,
        SERVICE_ERROR_NORMAL, pchar(sBinFile), nil, nil, nil, nil, nil);
      if (schs > 0) then begin
          result := true;
          CloseServiceHandle(schs);
        end else result := false;
      CloseServiceHandle(schm);
    end else result := false;
end;

//—————————————————————————————————————————————————————————————————————————————
// Removes an NT Service
//—————————————————————————————————————————————————————————————————————————————

function ServiceDelete(sMachine, sService: string): boolean;
var schm, schs: SC_Handle;
begin
  schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CREATE_SERVICE);
  if (schm > 0) then begin
      schs := OpenService(schm, pchar(sService), SERVICE_ALL_ACCESS);
      if (schs > 0) then begin
          result := DeleteService(schs);
          CloseServiceHandle(schs);
        end else result := false;
      CloseServiceHandle(schm);
    end else result := false;
end;

//—————————————————————————————————————————————————————————————————————————————
// Starts an NT service
//—————————————————————————————————————————————————————————————————————————————

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;

//—————————————————————————————————————————————————————————————————————————————
// Stops an NT service
//—————————————————————————————————————————————————————————————————————————————

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;

//—————————————————————————————————————————————————————————————————————————————
// Returns the full name to the Interbase guardian EXE file
//—————————————————————————————————————————————————————————————————————————————

function GetInterbaseGuardianFile: string;
var
  Filename: string;
  Reg: TRegistry;
begin
  Filename := '';
  Reg := TRegistry.Create(KEY_READ);
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('Software\InterBase Corp\InterBase\CurrentVersion') then begin
        if Reg.OpenKeyReadOnly('Software\InterBase Corp\InterBase\CurrentVersion') then begin
            Filename := Reg.ReadString('ServerDirectory') + 'ibguard.exe';
            Reg.CloseKey;
          end;
      end else begin
        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;
      end;
  finally
    Reg.free;
  end;
  result := filename;
end;

function GetInterbaseIsqlFilePath: string;
begin
  result := GetIBRootDir + 'bin';
end;


//—————————————————————————————————————————————————————————————————————————————
// returns true if Interbase is running
//—————————————————————————————————————————————————————————————————————————————
{
#define GUARDIAN_APP_NAME		"Firebird Guardian"
#define GUARDIAN_APP_LABEL		"Firebird Guardian"
#define GUARDIAN_CLASS_NAME		"FB_Guard"

#define SS_EXECUTABLE			"fbserver.exe"
#define CS_EXECUTABLE			"fb_inet_server.exe"
}
function InterbaseRunning: boolean;
begin
  result := boolean(FindWindow('IB_Server', 'InterBase Server')
    or FindWindow('IB_Guard', 'InterBase Guardian'));
end;


//—————————————————————————————————————————————————————————————————————————————
// Shuts down Interbase
//—————————————————————————————————————————————————————————————————————————————

function ShutDownInterbase: boolean;
var IBSRVHandle, IBGARHandle: THandle;
begin
  if IsNT then
  begin
    result := ServiceStop('', 'InterBaseGuardian');
  end
  else
  begin
    IBGARHandle := FindWindow('IB_Guard', 'InterBase Guardian');
    if IBGARHandle > 0 then
    begin
      PostMessage(IBGARHandle, 31, 0, 0);
      PostMessage(IBGARHandle, 16, 0, 0);
    end;
    IBSRVHandle := FindWindow('IB_Server', 'InterBase Server');
    if IBSRVHandle > 0 then
    begin
      PostMessage(IBSRVHandle, 31, 0, 0);
      PostMessage(IBSRVHandle, 16, 0, 0);
    end;
    result := InterbaseRunning;
  end;
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;

//—————————————————————————————————————————————————————————————————————————————
// Returns TRUE if Interbase is installed
//—————————————————————————————————————————————————————————————————————————————

function InterbaseInstalled: boolean;
var
  Filename: string;
  Running: boolean;
  Reg: TRegistry;
begin
  Running := InterbaseRunning;
  if Running = false then begin
      filename := GetInterbaseGuardianFile;
      if FileExists(Filename) then begin
          if FileExists(GetSysDirectory + '\gds32.dll') then result := true else result := false;
        end else result := false;
    end else result := true;
end;


//********************************************************************
// FireBird
//********************************************************************
function GetFBRootDir: string;
var Reg: TRegistry;
begin
  Reg := TRegistry.Create(KEY_READ);
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('\Software\Firebird Project\Firebird Server\Instances') then begin
        if Reg.OpenKeyReadOnly('\Software\Firebird Project\Firebird Server\Instances') then begin
            if Reg.ValueExists('DefaultInstance') then begin
                result := Reg.ReadString('DefaultInstance');
              end;
            Reg.CloseKey;
          end else result := '';
      end else result := '';
  finally
    Reg.free;
  end;
end;


function GetFireBirdGuardianFile: string;
begin
  result := GetFBRootDir+'bin\fbguard.exe';
end;

function GetFireBirdIsqlFilePath: string;
begin
  result := GetFBRootDir + 'bin';
end;

function FireBirdRunning: boolean;
begin
  result := boolean(FindWindow('FB_Server', 'FireBird Server')
    or FindWindow('FB_Guard', 'FireBird Guardian'));
end;

function ShutDownFireBird: boolean;
var
  IBSRVHandle,
  IBGARHandle: THandle;
begin
  if IsNT then
  begin
    result := ServiceStop('', 'FirebirdGuardianDefaultInstance');
//    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 := FireBirdRunning;
  end;
end;

function StartFireBird: boolean;
var
  Filename: string;
  StartupInfo: TStartupInfo;
  ProcessInformation: TProcessInformation;
begin
  filename := GetFireBirdGuardianFile;
  if FileExists(Filename) then begin
      if IsNT then begin result := ServiceStart('', 'FirebirdGuardianDefaultInstance');
        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 FireBirdInstalled: boolean;
var
  Filename: string;
  Running: boolean;
  Reg: TRegistry;
begin
  Running := FireBirdRunning;
  if Running = false then begin
      filename := GetFireBirdGuardianFile;
      if FileExists(Filename) then begin
          if FileExists(GetSysDirectory + '\gds32.dll') then result := true else result := false;
        end else result := false;
    end else result := true;
end;


end.

Mesaj gönderen **fduman** » 19 Ağu 2005 02:31

Yukarıdaki kod işe yarar ve güzel bir koda benziyor.

Maalesef try except FB client kurulu değilse işe yaramıyor. Çünkü IBX uniti initialization esnasında DLL i yüklemeye çalışıyor. Belki IBX unitine müdahale ile bu sorunun üstesinden gelebilirsiniz.

Uğur1982 · Mesaj gönderen **Uğur1982** » 19 Ağu 2005 04:50

@coskundeniz, unit için teşekkür ederim...

iyi günler...

Okann · Mesaj gönderen **Okann** » 09 Tem 2010 04:32

Aşağıda hata kodu ve hatanın olduğu yerin yanında açıklama var lütfen bana yardımcı olailirmisiniz. düzeltemiyorum hatayı

Kod: Tümünü seç

function TfrmMain.InstallAndStartGuardian: Boolean;
var
  sFBPath, sExecName: string;
  lArray: array[0..255] of Char;
  bResultInstall, bResultStart: Boolean;
begin
  Result := False;
  if (IsNT = True) then
  begin
    sFBPath := GetFBRootDir;
    if (sFBPath <> '') then
    begin
      sExecName := Format('%s%s', [sFBPath,'bin\instsvc.exe i -s -g -a']);
      if (WinExec(StrPCopy(lArray, sExecName), 2) > 31) then  tam olarak bu satırda hata veriyor. normalde kod yazma aşamasında hata yok ama compile ederken hata veriyor. Sebebi ne olabilir.
      begin
        result := True;
      end;
    end;
  end else
  begin
    bResultInstall := False;
    bResultStart   := False;
    sFBPath        := GetFBRootDir;
    with TRegistry.Create do
    try
      RootKey := HKEY_LOCAL_MACHINE;
      if (OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', False)=True) then
      begin
        WriteString('Firebird Guardian', sFBPath + 'bin\fbguard.exe -a');
        bResultInstall := True;
      end;
    finally
      CloseKey;
      Free;
    end;
    if (sFBPath <> '') then
    begin
      sExecName := Format('%s%s', [sFBPath, 'bin\fbguard.exe']);
      if (WinExec(StrPCopy(lArray, sExecName), 2) > 31) then  yine buradada aynı şekilde hata veriyor..
      begin
        bResultStart := True;
      end;
    end;
    if ((bResultInstall = True) and (bResultStart = True)) then
    begin
      Result := True;
    end;
  end;
end;


hata kodu [DCC Error] unMain.pas(222): E2010 Incompatible types: 'Char' and 'AnsiChar'

Okann · Mesaj gönderen **Okann** » 10 Tem 2010 05:31

yardımcı olabilecek yokmu

Mesaj gönderen **sabanakman** » 10 Tem 2010 09:34

String tipi yerine AnsiString tipini kullan. Sanırım Delphi2009 veya üstü versiyon kullanıyorsunuz. UniCode üzerine araştırma yaparsanız daha detaylı cevaplar elde edebilirsiniz.

Okann · Mesaj gönderen **Okann** » 11 Tem 2010 03:35

dediğiniz gibi yaptım fakat stringi değil char yerine ansichar kullandım stringi ansistring yapınca çok uyarı veriyo yani aslında char kısmından dolayı hata veriyormuş o yüzden char kısmını ansichar yaptım
[DCC Warning] unMain.pas(231): W1058 Implicit string cast with potential data loss from 'string' to 'AnsiString' şuanda sadece verdiği uyarı bu kullanım aşamasında bu uyarı çalışmasını etkilermi yada bu uyarıyıda ortadan kaldırmanın bir yoılu varmı teşekkürler mesajımla ilgilendiğiniz için

PROGRAMADOR · Mesaj gönderen **PROGRAMADOR** » 19 Ağu 2014 04:58

Yukarıdaki kod x64 Firebird'de hata veriyor. Bende x64 Firebird kurulu ve kod çalışmıyor. Bu konuda yardımcı olabilecek var mı?

Delphi Forum

Fb/Ib Kurulumu veya çalışıyor mu?

Fb/Ib Kurulumu veya çalışıyor mu?

Re: Fb/Ib Kurulumu veya çalışıyor mu?

Re: Fb/Ib Kurulumu veya çalışıyor mu?

Re: Fb/Ib Kurulumu veya çalışıyor mu?

Re: Fb/Ib Kurulumu veya çalışıyor mu?

Re: Fb/Ib Kurulumu veya çalışıyor mu?