Çeşitli kod ipuçları

[ikutluay]

Kod: Tümünü seç

uses
  Registry;

procedure TForm1.GetDataSourceNames(System: Boolean);
var
  reg: TRegistry;
begin
  ListBox1.Items.Clear;

  reg := TRegistry.Create;
  try
    if System then
      reg.RootKey := HKEY_LOCAL_MACHINE
    else
      reg.RootKey := HKEY_CURRENT_USER;

    if reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources', False) then
    begin
      reg.GetValueNames(ListBox1.Items);
    end;

  finally
    reg.CloseKey;
    FreeAndNil(reg);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //System DSNs
  GetDataSourceNames(True);

  //User DSNs
  GetDataSourceNames(False);
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table.Close;
  Table.Exclusive := True;
  Table.Open;
  DbiRegenIndexes(Table.Handle);
  Table.Close;
end;

[ikutluay]

Kod: Tümünü seç

/ Read an MS-ACCESS Database using ADO
// Verify if it is an ACCESS MDB File
// Write a Record to MS-ACCESS Database
// Components Needed on the Application Form are:-
//    TADOtable,TDataSource,TOpenDialog,TDBGrid,
//    TBitBtn,TTimer,TEditTextBox
// Date : 22/01/2002
// Author: Michael Casse.

program ADOdemo;

uses
  Forms,
  uMain in 'uMain.pas' {frmMain};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.Run;
end.
///////////////////////////////////////////////////////////////////
unit uMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons,
  ComObj;

type
  TfrmMain = class(TForm)
    DBGridUsers: TDBGrid;
    BitBtnClose: TBitBtn;
    DSource1: TDataSource;
    EditTextBox: TEdit;
    BitBtnAdd: TBitBtn;
    TUsers: TADOTable;
    BitBtnRefresh: TBitBtn;
    Timer1: TTimer;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure ConnectToAccessDB(lDBPathName, lsDBPassword: string);
    procedure ConnectToMSAccessDB(lsDBName, lsDBPassword: string);
    procedure AddRecordToMSAccessDB;
    function CheckIfAccessDB(lDBPathName: string): Boolean;
    function GetDBPath(lsDBName: string): string;
    procedure BitBtnAddClick(Sender: TObject);
    procedure BitBtnRefreshClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    function GetADOVersion: Double;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  Global_DBConnection_String: string;
const
  ERRORMESSAGE_1 = 'No Database Selected';
  ERRORMESSAGE_2 = 'Invalid Access Database';

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  ConnectToMSAccessDB('ADODemo.MDB', '123'); // DBName,DBPassword
end;

procedure TfrmMain.ConnectToMSAccessDB(lsDBName, lsDBPassword: string);
var
  lDBpathName: string;
begin
  lDBpathName := GetDBPath(lsDBName);
  if (Trim(lDBPathName) <> '') then
  begin
    if CheckIfAccessDB(lDBPathName) then
      ConnectToAccessDB(lDBPathName, lsDBPassword);
  end
  else
    MessageDlg(ERRORMESSAGE_1, mtInformation, [mbOK], 0);
end;

function TfrmMain.GetDBPath(lsDBName: string): string;
var
  lOpenDialog: TOpenDialog;
begin
  lOpenDialog := TOpenDialog.Create(nil);
  if FileExists(ExtractFileDir(Application.ExeName) + '\' + lsDBName) then
    Result := ExtractFileDir(Application.ExeName) + '\' + lsDBName
  else
  begin
    lOpenDialog.Filter := 'MS Access DB|' + lsDBName;
    if lOpenDialog.Execute then
      Result := lOpenDialog.FileName;
  end;
end;

procedure TfrmMain.ConnectToAccessDB(lDBPathName, lsDBPassword: string);
begin
  Global_DBConnection_String :=
    'Provider=Microsoft.Jet.OLEDB.4.0;' +
    'Data Source=' + lDBPathName + ';' +
    'Persist Security Info=False;' +
    'Jet OLEDB:Database Password=' + lsDBPassword;

  with TUsers do
  begin
    ConnectionString := Global_DBConnection_String;
    TableName        := 'Users';
    Active           := True;
  end;
end;

// Check if it is a valid ACCESS DB File Before opening it.

function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean;
var
  UnTypedFile: file of Byte;
  Buffer: array[0..19] of Byte;
  NumRecsRead: Integer;
  i: Integer;
  MyString: string;
begin
  AssignFile(UnTypedFile, lDBPathName);
  reset(UnTypedFile,1);
  BlockRead(UnTypedFile, Buffer, 19, NumRecsRead);
  CloseFile(UnTypedFile);
  for i := 1 to 19 do MyString := MyString + Trim(Chr(Ord(Buffer[i])));
  Result := False;
  if Mystring = 'StandardJetDB' then
    Result := True;
  if Result = False then
    MessageDlg(ERRORMESSAGE_2, mtInformation, [mbOK], 0);
end;

procedure TfrmMain.BitBtnAddClick(Sender: TObject);
begin
  AddRecordToMSAccessDB;
end;

procedure TfrmMain.AddRecordToMSAccessDB;
var
  lADOQuery: TADOQuery;
  lUniqueNumber: Integer;
begin
  if Trim(EditTextBox.Text) <> '' then
  begin
    lADOQuery := TADOQuery.Create(nil);
    with lADOQuery do
    begin
      ConnectionString := Global_DBConnection_String;
      SQL.Text         :=
        'SELECT Number from Users';
      Open;
      Last;
      // Generate Unique Number (AutoNumber in Access)
      lUniqueNumber := 1 + StrToInt(FieldByName('Number').AsString);
      Close;
      // Insert Record into MSAccess DB using SQL
      SQL.Text :=
        'INSERT INTO Users Values (' +
        IntToStr(lUniqueNumber) + ',' +
        QuotedStr(UpperCase(EditTextBox.Text)) + ',' +
        QuotedStr(IntToStr(lUniqueNumber)) + ')';
      ExecSQL;
      Close;
      // This Refreshes the Grid Automatically
      Timer1.Interval := 5000;
      Timer1.Enabled  := True;
    end;
  end;
end;

procedure TfrmMain.BitBtnRefreshClick(Sender: TObject);
begin
  Tusers.Active := False;
  Tusers.Active := True;
end;

procedure TfrmMain.Timer1Timer(Sender: TObject);
begin
  Tusers.Active  := False;
  Tusers.Active  := True;
  Timer1.Enabled := False;
end;

function TfrmMain.GetADOVersion: Double;
var
  ADO: OLEVariant;
begin
  try
    ADO    := CreateOLEObject('adodb.connection');
    Result := StrToFloat(ADO.Version);
    ADO    := Null;
  except
    Result := 0.0;
  end;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  ShowMessage(Format('ADO Version = %n', [GetADOVersion]));
end;

end.

[ikutluay]

Kod: Tümünü seç

{
  As we know, Paradox Tables consist in a table file and some corresponding index files
  there are many way to copy them:
    1. Using TBatchMover (at DataAccess Pallete) with Mode : BatCopy
       But you can't copy the tables corresponding index files, TBatchMove just
       copies the structure and data.
    2. Using FileCopy
       But you can't copy the tables corresponding index files automatically,
       you should define each files
    .. and many more

  The Simple way is:

  Put two TTables on your form, name it as tbSource and tbTarget.
  Then, put this procedure under implementation area
}

type
  TForm1 = class(TForm)
    tbSource: TTable;
    tbTarget: TTable;
    // ...
  end;

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin
  tbSource.TableName := 'Source.DB';  // The name of your tables which you want to copy from
  tbTarget.TableName := 'Target.DB';  // The name of your tables which you will to copy to
                                      // You Can  set the tbSource.DataBaseName to an existing path/Alias
                                      //    where you store your DB
                                      // You Can  set the tbTarget.DataBaseName to an existing path/Alias
                                      //    where you want to store the duplicate DB
  tbSource.StoreDefs := True;
  tbTarget.StoreDefs := True;
  tbSource.FieldDefs.Update;
  tbSource.IndexDefs.Update;
  tbTarget.FieldDefs := tbSource.FieldDefs;
  tbTarget.IndexDefs := tbSource.IndexDefs;
  tbTarget.CreateTable;
  //Actually you can set these code up to only 5 lines :)
end;


End.

[true_false]

ingilizce bilmeyenler (ben dahil) ve topiğin daha hoş görünmesi için keşke kodların altına ne yaptığına dair ufak açıklamalar(türkçe) geçseydiniz daha iyi olurdu kanımca genede teşekkürler.

[ikutluay]

Kod: Tümünü seç

{
 In the "Object Inspector" set your DBGrid's Option for dgMultiSelect = True.
 The Grid_Edit function calls for each selected DBGrid-Row a data-processing
 function.
 Return value is the number of processed rows.

 Im Objektinspektor unter Options des DBGrids die Option "dgMultiSelect"
 auf TRUE setzen.
 Ruft zu jeder markierten DBGrid-Zeile eine Bearbeitungs-Funktion auf
 Rückgabewert = Anzahl bearbeiteter Zeilen
}

function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint;
  // declared in the private section
  // als private deklariert
begin
  Result := 0;
  with dbgIn.DataSource.DataSet do
  begin
    First;
    DisableControls;
    try
      while not EOF do
      begin
        if (dbgIn.SelectedRows.CurrentRowSelected = True) then
        begin
          { +++ Call here the data-processing function +++
          
           +++ HIER DIE BEARBEITUNGS_FKT AUFRUFEN +++
           zb. iValue := qryIn.FieldByName('FELDNAME').AsInteger;
           und so weiter...
          }
          Inc(Result);
        end;
        Next;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Form1.Caption := 'Processed: ' + IntToStr(Grid_Edit(DBGrid1, Query1));
end;

[ikutluay]

Kod: Tümünü seç

type
  ISelfDestroy = interface;
  //forget about GUID, if you are not using COM

  TSelfDestroy = class(TInterfacedObject, ISelfDestroy)
  private
    FObject: TObject;
  public
    constructor Create(AObject: TObject);
    destructor Destroy; override;
  end;


implementation


constructor TSelfDestroy.Create(AObject: TObject);
begin
  FObject := AObject;
end;

destructor TSelfDestroy.Destroy;
begin
  FreeAndNil(FObject);
  inherited;
end;


// So when you use, just do like this...

procedure TForm1.Button1Click(Sender: TObject);
var
  MyObject: TMyObject;
  SelfDestroy: TSelfDestroy;
  begin
  MyObject    := TMyObject.Create;
  SelfDestroy := TSelfDestroy.Create(MyObject);
  // The MyObject will free automatically as soon as TSelfDestroy
  // goes out of scope.
  // Carry on your code here...
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
var 
  iValue: LongInt;
begin
  // color only the first field
  // nur erstes Feld einfärben
  if (DataCol = 0) then
  begin
    // Check the field value and assign a color
    // Feld-Wert prüfen und entsprechende Farbe wählen
    iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
    case iValue of
      1: dbgIn.Canvas.Brush.Color := clGreen;
      2: dbgIn.Canvas.Brush.Color := clLime;
      3: dbgIn.Canvas.Brush.Color := clYellow;
      4: dbgIn.Canvas.Brush.Color := clRed;
    end;
    // Draw the field
    // Feld zeichnen
    dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
  end;
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
  ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;

[ikutluay]

Kod: Tümünü seç

{Unit to export a dataset to XML}

unit DS2XML;

interface

uses
  Classes, DB;

procedure DatasetToXML(Dataset: TDataSet; FileName: string);

implementation

uses
  SysUtils;

var
  SourceBuffer: PChar;

procedure WriteString(Stream: TFileStream; s: string);
begin
  StrPCopy(SourceBuffer, s);
  Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;

procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);

  function XMLFieldType(fld: TField): string;
  begin
    case fld.DataType of
      ftString: Result   := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
      ftSmallint: Result := '"i4"'; //??
      ftInteger: Result  := '"i4"';
      ftWord: Result     := '"i4"'; //??
      ftBoolean: Result  := '"boolean"';
      ftAutoInc: Result  := '"i4" SUBTYPE="Autoinc"';
      ftFloat: Result    := '"r8"';
      ftCurrency: Result := '"r8" SUBTYPE="Money"';
      ftBCD: Result      := '"r8"'; //??
      ftDate: Result     := '"date"';
      ftTime: Result     := '"time"'; //??
      ftDateTime: Result := '"datetime"';
      else
    end;
    if fld.Required then
      Result := Result + ' required="true"';
    if fld.ReadOnly then
      Result := Result + ' readonly="true"';
  end;
var
  i: Integer;
begin
  WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport -->  ' +
    '<DATAPACKET Version="2.0">');
  WriteString(Stream, '<METADATA><FIELDS>');

  {write th metadata}
  with Dataset do
    for i := 0 to FieldCount - 1 do
    begin
      WriteString(Stream, '<FIELD attrname="' +
        Fields[i].FieldName +
        '" fieldtype=' +
        XMLFieldType(Fields[i]) +
        '/>');
    end;
  WriteString(Stream, '</FIELDS>');
  WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
  WriteString(Stream, '</METADATA><ROWDATA>');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
  WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '<ROW');
end;

procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
  if not IsAddedTitle then
    WriteString(Stream, '/>');
end;

procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
  if Assigned(fld) and (AString <> '') then
    WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;

function GetFieldStr(Field: TField): string;

  function GetDig(i, j: Word): string;
  begin
    Result := IntToStr(i);
    while (Length(Result) < j) do
      Result := '0' + Result;
  end;
var 
  Hour, Min, Sec, MSec: Word;
begin
  case Field.DataType of
    ftBoolean: Result := UpperCase(Field.AsString);
    ftDate: Result    := FormatDateTime('yyyymmdd', Field.AsDateTime);
    ftTime: Result    := FormatDateTime('hhnnss', Field.AsDateTime);
    ftDateTime: 
      begin
        Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
        DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
        if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
          Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
            2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
      end;
    else
      Result := Field.AsString;
  end;
end;

procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
  Stream: TFileStream;
  bkmark: TBookmark;
  i: Integer;
begin
  Stream       := TFileStream.Create(FileName, fmCreate);
  SourceBuffer := StrAlloc(1024);
  WriteFileBegin(Stream, Dataset);

  with DataSet do
  begin
    DisableControls;
    bkmark := GetBookmark;
    First;

    {write a title row}
    WriteRowStart(Stream, True);
    for i := 0 to FieldCount - 1 do
      WriteData(Stream, nil, Fields[i].DisplayLabel);
    {write the end of row}
    WriteRowEnd(Stream, True);

    while (not EOF) do
    begin
      WriteRowStart(Stream, False);
      for i := 0 to FieldCount - 1 do
        WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
      {write the end of row}
      WriteRowEnd(Stream, False);

      Next;
    end;

    GotoBookmark(bkmark);
    EnableControls;
  end;

  WriteFileEnd(Stream);
  Stream.Free;
  StrDispose(SourceBuffer);
end;

end.


//Beispiel, Example:


uses DS2XML;

procedure TForm1.Button1Click(Sender: TObject);
  begin  DatasetToXML(Table1, 'test.xml');
  end;

[ikutluay]

Kod: Tümünü seç

How to recover Data in a damaged Header of DbTables.

(Paradox or Dbase) Tables

If this problem occurs and we have not copies of data.

Paradox can't directly open those damaged Tables so
Paradox can't repair those tables.

solution :

T1: the Damaged Table

1- We Have to create an empty Table (T2.Db or
T2.Dbf) that have the same structure of damaged table
(T1.DB or T1.Dbf).

2- With Dos Prompts or excutable batch File we have to
execute this command:

Copy T2.Db+T1.db T3.Db

or

Copy T2.Dbf+T1.dbf T3.Dbf

3-Finally with paradox browser we can open T3 Table
we have to delete bad records.
and copy t3 to t1 table.

[ikutluay]

Kod: Tümünü seç

ype
  THackAccess = class(TCustomGrid);

{
  THackAccess Is needed because TCustomGrid.MoveColumn is
  protected and you can't access it directly.

  THackAccess Braucht man, da TCustomGrid.MoveColumn in der
  Protected-Sektion steht und nicht direkt darauf zugegriffen werden kann.
}

// In the implementation-Section:

procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer);
begin
  THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn);
end;


{Example/ Beispiel}

procedure TForm1.Button1Click(Sender: TObject);
begin
  MoveDBGridColumns(DBGrid1, 1, 2)
end;

[ikutluay]

Kod: Tümünü seç

{ Loading millions of records into a stringlist can be very slow }

procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
  StringList.Clear;
  with SourceTable do
  begin
    Open;
    DisableControls;
    try
      while not EOF do
      begin
        StringList.Add(FieldByName('OriginalData').AsString);
        Next;
      end;
    finally
      EnableControls;
      Close;
    end;
  end;
end;

{ This is much, much faster }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
  with CacheTable do
  begin
    Open;
    try
      StringList.Text := FieldByName('Data').AsString;
    finally
      Close;
    end;
  end;
end;

{ How can this be done?

  In Microsoft SQL Server 7, you can write a stored procedure that updates every night
  a cache table that holds all the data you want in a single column and row.
  In this example, you get the data from a SourceTable and put it all in a Cachetable.
  The CacheTable has one blob column and must have only one row.
  Here it is the SQL code: }


Create Table CacheTable
(Data Text NULL)
GO

Create 

procedure PopulateCacheTable as
  begin
  set NOCOUNT on
  DECLARE @ptrval binary(16), @Value varchar(600) -
  - a good Value for the expected maximum Length
  - - You must set 'select into/bulkcopy' option to True in order to run this sp
  DECLARE @dbname nvarchar(128)
  set @dbname = db_name()
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
- - Declare a cursor
DECLARE scr CURSOR for
SELECT  OriginalData + char(13) + char(10) - - each line in a TStringList is
separated by a #13#10
FROM    SourceTable
- - The CacheTable Table must have only one record
if EXISTS (SELECT * FROM CacheTable)
Update CacheTable set Data = ''
else
Insert CacheTable VALUES('')
- - Get a Pointer to the field we want to Update
SELECT @ptrval = TEXTPTR(Data) FROM CacheTable

Open scr
FETCH Next FROM scr INTO @Value
while @ @FETCH_STATUS = 0
begin - - This UPDATETEXT appends each Value to the 
end 
of the blob field
UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
FETCH Next FROM scr INTO @Value
end
Close scr
DEALLOCATE scr
- - Reset this option to False
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO

{ You may need to increase the BLOB SIZE parameter if you use BDE }

[ikutluay]

ingilizce bilmeyenler (ben dahil) ve topiğin daha hoş görünmesi için keşke kodların altına ne yaptığına dair ufak açıklamalar(türkçe) geçseydiniz daha iyi olurdu kanımca genede teşekkürler.

başlıkları yeterli sanıyorum... ancak takıldığınız bir yer varsa sorun yardımcı olalım.

[ikutluay]

Kod: Tümünü seç

  With different versions of MDAC available it is sometimes
  useful to know that your application won't fail because a user
  hasn't got the latest version installed.
  The following function returns the ADO version installed,
  you need to place ComObj in the uses clause to use this function.
}

function GetADOVersion: Double;
var
  ADO: OLEVariant;
begin
  try
    ADO    := CreateOLEObject('adodb.connection');
    Result := StrToFloat(ADO.Version);
    ADO    := Null;
  except
    Result := 0.0;
  end;
end;

// To use this function try something like:

procedure TForm1.Button1Click(Sender: TObject);
const
  ADOVersionNeeded = 2.5;
begin
  if GetADOVersion then
    ShowMessage('Need to install MDAC version 2.7')
  else
    ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion]));
end;

[ikutluay]

Kod: Tümünü seç

uses
  ComObj;

function OpenConnection(ConnectionString: AnsiString): Integer;
var
  ADODBConnection: OleVariant;
begin
  ADODBConnection := CreateOleObject('ADODB.Connection');
  ADODBConnection.CursorLocation := 3; // User client
  ADODBConnection.ConnectionString := ConnectionString;
  Result          := 0;
  try
    ADODBConnection.Open;
  except
    Result := -1;
  end;
end;

function DataBaseConnection_Test(bMessage: Boolean): AnsiString;
var
  asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;
  iReturn: Integer;
  OldCursor: TCursor;
begin
  OldCursor     := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  asTimeout     := '150';
  asUserName    := 'NT_Server';
  asPassword    := 'SA';
  asDataSource  := 'SQL Server - My DataBase';

  ConnectionString := 'Data Source = ' + asDataSource +
    'User ID = ' + asUserName +
    'Password = ' + asPassword +
    'Mode = Read|Write;Connect Timeout = ' + asTimeout;
  try
    iReturn := OpenConnection(ConnectionString);

    if (bMessage) then
    begin
      if (iReturn = 0) then
        Application.MessageBox('Connection OK!', 'Information', MB_OK)
      else if (iReturn = -1) then
        Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK);
    end;

    if (iReturn = 0) then
      Result := ConnectionString
    else if (iReturn = -1) then
      Result := '';
  finally
    Screen.Cursor := OldCursor;
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  DataBaseConnection_Test(True);
end;