Çeşitli kod ipuçları

[ikutluay]

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOQuery1.SQL.Add('Exec SP_Tables');
  ADOQuery1.Active := True;
end;

[ikutluay]

Kod: Tümünü seç

(*
A common problem when working with DBGrid is, that this component can't display TMemo fields,
multiline columns, Graphics...
There are a few good freeware components around to solve this problem.
The best one is definitly "DBGRIDPLUS", which comes with full sources.
However, this component does not allow to edit the text in memo fields.
The delphi fans out there who bought a delphi version that comes with the VCL sources can
fix this problem:
Open dbgrids.pas and make the following changes:
(To have memo editing in your app you must just add the modifyed version of dbgrids.pas to your uses clause)
*)

function TCustomDBGrid.GetEditLimit: Integer;
begin
  Result := 0;
  if Assigned(SelectedField) and (SelectedField.DataType in [ftString, ftWideString, ftMemo]) then <-- Add
    Result := SelectedField.Size;
end;

function TCustomDBGrid.GetEditText(ACol, ARow: Longint): string;
begin
  Result := '';
  if FDatalink.Active then
  with Columns[RawToDataColumn(ACol)] do
    if Assigned(Field) then
      Result := Field.AsString; <-- Change this.
  FEditText := Result;
end;

(*
Just compare theese edited functions with the original ones, and you will know what to change.
To get multiline cell support (not in memo fields!) for DBGridPlus, send me an email and i can send you the changed DBGridPlus.pas file.
*)

[ikutluay]

Kod: Tümünü seç

// Insert a new Record...
var
  LastID: Integer;
//  Query: TADOQuery;
//  oder
//  Query: TQuery;
begin
  Query.Active := False;
  Query.SQL.Clear;
  Query.SQL.Append('INSERT INTO Table (Spalte) VALUES (Value)');
  Query.ExecSQL;
  LastID := GetLastID(Query);
end;

// get the ID of the last inserted row
function GetLastID(var Query: TADOQuery {or TQuery}): Integer;
begin
  result := -1;
  try
    Query.SQL.clear;
    Query.SQL.Add('SELECT @@IDENTITY');
    Query.Active := True;
    Query.First;
    result := Query.Fields.Fields[0].AsInteger;
  finally
    Query.Active := False;
    Query.SQL.clear;
  end;
end;

[ikutluay]

Kod: Tümünü seç

procedure TLocal.CreateTables(WindowsSecurity: Boolean; Username, Password: String);
var
  ConnectionString: String;
begin
  if WindowsSecurity then
    ConnectionString := 'Provider=SQLOLEDB.1;' +
                        'Integrated Security=SSPI;' +
                        'Persist Security Info=False;' +
                        'Initial Catalog=test'
  else
    ConnectionString := 'Provider=SQLOLEDB.1;' +
                        'Password=' + Password + ';' +
                        'Persist Security Info=True;' +
                        'User ID=' + Username + ';' +
                        'Initial Catalog=test';
  try

    try
      ADOConnection.ConnectionString := ConnectionString;
      ADOConnection.LoginPrompt := False;
      ADOConnection.Connected := True;

      ADOQuery.Connection := ADOConnection;

      ADOQuery.SQL.Clear;
      with ADOQuery.SQL do
      begin
        Add('create table Klijent(');
        Add('JMBG     char(13) not null,');
        Add('Ime      char(30) not null,');
        Add('Adresa   char(30) not null,');
        Add('Telefon  char(15) not null,');
        Add('Primanja numeric(6,2) not null,');
        Add('primary key (JMBG))');
      end;
      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;
      with ADOQuery.SQL do
      begin
        Add('create table Kredit(');
        Add('Sifra    numeric not null,');
        Add('Tip      char(15) unique not null,');
        Add('Kamata   numeric not null,');
        Add('primary key (Sifra))');
      end;
      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;
      with ADOQuery.SQL do
      begin
        Add('create table Operator(');
        Add('JMBG     char(13) unique not null,');
        Add('Ime      char(30) not null,');
        Add('Sifra    char(30) not null,');
        Add('Adresa   char(30) not null,');
        Add('Telefon  char(15) not null,');
        Add('Prioritet smallint not null check (Prioritet>0),');
        Add('primary key (JMBG))');
      end;
      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;
      with ADOQuery.SQL do
      begin
        Add('create table Kreditiranja (');
        Add('Sifra          numeric not null,');
        Add('Sifra_kredita  numeric not null,');
        Add('Datum          datetime,');
        Add('Iznos_kredita  numeric(10,2) check (Iznos_kredita>0),');
        Add('Broj_rata      numeric,');
        Add('JMBG_klijenta  char(13),');
        Add('JMBG_operatora char(13),');
        Add('primary key(Sifra),');
        Add('foreign key(Sifra_kredita) references Kredit(Sifra) on delete cascade on update cascade,');
        Add('foreign key(JMBG_klijenta) references Klijent(JMBG) on delete cascade on update cascade,');
        Add('foreign key(JMBG_operatora) references Operator(JMBG) on delete cascade on update cascade)');
      end;
      ADOQuery.ExecSQL;

      ADOQuery.SQL.Clear;
      with ADOQuery.SQL do
      begin
        Add('create table Rata (');
        Add('Broj_rate    numeric not null,');
        Add('Broj_sifre   numeric not null,');
        Add('Datum        datetime,');
        Add('Iznos_rate   numeric(10,2) check (Iznos_rate>0),');
        Add('primary key (Broj_rate),');
        Add('foreign key (Broj_sifre) references Kreditiranja(Sifra) on delete cascade on update cascade)');
      end;
      ADOQuery.ExecSQL;

      MessageDlg('Tabele su uspjesno kreirane.', mtInformation, [mbOK], 0);
    except
      on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
    end;

  finally
    ADOConnection.Connected := False;
  end;
end;

 

[ikutluay]

Kod: Tümünü seç

{
  Here is a function I have made to compact and repair an access database.
  Exclusive access to the DB is required!!
}

uses
  ComObj;

function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var 
  v: OLEvariant;
begin
  Result := True;
  try
    v := CreateOLEObject('JRO.JetEngine');
    try
      V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB,
                        'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
      DeleteFile(DB);
      RenameFile(DB+'x',DB);
    finally
      V := Unassigned;
    end;
  except
    Result := False;
  end;
end;

[ikutluay]

Kod: Tümünü seç

procedure CreateDatabase(WindowsSecurity: Boolean; Username, Password: String);
var
  ConnectionString: String;
  CommandText: String;
begin
  if WindowsSecurity then
    ConnectionString := 'Provider=SQLOLEDB.1;' +
                        'Integrated Security=SSPI;' +
                        'Persist Security Info=False;' +
                        'Initial Catalog=master'
  else
    ConnectionString := 'Provider=SQLOLEDB.1;' +
                        'Password=' + Password + ';' +
                        'Persist Security Info=True;' +
                        'User ID=' + Username + ';' +
                        'Initial Catalog=master';

  try

    try
      ADOConnection.ConnectionString := ConnectionString;
      ADOConnection.LoginPrompt := False;
      ADOConnection.Connected := True;


      CommandText := 'CREATE DATABASE test ON ' +
                     '( NAME = test_dat,    ' +
                     'FILENAME = ''c:\program files\microsoft sql server\mssql\data\test.mdf'', ' +
                     'SIZE = 4, ' +
                     'MAXSIZE = 10, ' +
                     'FILEGROWTH = 1 )';

      ADOCommand.CommandText := CommandText;
      ADOCommand.Connection := ADOConnection;
      ADOCommand.Execute;
      MessageDlg('Database succesfully created.', mtInformation, [mbOK], 0);

    except
      on E: Exception do MessageDlg(E.Message, mtWarning, [mbOK], 0);
    end;

  finally
    ADOConnection.Connected := False;
    ADOCommand.Connection := nil;
  end;

end;

[ikutluay]

Kod: Tümünü seç

 This unit creates a database on a Interbase-Server at run-time.
 The IBConsole is no longer needed.
 You can execute an SQL script to create tables.
 Try it out!
}

{
 Diese Unit erstellt eine Datenbank auf einem Interbase - Server zur Laufzeit des Programms.
 Es wird nicht mehr die IBConsole gebraucht.
 Dazu kann man im Memo noch ein SQL - Skript ablaufen lassen zum erstellen der Tabellen.
 Probiert es einfach aus.
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ZTransact, ZIbSqlTr, DB, ZQuery, ZIbSqlQuery,
  ZConnect, ZIbSqlCon;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    ZIbSqlQuery1: TZIbSqlQuery;
    ZIbSqlTransact1: TZIbSqlTransact;
    ZIbSqlDatabase1: TZIbSqlDatabase;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);   // Caption/ Beschriftung : Create Database
    procedure Button2Click(Sender: TObject);   // Caption/ Beschriftung : SQL-Anweisung
    procedure Button3Click(Sender: TObject);   // Caption/ Beschriftung : drop data_base
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

// Creating the database
// Hier wird durch drücken des Buttons die Datenbank erstellt
//---------------------------------------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
begin
  ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>';// Path to Database
  ZIbSqlDatabase1.Host := 'testserver';
  ZIbSqlDatabase1.Password := 'masterkey';
  ZIbSqlDatabase1.Login := 'SYSDBA';
  ZIbSqlDatabase1.CreateDatabase('');
end;

// Execute the SQL-Script in the memo
// Hier wird durch drücken des Buttons das SQL-Skript im Memo ausgeführt
//----------------------------------------------------------------------
procedure TForm1.Button2Click(Sender: TObject);
begin
  ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
  ZIbSqlDatabase1.Host := 'testserver';
  ZIbSqlDatabase1.Password := 'masterkey';
  ZIbSqlDatabase1.Login := 'SYSDBA';
  ZIbSqlQuery1.SQL.Clear;
  ZIbSqlQuery1.SQL.AddStrings(memo1.Lines);
  ZIbSqlQuery1.ExecSQL;
end;

// Deleted the database
// Hier wird durch drücken des Buttons die Datenbank komplette gelöscht
//---------------------------------------------------------------------
procedure TForm1.Button3Click(Sender: TObject);
begin
  ZIbSqlDatabase1.Database := '<<Pfad zu Datenbank>>'; // Path to Database
  ZIbSqlDatabase1.Host := 'testserver';
  ZIbSqlDatabase1.Password := 'masterkey';
  ZIbSqlDatabase1.Login := 'SYSDBA';
  ZIbSqlDatabase1.DropDatabase;
end;

end.

[ikutluay]

Kod: Tümünü seç

unit ADOXMLUnit;

interface

uses
  Classes, ADOInt;

function RecordsetToXML(const Recordset: _Recordset): string;
function RecordsetFromXML(const XML: string): _Recordset;

implementation

uses
  ComObj;

{
  Example:
  ...
    Memo1.Lines.Text:=RecordsetToXML(ADOQuery1.Recordset);
  ...
}
function RecordsetToXML(const Recordset: _Recordset): string;
var 
  RS: Variant;
  Stream: TStringStream;
begin
  Result := '';
  if Recordset = nil then Exit;
  Stream := TStringStream.Create('');
  try
    RS := CreateOleObject('ADODB.Recordset');
    RS := Recordset;
    RS.Save(TStreamAdapter.Create(stream) as IUnknown, adPersistXML);
    Stream.Position := 0;
    Result := Stream.DataString;
  finally
    Stream.Free;
  end;
end;

{
  Example:
  ...
    ADOQuery1.Recordset:=RecordsetFromXML(Memo1.Lines.Text);
  ...
}

function RecordsetFromXML(const XML: string): _Recordset;
var 
  RS: Variant;
  Stream: TStringStream;
begin
  Result := nil;
  if XML = '' then Exit;
  try
    Stream := TStringStream.Create(XML);
    Stream.Position := 0;
    RS := CreateOleObject('ADODB.Recordset');
    RS.Open(TStreamAdapter.Create(Stream) as IUnknown);
    Result := IUnknown(RS) as _Recordset;
  finally
    Stream.Free;
  end;
end;

end.

[ikutluay]

Kod: Tümünü seç

{How to stop the dbgrid control from auto-appending a new entry when you move
down after the last record in a table.
It creates a new blank line / record in the table. Can this be stopped?}

{A: Add to your TTables's "BeforeInsert"  event the following line:}

procedure TForm1.Tbable1BeforeInsert(DataSet: TDataSet);
begin
  Abort;  {<<---this line}
end;

{A: It traps the down key and checks for end-of-file.}

procedure TForm8.DBGrid1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_DOWN) then
  begin
    TTable1.DisableControls;
    TTable1Next;
    if TTable1.EOF then
      Key := 0
    else
      TTable1.Prior;
    TTable1.EnableControls;
  end;
end;

[ikutluay]

Kod: Tümünü seç

function TForm1.GetSQLDateTimeFormat(UDL: string): string;
begin
  Screen.Cursor := crSQLWait;
  if ADOConnection1.Connected then ADOConnection1.Close;
  ADOConnection1.ConnectionString := 'FILE NAME=' + UDL;
  ADOQuery1.SQL.Clear;
  ADOQuery1.SQL.Add('sp_helplanguage @@LANGUAGE');
  Application.ProcessMessages;
  try
    try
      ADOQuery1.Open;
    except
      on E: Exception do MessageBox(Handle,
          PChar('Die Abfrage konnte nicht geöffnet werden:' + #13#10 + #13#10 + E.Message),
          PChar('Fehler!'), 16);
    end;
    if (ADOQuery1.Active) and (ADOQuery1.RecordCount > 0) then
      Result := ADOQuery1.FieldByName('dateformat').AsString;
  finally
    Screen.Cursor := crDefault;
  end;
end;



function DateTimeToSQLDateTimeString(Data: TDateTime; Format: string;
  OnlyDate: Boolean = True): string;
var
  y, m, d, h, mm, s, ms: Word;
begin
  DecodeDate(Data, y, m, d);
  DecodeTime(Data, h, mm, s, ms);
  if Format = 'dmy' then
    Result := IntToStr(d) + '-' + IntToStr(m) + '-' + IntToStr(y)
  else if Format = 'ymd' then
    Result := IntToStr(y) + '-' + IntToStr(m) + '-' + IntToStr(d)
  else if Format = 'ydm' then
    Result := IntToStr(y) + '-' + IntToStr(d) + '-' + IntToStr(m)
  else if Format = 'myd' then
    Result := IntToStr(m) + '-' + IntToStr(y) + '-' + IntToStr(d)
  else if Format = 'dym' then
    Result := IntToStr(d) + '-' + IntToStr(y) + '-' + IntToStr(m)
  else
    Result := IntToStr(m) + '-' + IntToStr(d) + '-' + IntToStr(y); //mdy: ; //US
  if not OnlyDate then
    Result := Result + ' ' + IntToStr(h) + ':' + IntToStr(mm) + ':' + IntToStr(s);
end;



//Example:
//Beispiel:

procedure ConvertSQLDateTime;
begin
  ShowMessage(DateTimeToSQLDateTimeString(now, GetSQLLanguage('C:\DBEngl.udl')));
end;

[ikutluay]

Kod: Tümünü seç

{
Exporting ADO tables into various formats

In this article I want to present a component I built in order to
supply exporting features to the ADOTable component. ADO supplies
an extended SQL syntax that allows exporting of data into various 
formats. I took into consideration the following formats:

1)Excel
2)Html
3)Paradox
4)Dbase
5)Text

You can see all supported output formats in the registry:
"HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\ISAM formats"

This is the complete source of my component }

unit ExportADOTable;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, ADODB;

type
  TExportADOTable = class(TADOTable)
  private
    { Private declarations }
    //TADOCommand component used to execute the SQL exporting commands
    FADOCommand: TADOCommand;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;

    //Export procedures
    //"FiledNames" is a comma separated list of the names of the fields you want to export
    //"FileName" is the name of the output file (including the complete path)
    //if the dataset is filtered (Filtered = true and Filter <> ''), then I append 
    //the filter string to the sql command in the "where" directive
    //if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the 
    //"order by" directive
   
    procedure ExportToExcel(FieldNames: string; FileName: string;
      SheetName: string; IsamFormat: string);
    procedure ExportToHtml(FieldNames: string; FileName: string);
    procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string);
    procedure ExportToTxt(FieldNames: string; FileName: string);
  published
    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Carlo Pasolini', [TExportADOTable]);
end;

constructor TExportADOTable.Create(AOwner: TComponent);
begin
  inherited;

  FADOCommand := TADOCommand.Create(Self);
end;


procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string;
  SheetName: string; IsamFormat: string);
begin
  {IsamFormat values
   Excel 3.0
   Excel 4.0
   Excel 5.0
   Excel 8.0
  }

  if not Active then
    Exit;
  FADOCommand.Connection  := Connection;  
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string);
var
  IsamFormat: string;
begin
  if not Active then
    Exit;

  IsamFormat := 'HTML Export';

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;


procedure TExportADOTable.ExportToParadox(FieldNames: string;
  FileName: string; IsamFormat: string);
begin
  {IsamFormat values
  Paradox 3.X
  Paradox 4.X
  Paradox 5.X
  Paradox 7.X
  }
  if not Active then
    Exit;

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string;
  IsamFormat: string);
begin
  {IsamFormat values
  dBase III
  dBase IV
  dBase 5.0
  }
  if not Active then
    Exit;

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string);
var
  IsamFormat: string;
begin
  if not Active then
    Exit;

  IsamFormat := 'Text';

  FADOCommand.Connection  := Connection;
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' +
    ExtractFileName(FileName) + ']' + 
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat +
    ';]' + ' From ' + TableName;
  if Filtered and (Filter <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter;
  if (Sort <> '') then
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort;
  FADOCommand.Execute;
end;

end.

{
Note that you can use an already existing database as destination but not an already existing
table in the database itself: if you specify an already exixting table you will receive
an error message. You might insert a verification code inside every exporting procedure of my
component, before the execution of the sql exporting command, in order to send a request of  
deleting the already present table or aborting the exporting process.

carlo Pasolini, Riccione(italy), e-mail: ccpasolini@libero.it
}

[ikutluay]

Kod: Tümünü seç

unit dbTables;

interface

uses ADODb;

type
  TTableType = (ttTable, ttView, ttSynonym, ttSystemTable, ttAccessTable);

type
  TTableTypes = set of TTableType;

type
  TTableItem = record
    ItemName: string;
    ItemType: string;
  end;

type
  TTableItems = array of TTableItem;

function addFilter(string1, string2: string): string;
function ADODbTables(ADOConnection: TADOConnection; types: TTableTypes): TTableItems;

implementation

function addFilter(string1, string2: string): string;
begin
  if string1 <> '' then
    Result := string1 + ' or ' + string2
  else
    Result := string2;
end;

function ADODbTables(ADOConnection: TADOConnection; types: TTableTypes): TTableItems;
var
  ADODataSet: TADODataSet;
  i: integer;
begin
  ADODataSet := TADODataSet.Create(nil);
  ADODataSet.Connection := ADOConnection;
  ADOConnection.OpenSchema(siTables, EmptyParam, EmptyParam, ADODataSet);

  if (ttTable in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''TABLE'')');

  if (ttView in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''VIEW'')');

  if (ttSynonym in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''SYNONYM'')');

  if (ttSystemTable in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''SYSTEM TABLE'')');

  if (ttAccessTable in types) then
    ADODataSet.Filter := addFilter(ADODataSet.Filter, '(TABLE_TYPE = ''ACCESS TABLE'')');

  ADODataSet.Filtered := True;

  SetLength(Result, ADODataSet.RecordCount);

  i := 0;
  with ADODataSet do
  begin
    First;
    while not EOF do
    begin
      with Result[i] do
      begin
        ItemName := FieldByName('TABLE_NAME').AsString;
        ItemType := FieldByName('TABLE_TYPE').AsString;
      end;
      Inc(i);
      Next;
    end;
  end;

  ADODataSet.Free;
end;

end.

{
Example: create a new project and add a TADOConnection (ADOConnection1),
a TButton (Button1) and a TMemo (Memo1); assign a ConnectionString to the
TADOConnection component and set "ADOConnection1.Active := True"
}

procedure TForm1.Button1Click(Sender: TObject);
var
  output: ttableitems;
  i: integer;
begin
  output := ADODbTables(ADOConnection1, [ttTable, ttView, ttSynonym]);
  //  output := ADODbTables(ADOConnection1, [ttSystemTable, ttAccessTable]);
  for i := Low(output) to High(output) do
  begin
    Memo1.Lines.Add(output[i].ItemName + '---' + output[i].ItemType);
  end;
  output := nil;
end;

[ikutluay]

Kod: Tümünü seç

{
  Exporting a DBGrid to excel without OLE

  I develop software and about 95% of my work deals with databases.
  I enjoied the advantages of using Microsoft Excel in my projects
  in order to make reports but recently I decided to convert myself
  to the free OpenOffice suite.
  I faced with the problem of exporting data to Excel without having
  Office installed on my computer.
  The first solution was to create directly an Excel format compatible file:
  this solution is about 50 times faster than the OLE solution but there
  is a problem: the output file is not compatible with OpenOffice.
  I wanted a solution which was compatible with each "DataSet";
  at the same time I wanted to export only the dataset data present in
  a DBGrid and not all the "DataSet".
  Finally I obtained this solution which satisfied my requirements.
  I hope that it will be usefull for you too.

  First of all you must import the ADOX type library
  which will be used to create the Excel file and its
  internal structure: in the Delphi IDE:

  1)Project->Import Type Library:
  2)Select "Microsoft ADO Ext. for DDL and Security"
  3)Uncheck "Generate component wrapper" at the bottom
  4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in
    (TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog)
    in order to avoid conflicts with the already present TTable component.
  5)Select the Unit dir name and press "Create Unit".
    It will be created a file named AOX_TLB.
    Include ADOX_TLB in the "uses" directive inside the file in which you want
    to use ADOX functionality.

  That is all. Let's go now with the implementation:
}

unit DBGridExportToExcel;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB;


type TScrollEvents = class
       BeforeScroll_Event: TDataSetNotifyEvent;
       AfterScroll_Event: TDataSetNotifyEvent;
       AutoCalcFields_Property: Boolean;
  end;

procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);


implementation

//Support procedures: I made that in order to increase speed in
//the process of scanning large amounts
//of records in a dataset

//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and
//"AfterScroll" events and the "AutoCalcFields" property.
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
begin
     with DataSet do
          begin
               DisableControls;
               ScrollEvents := TScrollEvents.Create();
               with ScrollEvents do
                    begin
                         BeforeScroll_Event := BeforeScroll;
                         AfterScroll_Event := AfterScroll;
                         AutoCalcFields_Property := AutoCalcFields;
                         BeforeScroll := nil;
                         AfterScroll := nil;
                         AutoCalcFields := False;
                    end;
          end;
end;

//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
     with DataSet do
          begin
               EnableControls;
               with ScrollEvents do
                    begin
                         BeforeScroll := BeforeScroll_Event;
                         AfterScroll := AfterScroll_Event;
                         AutoCalcFields := AutoCalcFields_Property;
                    end;
          end;
end;

//This is the procedure which make the work:

procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string);
var
  cat: _Catalog;
  tbl: _Table;
  col: _Column;
  i: integer;
  ADOConnection: TADOConnection;
  ADOQuery: TADOQuery;
  ScrollEvents: TScrollEvents;
  SavePlace: TBookmark;
begin
  //
  //WorkBook creation (database)
  cat := CoCatalog.Create;
  cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0');
  //WorkSheet creation (table)
  tbl := CoTable.Create;
  tbl.Set_Name(SheetName);
  //Columns creation (fields)
  DBGrid.DataSource.DataSet.First;
  with DBGrid.Columns do
    begin
      for i := 0 to Count - 1 do
        if Items[i].Visible then
        begin
          col := nil;
          col := CoColumn.Create;
          with col do
            begin
              Set_Name(Items[i].Title.Caption);
              Set_Type_(adVarWChar);
            end;
          //add column to table
          tbl.Columns.Append(col, adVarWChar, 20);
        end;
    end;
  //add table to database
  cat.Tables.Append(tbl);

  col := nil;
  tbl := nil;
  cat := nil;

  //exporting
  ADOConnection := TADOConnection.Create(nil);
  ADOConnection.LoginPrompt := False;
  ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0';
  ADOQuery := TADOQuery.Create(nil);
  ADOQuery.Connection := ADOConnection;
  ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]';
  ADOQuery.Open;


  DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);
  SavePlace := DBGrid.DataSource.DataSet.GetBookmark;
  try
  with DBGrid.DataSource.DataSet do
    begin
      First;
      while not Eof do
        begin
          ADOQuery.Append;
          with DBGrid.Columns do
            begin
              ADOQuery.Edit;
              for i := 0 to Count - 1 do
                if Items[i].Visible then
                  begin
                    ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString;
                  end;
              ADOQuery.Post;
            end;
          Next;
        end;
    end;

  finally
  DBGrid.DataSource.DataSet.GotoBookmark(SavePlace);
  DBGrid.DataSource.DataSet.FreeBookmark(SavePlace);
  EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents);

  ADOQuery.Close;
  ADOConnection.Close;

  ADOQuery.Free;
  ADOConnection.Free;

  end;

end;

end.

[ikutluay]

Kod: Tümünü seç

{The following function can be added to your to your unit and called as follows:}

Locate(Table1, Table1LName, 'Beman');

{Table1 is your table component, Table1LName is TField you've add with the fields
editor (double click on the table component) and 'Beman' is the name you want to find.}

{Locate will find SValue in a non-indexed table}

function Locate(const oTable: TTable; const oField: TField;
  const sValue: string): Boolean;
var

  bmPos: TBookMark;
  bFound: Boolean;
begin
  Locate := False;
  bFound := False;
  if not oTable.Active then Exit;
  if oTable.FieldDefs.IndexOf(oField.FieldName) < 0 then Exit;
  bmPos := oTable.GetBookMark;
  with oTable do
  begin
    DisableControls;
    First;
    while not EOF do
      if oField.AsString = sValue then
      begin
        Locate := True;
        bFound := True;
        Break;
      end
    else
      Next;
  end;
  if (not bFound) then
    oTable.GotoBookMark(bmPos);
  oTable.FreeBookMark(bmPos);
  oTable.EnableControls;
end;

[ikutluay]

Kod: Tümünü seç

  Information that describes the conditions of a database engine error can
  be obtained for use by an application through the use of an EDBEngineError
  exception. EDBEngineError exceptions are handled in an application through
  the use of a try..except construct. When an EDBEngineError exception
  occurs, a EDBEngineError object would be created and various fields in that
  EDBEngineError object would be used to programmatically determine what
  went wrong and thus what needs to be done to correct the situation. Also,
  more than one error message may be generated for a given exception. This
  requires iterating through the multiple error messages to get needed infor-
  mation.
}

{The fields that are most pertinent to this context are:}

{  ErrorCount: type Integer; indicates the number of errors that are in
     the Errors property; counting begins at zero.

   Errors: type TDBError; a set of record-like structures that contain
     information about each specific error generated; each record is
     accessed via an index number of type Integer.

   Errors.ErrorCode: type DBIResult; indicating the BDE error code for the
     error in the current Errors record.

   Errors.Category: type Byte; category of the error referenced by the
     ErrorCode field.

   Errors.SubCode: type Byte; subcode for the value of ErrorCode.

   Errors.NativeError: type LongInt; remote error code returned from the
     server; if zero, the error is not a server error; SQL statement
     return codes appear in this field.

   Errors.Message: type TMessageStr; if the error is a server error, the
     server message for the error in the current Errors record; if not a
     server error, a BDE error message.}

{
  In a try..except construct, the EDBEngineError object is created directly
  in the except section of the construct. Once created, fields may be
  accessed normally, or the object may be passed to another procedure for
  inspection of the errors. Passing the EDBEngineError object to a special-
  ized procedure is preferred for an application to make the process more
  modular, reducing the amount of repeated code for parsing the object for
  error information. Alternately, a custom component could be created to
  serve this purpose, providing a set of functionality that is easily trans-
  ported across applications. The example below only demonstrates creating
  the DBEngineError object, passing it to a procedure, and parsing the
  object to extract error information.
}

{
  In a try..except construct, the DBEngineError can be created with syntax
  such as that below:
}

procedure TForm1.Button1Click(Sender: TObject);
var
  i: Integer;
begin
  if Edit1.Text > ' ' then 
  begin
    Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text);
    try
      Table1.Post;
    except 
      on E: EDBEngineError do
        ShowError(E);
    end;
  end;
end;

{
  In this procedure, an attempt is made to change the value of a field in a
  table and then call the Post method of the corresponding TTable component.
  Only the attempt to post the change is being trapped in the try..except
  construct. If an EDBEngineError occurs, the except section of the con-
  struct is executed, which creates the EDBEngineError object (E) and then
  passes it to the procedure ShowError. Note that only an EDBEngineError
  exception is being accounted for in this construct. In a real-world sit-
  uation, this would likely be accompanied by checking for other types of
  exceptions.

  The procedure ShowError takes the EDBEngineError, passed as a parameter,
  and queries the object for contained errors. In this example, information
  about the errors are displayed in a TMemo component. Alternately, the
  extracted values may never be displayed, but instead used as the basis for
  logic branching so the application can react to the errors. The first step
  in doing this is to establish the number of errors that actually occurred.
  This is the purpose of the ErrorCount property. This property supplies a
  value of type Integer that may be used to build a for loop to iterate
  through the errors contained in the object. Once the number of errors
  actually contained in the object is known, a loop can be used to visit
  each existing error (each represented by an Errors property record) and
  extract information about each error to be inserted into the TMemo comp-
  onent.
}

procedure TForm1.ShowError(AExc: EDBEngineError);
var
  i: Integer;
begin
  Memo1.Lines.Clear;
  Memo1.Lines.Add('Number of errors: ' + IntToStr(AExc.ErrorCount));
  Memo1.Lines.Add('');
  {Iterate through the Errors records}
  for i := 0 to AExc.ErrorCount - 1 do 
  begin
    Memo1.Lines.Add('Message: ' + AExc.Errors[i].Message);
    Memo1.Lines.Add('   Category: ' +
      IntToStr(AExc.Errors[i].Category));
    Memo1.Lines.Add('   Error Code: ' +
      IntToStr(AExc.Errors[i].ErrorCode));
    Memo1.Lines.Add('   SubCode: ' +
      IntToStr(AExc.Errors[i].SubCode));
    Memo1.Lines.Add('   Native Error: ' +
      IntToStr(AExc.Errors[i].NativeError));
    Memo1.Lines.Add('');
  end;
end;