neoturk: ...Edit an inplace tmemo inside a tdbgrid ?...
(*
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.
*)
Delphi - .....................................
neoturk: ...Multi select rows in a dbgrid using shift [select as in the ie] ?...
property BM1: TBookmark read FBM1 Write SetBM1;
property BM2: TBookmark read FBM2 Write SetBM2;
procedure Markieren(Sender: TObject);
function Shiftgedr: Boolean;
procedure TForm1.Markieren(Sender: TObject);
var
Richtung: string;
TempBM: TBookmark;
begin
with (Sender as TDBGRID).DataSource.Dataset do
begin
if (BOF and EOF) then
Exit;
DisableControls;
try
try
GotoBookmark(BM1);
case DBGrid1.DataSource.DataSet.CompareBookmarks(BM1, BM2) of
-1: Richtung := 'Unten';
1: Richtung := 'Oben';
0: Richtung := 'Gleich';
end;
TempBM := DBGrid1.DataSource.DataSet.GetBookmark;
while DBGrid1.DataSource.DataSet.CompareBookmarks(BM2, TempBM) <> 0 do
begin
DBGrid1.SelectedRows.CurrentRowSelected := True;
if Richtung = 'Unten' then
Next
else
Prior;
TempBM := DBGrid1.DataSource.DataSet.GetBookmark;
end;
finally
FreeBookmark(tempbm);
end;
finally
EnableControls;
end;
end;
end;
function TForm1.Shiftgedr: Boolean;
var
State: TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[VK_SHIFT] and 128) <> 0);
end;
//Im "OnMouseUP" des Grids folgenden Code einbauen
begin
if not Shiftgedr then
Merke1 := nil;
if Merke1 = nil then
Merke1 := DBGrid1.DataSource.DataSet.GetBookmark
else
Merke2 := DBGrid1.DataSource.DataSet.GetBookmark;
if (Merke1 <> nil) and (Merke2 <> nil) then
begin
if Shiftgedr then
begin
Markieren(Sender);
end;
end;
end;
Delphi - .....................................
neoturk: ...Multi select rows in a dbgrid using shift [select as in the ie] ?...
property BM1: TBookmark read FBM1 Write SetBM1;
property BM2: TBookmark read FBM2 Write SetBM2;
procedure Markieren(Sender: TObject);
function Shiftgedr: Boolean;
procedure TForm1.Markieren(Sender: TObject);
var
Richtung: string;
TempBM: TBookmark;
begin
with (Sender as TDBGRID).DataSource.Dataset do
begin
if (BOF and EOF) then
Exit;
DisableControls;
try
try
GotoBookmark(BM1);
case DBGrid1.DataSource.DataSet.CompareBookmarks(BM1, BM2) of
-1: Richtung := 'Unten';
1: Richtung := 'Oben';
0: Richtung := 'Gleich';
end;
TempBM := DBGrid1.DataSource.DataSet.GetBookmark;
while DBGrid1.DataSource.DataSet.CompareBookmarks(BM2, TempBM) <> 0 do
begin
DBGrid1.SelectedRows.CurrentRowSelected := True;
if Richtung = 'Unten' then
Next
else
Prior;
TempBM := DBGrid1.DataSource.DataSet.GetBookmark;
end;
finally
FreeBookmark(tempbm);
end;
finally
EnableControls;
end;
end;
end;
function TForm1.Shiftgedr: Boolean;
var
State: TKeyboardState;
begin
GetKeyboardState(State);
Result := ((State[VK_SHIFT] and 128) <> 0);
end;
//Im "OnMouseUP" des Grids folgenden Code einbauen
begin
if not Shiftgedr then
Merke1 := nil;
if Merke1 = nil then
Merke1 := DBGrid1.DataSource.DataSet.GetBookmark
else
Merke2 := DBGrid1.DataSource.DataSet.GetBookmark;
if (Merke1 <> nil) and (Merke2 <> nil) then
begin
if Shiftgedr then
begin
Markieren(Sender);
end;
end;
end;
Delphi - .....................................
neoturk: ...Load a jpeg file into a blob field using sql ?...
procedure TForm1.Button1Click(Sender: TObject);
var
ms: TMemoryStream;
begin
if OpenPictureDialog1.Execute then
begin
ms := TMemoryStream.Create;
try
ms.LoadFromFile(OpenPictureDialog1.FileName);
with Query1 do
begin
with SQL do
begin
Clear;
Add('INSERT INTO "ImageTbl.db" (ImageFld)');
Add('VALUES (:param0 )');
end;
Query1.ParamByName('param0').SetBlobData(ms.Memory, ms.Size);
ExecSQL;
end;
finally
ms.Free;
end;
end;
end;
Delphi - .....................................
neoturk: ...Load a jpeg file into a blob field using sql ?...
procedure TForm1.Button1Click(Sender: TObject);
var
ms: TMemoryStream;
begin
if OpenPictureDialog1.Execute then
begin
ms := TMemoryStream.Create;
try
ms.LoadFromFile(OpenPictureDialog1.FileName);
with Query1 do
begin
with SQL do
begin
Clear;
Add('INSERT INTO "ImageTbl.db" (ImageFld)');
Add('VALUES (:param0 )');
end;
Query1.ParamByName('param0').SetBlobData(ms.Memory, ms.Size);
ExecSQL;
end;
finally
ms.Free;
end;
end;
end;
Delphi - .....................................
neoturk: ...Convert a query into a table ?...
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms,
Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Button1: TButton;
Query1: TQuery;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
InitQuery: TQuery;
InitTable: TTable;
InitBatch: TBatchMove;
begin
InitQuery := TQuery.Create(Application);
with InitQuery do
begin
DatabaseName := 'DBDEMOS';
Close;
SQL.Clear;
SQL.Add('SELECT * ');
SQL.Add('FROM customer.db');
SQL.Add('WHERE Country="US"');
SQL.SaveToFile('mgrInit.sql');
try
Open;
try // Send the SQL result to c:tempINIT.DB
InitTable := TTable.Create(Application);
with InitTable do
begin
DatabaseName := 'c:temp';
TableName := 'INIT';
end;
InitBatch := TBatchMove.Create(Application);
with InitBatch do
begin
Destination := InitTable;
Source := InitQuery;
Mode := batCopy;
Execute;
end;
finally
InitTable.Free;
InitBatch.Free;
end;
except
Free;
Abort;
end;
Free;
end;
end;
end.
Delphi - .....................................
neoturk: ...Convert a query into a table ?...
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms,
Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Button1: TButton;
Query1: TQuery;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
InitQuery: TQuery;
InitTable: TTable;
InitBatch: TBatchMove;
begin
InitQuery := TQuery.Create(Application);
with InitQuery do
begin
DatabaseName := 'DBDEMOS';
Close;
SQL.Clear;
SQL.Add('SELECT * ');
SQL.Add('FROM customer.db');
SQL.Add('WHERE Country="US"');
SQL.SaveToFile('mgrInit.sql');
try
Open;
try // Send the SQL result to c:tempINIT.DB
InitTable := TTable.Create(Application);
with InitTable do
begin
DatabaseName := 'c:temp';
TableName := 'INIT';
end;
InitBatch := TBatchMove.Create(Application);
with InitBatch do
begin
Destination := InitTable;
Source := InitQuery;
Mode := batCopy;
Execute;
end;
finally
InitTable.Free;
InitBatch.Free;
end;
except
Free;
Abort;
end;
Free;
end;
end;
end.
Delphi - .....................................
neoturk: ...Create tables detial-master in sql server 2000 with code ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Create Table MasterTable ' +
'(FieldName Primary Key);';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Create Table Detailtable ' +
'(Fieldname Primary Key Refrenced Mastertable(Fieldname));';
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Create tables detial-master in sql server 2000 with code ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Create Table MasterTable ' +
'(FieldName Primary Key);';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Create Table Detailtable ' +
'(Fieldname Primary Key Refrenced Mastertable(Fieldname));';
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Get list of tables in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_Tables');
ADOQuery1.Active := True;
end;
Delphi - .....................................
neoturk: ...Get list of tables in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_Tables');
ADOQuery1.Active := True;
end;
Delphi - .....................................
neoturk: ...Get list of database in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_DATABASES');
ADOQuery1.Active := True;
end;
Delphi - .....................................
neoturk: ...Get list of database in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_DATABASES');
ADOQuery1.Active := True;
end;
Delphi - .....................................
neoturk: ...Get list of active users in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_WHO');
ADOQuery1.Active := True;
end;
Delphi - .....................................
neoturk: ...Get list of active users in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOQuery1.SQL.Add('Exec SP_WHO');
ADOQuery1.Active := True;
end;
Delphi - .....................................
neoturk: ...Delete a user from adatabase in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_DropUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Delete a user from adatabase in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_DropUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Add a user into a database in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Add a user into a database in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Delete a user's login in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Exec SP_DropLogin ' + QuotedStr('UserName');
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Delete a user's login in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Exec SP_DropLogin ' + QuotedStr('UserName');
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Connect to sql server 2000 ?...
begin
ADOConnection1.ConnectionString := 'Server=Hostname;DataBase=DatabaseName';
ADOConnection1.Open('UserName', 'Password');
ADOConnection1.Connected := True;
end;
Delphi - .....................................
neoturk: ...Connect to sql server 2000 ?...
begin
ADOConnection1.ConnectionString := 'Server=Hostname;DataBase=DatabaseName';
ADOConnection1.Open('UserName', 'Password');
ADOConnection1.Connected := True;
end;
Delphi - .....................................
neoturk: ...Add a user's login in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOConnection1.Connected := True;
ADOCommand1.CommandText := 'Exec SP_AddLogin ' + QuotedStr('UserName') +
',' + QuotedStr('Password') + ',' + QuotedStr('Database Name') + ',' +
QuotedStr('English') + ';';
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Add a user's login in sql server 2000 ?...
procedure TForm1.Button1Click(Sender: TObject);
begin
ADOConnection1.Connected := True;
ADOCommand1.CommandText := 'Exec SP_AddLogin ' + QuotedStr('UserName') +
',' + QuotedStr('Password') + ',' + QuotedStr('Database Name') + ',' +
QuotedStr('English') + ';';
ADOCommand1.Execute;
end;
Delphi - .....................................
neoturk: ...Adapt datetime values for sql-server or access formats ?...
{---------------------------------------------------------------------
Dieser Tip ist als Verbesserung zum ursprünglichen Artikel
http://www.swissdelphicenter.ch/de/showcode.php?id=1423
gedacht.
Die folgende Funktionen wandeln einen DateTime Wert
(unabhängig vom eingestelltem Datumsformat) in einen
für den SQL-Server verständlichen String um.
----------------------------------------------------------------------
Please also take a look at the initial tip:
http://www.swissdelphicenter.ch/de/showcode.php?id=1423
the following functions converts a datatime value
(independant of the dateformat) to a string that
is readably by the SQL Server
---------------------------------------------------------------------}
function DateTimeToSQLServerDateTimeString(Value: TDateTime): string;
begin
Result := '{ ts' + QuotedStr(FormatDateTime('yyyy-mm-dd hh":"nn":"ss.z', Value)) + ' }';
end;
function DateTimeToSQLServerDateString(Value: TDateTime): string;
begin
Result := '{ d' + QuotedStr(FormatDateTime('yyyy-mm-dd', Value)) + ' }';
end;
function DateTimeToSQLServerTimeString(Value: TDateTime): string;
begin
Result := '{ t' + QuotedStr(FormatDateTime('hh":"nn":"ss.z', Value)) + ' }';
end;
{
dito für die Jet-Engine (Access-Datenbank)
also for the Jet-Engine (Access database)
}
function DateTimeToAccessDateTimeString(Value: TDateTime): string;
function FloatToStrEx(const Value: Extended; const DecSep: Char): string;
var
OldSep: Char;
begin
OldSep := DecimalSeparator;
try
DecimalSeparator := DecSep;
Result := FloatToStr(Value);
finally
DecimalSeparator := OldSep;
end;
end;
begin
// Da Access (Jet-Engine) ein Datum als Double speichert...
// because Access (Jet-Engine) stores a date as a double...
Result := FloatToStrEx(Value, '.');
end;
Delphi - .....................................
neoturk: ...Adapt datetime values for sql-server or access formats ?...
{---------------------------------------------------------------------
Dieser Tip ist als Verbesserung zum ursprünglichen Artikel
http://www.swissdelphicenter.ch/de/showcode.php?id=1423
gedacht.
Die folgende Funktionen wandeln einen DateTime Wert
(unabhängig vom eingestelltem Datumsformat) in einen
für den SQL-Server verständlichen String um.
----------------------------------------------------------------------
Please also take a look at the initial tip:
http://www.swissdelphicenter.ch/de/showcode.php?id=1423
the following functions converts a datatime value
(independant of the dateformat) to a string that
is readably by the SQL Server
---------------------------------------------------------------------}
function DateTimeToSQLServerDateTimeString(Value: TDateTime): string;
begin
Result := '{ ts' + QuotedStr(FormatDateTime('yyyy-mm-dd hh":"nn":"ss.z', Value)) + ' }';
end;
function DateTimeToSQLServerDateString(Value: TDateTime): string;
begin
Result := '{ d' + QuotedStr(FormatDateTime('yyyy-mm-dd', Value)) + ' }';
end;
function DateTimeToSQLServerTimeString(Value: TDateTime): string;
begin
Result := '{ t' + QuotedStr(FormatDateTime('hh":"nn":"ss.z', Value)) + ' }';
end;
{
dito für die Jet-Engine (Access-Datenbank)
also for the Jet-Engine (Access database)
}
function DateTimeToAccessDateTimeString(Value: TDateTime): string;
function FloatToStrEx(const Value: Extended; const DecSep: Char): string;
var
OldSep: Char;
begin
OldSep := DecimalSeparator;
try
DecimalSeparator := DecSep;
Result := FloatToStr(Value);
finally
DecimalSeparator := OldSep;
end;
end;
begin
// Da Access (Jet-Engine) ein Datum als Double speichert...
// because Access (Jet-Engine) stores a date as a double...
Result := FloatToStrEx(Value, '.');
end;
Delphi - .....................................
neoturk: ...Talk to a msaccess database thru dot net ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A working Delphi for Dot Net example that talks to an MSAccess
database and displays one result. This code should properly
demonstrate the use of Dot Net Components to retreive Data from
MS Access. Other examples I've seen are Internet based and do not
function correctly.
Any Comments to : Andychap@hotmail.com
Please put DOT NET in the subject so I can
Junk filter.
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
//--------------------------------------------------------------------
// Main program refers to the unit below. Make sure of the
// program paths!!!!!
//--------------------------------------------------------------------
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// Simple Access Database demonstration
//
// Written by Andy Chapman (AndyChap@hotmail.com)
// Copyright (C) ACMIS Software , 2003
//
// For all you Delphi lovers here's a complete example of reading
// an MSAccess database useing Dot Net notation. Most of the examples
// found on the net refered to internet and IIS applications but this
// one runs as a true dot net implementation. With thanks to all the
// articles posted on the net... you know who you are.
//
// Program DBTest uses Newform2 as its inclusion. This form is where
// all the work is done. Please pass comment to the EMail address above
// and mark in the Subject Line DOT NET or my mail filter will kill it
//
// Regards : Andrew Chapman
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
program DBTest;
uses
System.Windows.Forms,
Newform2 in 'c:tempnetNewform2.pas' {Form1};
begin
Mainform := TForm1.Create;
Application.Run(Mainform);
end.
//--------------------------------------------------------------------
// Unit refered to by the main program. Make sure your database
// path is set correctly
//--------------------------------------------------------------------
unit NewForm2;
interface
uses
{ Just like the old uses clause in a delphi program. The SYSTEM namespace refers to windows
type controls and not specifically the delphi ones. To draw a delphi button call on the
BORLAND.VCL name spaces... see below }
System.Reflection,
System.Drawing,
System.Drawing.Text,
System.ComponentModel,
System.Windows.Forms,
System.Data.OleDB,
System.Data,
System.Data.Common,
System.Runtime.InteropServices;
type
TForm1 = class(Form)
private
buttonload: system.windows.forms.button; // a button
Components: system.componentmodel.container; // a component store
datagrid1: system.windows.forms.datagrid; // not used in this implementation
public
constructor Create; // which I will inherite and amend
procedure InitializeComponents; // easy way to centralise component creation
procedure Button1_Click(Sender: TObject; E: EventArgs); // on click event
end;
var
MainForm: TForm1; // as ever a main delphi form
implementation
constructor TForm1.Create;
begin
inherited Create; // normal create stuff then set up all the required components
InitializeComponents; // sets up components
end;
procedure TForm1.InitializeComponents;
var
MyControls: array[0..2] of control; // container class for main form
begin
Self.ClientSize := system.Drawing.Size.Create(600,413); // client window on screen
Self.Components := System.ComponentModel.Container.Create();
// container class for the other bits
Self.buttonload := system.windows.forms.button.Create(); // make a button
Self.buttonload.add_click(button1_click); // set its on click event
Self.buttonload.Size := system.drawing.Size.Create(112,32); // size up the button
Self.buttonload.location := system.drawing.point.Create(480,352); // where on screen ?
Self.buttonload.Text := 'Read the database';
// text on the button - 'caption' in real delphi
Self.datagrid1 := system.windows.forms.datagrid.Create(); // draw a datagrid - not used
Self.datagrid1.Size := system.drawing.Size.Create(584,336);
Self.datagrid1.location := system.drawing.point.Create(8,8);
MyControls[0] := Self.buttonload; // add button to container class
MyControls[1] := Self.datagrid1; // add grid to container class
Self.Controls.AddRange(MyControls);
// basically add them to the form, form is now parent
end;
procedure TForm1.Button1_Click(Sender: TObject; E: EventArgs);
var
dbConnection: oleDBConnection;
dbCommand: OleDBCommand;
dbReader: OleDBDataReader;
dbDataAdapter: OleDBDataAdapter;
dbDataset: Dataset;
temp, temp1: string;
int1: Integer;
begin
temp := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=db1.mdb'; // connection string
temp1 := 'Select * from Shawbury'; // SQL code to fire
(* Fount that I had to use an explicit string to make the connection , The exapmple code
was'nt very clear on this - it works so hopefully it's the right solution *)
dbConnection := System.Data.OleDB.OleDbConnection.Create(temp); // make a DB Connection
dbConnection.Open(); // open a DB Conection
dbCommand := System.Data.OleDB.OleDbCommand.Create(temp1, dbConnection);
// execute the SQL
dbReader := dbCommand.ExecuteReader(); // and store in a datareader
int1 := dbReader.GetOrdinal('subcol1');
// I have a coloum in the Database called subcol1
while dbReader.read() do // keep reading all records
begin
// gives you a warm feeling to see the last record on the button
// - now I'm sure its read the file
buttonload.Text := dbreader.GetValue(int1).tostring;
end;
end;
end.
Delphi - .....................................
neoturk: ...Talk to a msaccess database thru dot net ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A working Delphi for Dot Net example that talks to an MSAccess
database and displays one result. This code should properly
demonstrate the use of Dot Net Components to retreive Data from
MS Access. Other examples I've seen are Internet based and do not
function correctly.
Any Comments to : Andychap@hotmail.com
Please put DOT NET in the subject so I can
Junk filter.
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
//--------------------------------------------------------------------
// Main program refers to the unit below. Make sure of the
// program paths!!!!!
//--------------------------------------------------------------------
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// Simple Access Database demonstration
//
// Written by Andy Chapman (AndyChap@hotmail.com)
// Copyright (C) ACMIS Software , 2003
//
// For all you Delphi lovers here's a complete example of reading
// an MSAccess database useing Dot Net notation. Most of the examples
// found on the net refered to internet and IIS applications but this
// one runs as a true dot net implementation. With thanks to all the
// articles posted on the net... you know who you are.
//
// Program DBTest uses Newform2 as its inclusion. This form is where
// all the work is done. Please pass comment to the EMail address above
// and mark in the Subject Line DOT NET or my mail filter will kill it
//
// Regards : Andrew Chapman
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
program DBTest;
uses
System.Windows.Forms,
Newform2 in 'c:tempnetNewform2.pas' {Form1};
begin
Mainform := TForm1.Create;
Application.Run(Mainform);
end.
//--------------------------------------------------------------------
// Unit refered to by the main program. Make sure your database
// path is set correctly
//--------------------------------------------------------------------
unit NewForm2;
interface
uses
{ Just like the old uses clause in a delphi program. The SYSTEM namespace refers to windows
type controls and not specifically the delphi ones. To draw a delphi button call on the
BORLAND.VCL name spaces... see below }
System.Reflection,
System.Drawing,
System.Drawing.Text,
System.ComponentModel,
System.Windows.Forms,
System.Data.OleDB,
System.Data,
System.Data.Common,
System.Runtime.InteropServices;
type
TForm1 = class(Form)
private
buttonload: system.windows.forms.button; // a button
Components: system.componentmodel.container; // a component store
datagrid1: system.windows.forms.datagrid; // not used in this implementation
public
constructor Create; // which I will inherite and amend
procedure InitializeComponents; // easy way to centralise component creation
procedure Button1_Click(Sender: TObject; E: EventArgs); // on click event
end;
var
MainForm: TForm1; // as ever a main delphi form
implementation
constructor TForm1.Create;
begin
inherited Create; // normal create stuff then set up all the required components
InitializeComponents; // sets up components
end;
procedure TForm1.InitializeComponents;
var
MyControls: array[0..2] of control; // container class for main form
begin
Self.ClientSize := system.Drawing.Size.Create(600,413); // client window on screen
Self.Components := System.ComponentModel.Container.Create();
// container class for the other bits
Self.buttonload := system.windows.forms.button.Create(); // make a button
Self.buttonload.add_click(button1_click); // set its on click event
Self.buttonload.Size := system.drawing.Size.Create(112,32); // size up the button
Self.buttonload.location := system.drawing.point.Create(480,352); // where on screen ?
Self.buttonload.Text := 'Read the database';
// text on the button - 'caption' in real delphi
Self.datagrid1 := system.windows.forms.datagrid.Create(); // draw a datagrid - not used
Self.datagrid1.Size := system.drawing.Size.Create(584,336);
Self.datagrid1.location := system.drawing.point.Create(8,8);
MyControls[0] := Self.buttonload; // add button to container class
MyControls[1] := Self.datagrid1; // add grid to container class
Self.Controls.AddRange(MyControls);
// basically add them to the form, form is now parent
end;
procedure TForm1.Button1_Click(Sender: TObject; E: EventArgs);
var
dbConnection: oleDBConnection;
dbCommand: OleDBCommand;
dbReader: OleDBDataReader;
dbDataAdapter: OleDBDataAdapter;
dbDataset: Dataset;
temp, temp1: string;
int1: Integer;
begin
temp := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=db1.mdb'; // connection string
temp1 := 'Select * from Shawbury'; // SQL code to fire
(* Fount that I had to use an explicit string to make the connection , The exapmple code
was'nt very clear on this - it works so hopefully it's the right solution *)
dbConnection := System.Data.OleDB.OleDbConnection.Create(temp); // make a DB Connection
dbConnection.Open(); // open a DB Conection
dbCommand := System.Data.OleDB.OleDbCommand.Create(temp1, dbConnection);
// execute the SQL
dbReader := dbCommand.ExecuteReader(); // and store in a datareader
int1 := dbReader.GetOrdinal('subcol1');
// I have a coloum in the Database called subcol1
while dbReader.read() do // keep reading all records
begin
// gives you a warm feeling to see the last record on the button
// - now I'm sure its read the file
buttonload.Text := dbreader.GetValue(int1).tostring;
end;
end;
end.
Delphi - .....................................
neoturk: ...Scroll within a dbgrid ?...
- Here is tip how to scroll DBGrid -}
//...
private
OldGridProc: TWndMethod;
procedure GridWindowProc(var Message: TMessage);
//...
procedure TForm1.FormCreate(Sender: TObject);
begin
OldGridProc := DBGrid1.WindowProc;
DBGrid1.WindowProc := GridWindowProc;
end;
procedure TForm1.GridWindowProc(var Message: TMessage);
var
Pos: SmallInt;
begin
OldGridProc(Message);
if Message.Msg = WM_VSCROLL then //or WM_HSCROLL
begin
Pos := Message.WParamHi; //Scrollbox position
Table1.RecNo := Pos;
end;
end;
Delphi - .....................................
neoturk: ...Scroll within a dbgrid ?...
- Here is tip how to scroll DBGrid -}
//...
private
OldGridProc: TWndMethod;
procedure GridWindowProc(var Message: TMessage);
//...
procedure TForm1.FormCreate(Sender: TObject);
begin
OldGridProc := DBGrid1.WindowProc;
DBGrid1.WindowProc := GridWindowProc;
end;
procedure TForm1.GridWindowProc(var Message: TMessage);
var
Pos: SmallInt;
begin
OldGridProc(Message);
if Message.Msg = WM_VSCROLL then //or WM_HSCROLL
begin
Pos := Message.WParamHi; //Scrollbox position
Table1.RecNo := Pos;
end;
end;
Delphi - .....................................
neoturk: ...Autosize a dbgrid-column to fit its contents ?...
Thanks to Thomas Stutz' tip on this site!}
{ A dbgrid is awkward since it has no cells,}
{ you have to step through the table using next;}
{ This procedure is however slow }
procedure SetGridColumnWidths(Grid: Tdbgrid);
const
DEFBORDER = 10;
var
temp, n: Integer;
lmax: array [0..30] of Integer;
begin
with Grid do
begin
Canvas.Font := Font;
for n := 0 to Columns.Count - 1 do
//if columns[n].visible then
lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
grid.DataSource.DataSet.First;
while not grid.DataSource.DataSet.EOF do
begin
for n := 0 to Columns.Count - 1 do
begin
//if columns[n].visible then begin
temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
if temp > lmax[n] then lmax[n] := temp;
//end; { if }
end; {for}
grid.DataSource.DataSet.Next;
end; { while }
grid.DataSource.DataSet.First;
for n := 0 to Columns.Count - 1 do
if lmax[n] > 0 then
Columns[n].Width := lmax[n];
end; { With }
end; {SetGridColumnWidths }
procedure TForm1.Button1Click(Sender: TObject);
begin
SetGridColumnWidths(dbgrid3);
end;
Delphi - .....................................
neoturk: ...Autosize a dbgrid-column to fit its contents ?...
Thanks to Thomas Stutz' tip on this site!}
{ A dbgrid is awkward since it has no cells,}
{ you have to step through the table using next;}
{ This procedure is however slow }
procedure SetGridColumnWidths(Grid: Tdbgrid);
const
DEFBORDER = 10;
var
temp, n: Integer;
lmax: array [0..30] of Integer;
begin
with Grid do
begin
Canvas.Font := Font;
for n := 0 to Columns.Count - 1 do
//if columns[n].visible then
lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
grid.DataSource.DataSet.First;
while not grid.DataSource.DataSet.EOF do
begin
for n := 0 to Columns.Count - 1 do
begin
//if columns[n].visible then begin
temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
if temp > lmax[n] then lmax[n] := temp;
//end; { if }
end; {for}
grid.DataSource.DataSet.Next;
end; { while }
grid.DataSource.DataSet.First;
for n := 0 to Columns.Count - 1 do
if lmax[n] > 0 then
Columns[n].Width := lmax[n];
end; { With }
end; {SetGridColumnWidths }
procedure TForm1.Button1Click(Sender: TObject);
begin
SetGridColumnWidths(dbgrid3);
end;
Delphi - .....................................
neoturk: ...Make a html and txt report component ?...
unit LittleReport;
interface
uses Windows, Messages, SysUtils, Classes, DB, Graphics;
const
FAuthor = 'Simone Di Cicco';
FVersion = '1.0';
type
TLittleReport = class(TComponent)
protected
FDataSet: TDataSet;
FWidth: Integer;
FTitle: string;
FAfterHTML: TStringList;
FPreHTML: TStringList;
procedure GetDBFieldData(StringList: TStringList; FieldName: string);
function GetDataRowsTXT: string;
function GetDataRowsHTML: string;
private
ColumnsCont: array of TStringList;
FieldNames: TStringList;
HTMLTable: TStringList;
TXTFile: TStringList;
IncRowTXT: Integer;
IncRowHTML: Integer;
published
property DataSet: TDataSet read FDataSet write FDataSet;
property HTMLTableWidth: Integer read FWidth write FWidth default 100;
property HTMLPageTitle: string read FTitle write FTitle;
property BeforeReportHTML: TStringList read FPreHTML write FPreHTML;
property AfterReportHTML: TStringList read FAfterHTML write FAfterHTML;
public
constructor Create(AOwner: TComponent); override;
// destructor Destroy; override;
procedure CreateReportHTML(Location: TFileName);
procedure CreateReportTXT(Location: TFileName);
end;
procedure Register;
implementation
{ TLittleReport }
procedure Register;
begin
RegisterComponents('Simone Di Cicco', [TLittleReport]);
end;
constructor TLittleReport.Create(AOwner: TComponent);
begin
inherited;
FPreHTML := TStringList.Create;
FPreHTML.Clear;
FAfterHTML := TStringList.Create;
FAfterHTML.Clear;
FieldNames := TStringList.Create;
FieldNames.Clear;
HTMLTable := TStringList.Create;
HTMLTable.Clear;
TXTFile := TStringList.Create;
TXTFile.Clear;
end;
procedure TLittleReport.GetDBFieldData(StringList: TStringList;
FieldName: string);
begin
StringList.Clear;
with FDataSet do
begin
Open;
DisableControls;
try
while not EOF do
begin
StringList.Add(FieldByName(FieldName).AsString);
Next;
end;
finally
EnableControls;
Close;
end;
end;
end;
procedure TLittleReport.CreateReportHTML(Location: TFileName);
var
Counter, ColCount, RowCont: Integer;
BHTMLPRE, BContPRE, BHTMLAF, BContAF: Integer;
NameCont, FieldCont: Integer;
FieldTitle: string;
begin
NameCont := 0;
FieldCont := 0;
RowCont := 0;
BHTMLPRE := 0;
BContPRE := 0;
BHTMLAF := 0;
BContAF := 0;
IncRowHTML := 0;
FDataSet.Open;
FieldNames.Clear;
FDataSet.GetFieldNames(FieldNames);
ColCount := FDataSet.Fields.Count;
SetLength(ColumnsCont, ColCount);
HTMLTable.Clear;
Counter := 0;
repeat
ColumnsCont[Counter] := TStringList.Create;
GetDBFieldData(ColumnsCont[Counter], FieldNames.Strings[Counter]);
Inc(Counter, 1);
until Counter = ColCount;
RowCont := ColumnsCont[0].Count;
BHTMLPRE := FPreHTML.Count;
if BHTMLPRE >= 1 then
begin
repeat
HTMLTable.Add(FPreHTML.Strings[BContPRE]);
Inc(BContPRE, 1);
until BContPRE = BHTMLPRE;
end;
if FTitle = '' then HTMLTable.Add('<title>' + Location + '</title>')
else
HTMLTable.Add('<title>' + FTitle + '</title>');
HTMLTable.Add('<Table Width="' + IntToStr(FWidth) + '%">');
NameCont := FieldNames.Count;
repeat
FieldTitle := FieldTitle + '</TD><TD></TD><TD><B>' +
FieldNames.Strings[FieldCont] + '</B></TD><TD></TD><TD>';
Inc(FieldCont, 1);
until NameCont = FieldCont;
FieldTitle := '<TR><TD>' + FieldTitle + '</TD></TR>';
HTMLTable.Add(FieldTitle);
repeat
HTMLTable.Add(GetDataRowsHTML);
Inc(IncRowHTML, 1);
until IncRowHTML = RowCont;
HTMLTable.Add('</table>');
BHTMLAF := FAfterHTML.Count;
if BHTMLAF >= 1 then
begin
repeat
HTMLTable.Add(FAfterHTML.Strings[BContAF]);
Inc(BContAF, 1);
until BContAF = BHTMLAF;
end;
HTMLTable.SaveToFile(Location);
end;
procedure TLittleReport.CreateReportTXT(Location: TFileName);
var
CounterRep, ColCount, RowCont: Integer;
NameCont, FieldCont: Integer;
FieldTitle: string;
begin
NameCont := 0;
FieldCont := 0;
RowCont := 0;
IncRowTXT := 0;
FDataSet.Open;
FieldNames.Clear;
FDataSet.GetFieldNames(FieldNames);
ColCount := FDataSet.Fields.Count;
SetLength(ColumnsCont, ColCount);
TXTFile.Clear;
CounterRep := 0;
repeat
ColumnsCont[CounterRep] := TStringList.Create;
GetDBFieldData(ColumnsCont[CounterRep], FieldNames.Strings[CounterRep]);
Inc(CounterRep, 1);
until CounterRep = ColCount;
RowCont := ColumnsCont[0].Count;
NameCont := FieldNames.Count;
repeat
FieldTitle := FieldTitle + '| ' + FieldNames.Strings[FieldCont];
Inc(FieldCont, 1);
until NameCont = FieldCont;
FieldTitle := FieldTitle + '|';
TXTFile.Add(FieldTitle);
TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
repeat
TXTFile.Add(GetDataRowsTXT);
TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
Inc(IncRowTXT, 1);
until IncRowTXT = RowCont;
TXTFile.SaveToFile(Location);
end;
function TLittleReport.GetDataRowsTXT: string;
var
CounterRow, ColArray: Integer;
ReportRow: string;
begin
CounterRow := 0;
ColArray := Length(ColumnsCont);
repeat
ReportRow := ReportRow + '| ' + ColumnsCont[CounterRow].Strings[IncRowTXT] + ' |';
Inc(CounterRow, 1);
until CounterRow = ColArray;
Result := ReportRow;
end;
function TLittleReport.GetDataRowsHTML: string;
var
CounterRow, ColArray: Integer;
ReportRow: string;
begin
CounterRow := 0;
ColArray := Length(ColumnsCont);
repeat
ReportRow := ReportRow + '</TD><TD></TD><TD>' +
ColumnsCont[CounterRow].Strings[IncRowHTML] + '</TD><TD></TD><TD>';
Inc(CounterRow, 1);
until CounterRow = ColArray;
ReportRow := '<TR><TD>' + ReportRow + '</TD></TR>';
Result := ReportRow;
end;
end.
Delphi - .....................................
neoturk: ...Make a html and txt report component ?...
unit LittleReport;
interface
uses Windows, Messages, SysUtils, Classes, DB, Graphics;
const
FAuthor = 'Simone Di Cicco';
FVersion = '1.0';
type
TLittleReport = class(TComponent)
protected
FDataSet: TDataSet;
FWidth: Integer;
FTitle: string;
FAfterHTML: TStringList;
FPreHTML: TStringList;
procedure GetDBFieldData(StringList: TStringList; FieldName: string);
function GetDataRowsTXT: string;
function GetDataRowsHTML: string;
private
ColumnsCont: array of TStringList;
FieldNames: TStringList;
HTMLTable: TStringList;
TXTFile: TStringList;
IncRowTXT: Integer;
IncRowHTML: Integer;
published
property DataSet: TDataSet read FDataSet write FDataSet;
property HTMLTableWidth: Integer read FWidth write FWidth default 100;
property HTMLPageTitle: string read FTitle write FTitle;
property BeforeReportHTML: TStringList read FPreHTML write FPreHTML;
property AfterReportHTML: TStringList read FAfterHTML write FAfterHTML;
public
constructor Create(AOwner: TComponent); override;
// destructor Destroy; override;
procedure CreateReportHTML(Location: TFileName);
procedure CreateReportTXT(Location: TFileName);
end;
procedure Register;
implementation
{ TLittleReport }
procedure Register;
begin
RegisterComponents('Simone Di Cicco', [TLittleReport]);
end;
constructor TLittleReport.Create(AOwner: TComponent);
begin
inherited;
FPreHTML := TStringList.Create;
FPreHTML.Clear;
FAfterHTML := TStringList.Create;
FAfterHTML.Clear;
FieldNames := TStringList.Create;
FieldNames.Clear;
HTMLTable := TStringList.Create;
HTMLTable.Clear;
TXTFile := TStringList.Create;
TXTFile.Clear;
end;
procedure TLittleReport.GetDBFieldData(StringList: TStringList;
FieldName: string);
begin
StringList.Clear;
with FDataSet do
begin
Open;
DisableControls;
try
while not EOF do
begin
StringList.Add(FieldByName(FieldName).AsString);
Next;
end;
finally
EnableControls;
Close;
end;
end;
end;
procedure TLittleReport.CreateReportHTML(Location: TFileName);
var
Counter, ColCount, RowCont: Integer;
BHTMLPRE, BContPRE, BHTMLAF, BContAF: Integer;
NameCont, FieldCont: Integer;
FieldTitle: string;
begin
NameCont := 0;
FieldCont := 0;
RowCont := 0;
BHTMLPRE := 0;
BContPRE := 0;
BHTMLAF := 0;
BContAF := 0;
IncRowHTML := 0;
FDataSet.Open;
FieldNames.Clear;
FDataSet.GetFieldNames(FieldNames);
ColCount := FDataSet.Fields.Count;
SetLength(ColumnsCont, ColCount);
HTMLTable.Clear;
Counter := 0;
repeat
ColumnsCont[Counter] := TStringList.Create;
GetDBFieldData(ColumnsCont[Counter], FieldNames.Strings[Counter]);
Inc(Counter, 1);
until Counter = ColCount;
RowCont := ColumnsCont[0].Count;
BHTMLPRE := FPreHTML.Count;
if BHTMLPRE >= 1 then
begin
repeat
HTMLTable.Add(FPreHTML.Strings[BContPRE]);
Inc(BContPRE, 1);
until BContPRE = BHTMLPRE;
end;
if FTitle = '' then HTMLTable.Add('<title>' + Location + '</title>')
else
HTMLTable.Add('<title>' + FTitle + '</title>');
HTMLTable.Add('<Table Width="' + IntToStr(FWidth) + '%">');
NameCont := FieldNames.Count;
repeat
FieldTitle := FieldTitle + '</TD><TD></TD><TD><B>' +
FieldNames.Strings[FieldCont] + '</B></TD><TD></TD><TD>';
Inc(FieldCont, 1);
until NameCont = FieldCont;
FieldTitle := '<TR><TD>' + FieldTitle + '</TD></TR>';
HTMLTable.Add(FieldTitle);
repeat
HTMLTable.Add(GetDataRowsHTML);
Inc(IncRowHTML, 1);
until IncRowHTML = RowCont;
HTMLTable.Add('</table>');
BHTMLAF := FAfterHTML.Count;
if BHTMLAF >= 1 then
begin
repeat
HTMLTable.Add(FAfterHTML.Strings[BContAF]);
Inc(BContAF, 1);
until BContAF = BHTMLAF;
end;
HTMLTable.SaveToFile(Location);
end;
procedure TLittleReport.CreateReportTXT(Location: TFileName);
var
CounterRep, ColCount, RowCont: Integer;
NameCont, FieldCont: Integer;
FieldTitle: string;
begin
NameCont := 0;
FieldCont := 0;
RowCont := 0;
IncRowTXT := 0;
FDataSet.Open;
FieldNames.Clear;
FDataSet.GetFieldNames(FieldNames);
ColCount := FDataSet.Fields.Count;
SetLength(ColumnsCont, ColCount);
TXTFile.Clear;
CounterRep := 0;
repeat
ColumnsCont[CounterRep] := TStringList.Create;
GetDBFieldData(ColumnsCont[CounterRep], FieldNames.Strings[CounterRep]);
Inc(CounterRep, 1);
until CounterRep = ColCount;
RowCont := ColumnsCont[0].Count;
NameCont := FieldNames.Count;
repeat
FieldTitle := FieldTitle + '| ' + FieldNames.Strings[FieldCont];
Inc(FieldCont, 1);
until NameCont = FieldCont;
FieldTitle := FieldTitle + '|';
TXTFile.Add(FieldTitle);
TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
repeat
TXTFile.Add(GetDataRowsTXT);
TXTFile.Add('"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""');
Inc(IncRowTXT, 1);
until IncRowTXT = RowCont;
TXTFile.SaveToFile(Location);
end;
function TLittleReport.GetDataRowsTXT: string;
var
CounterRow, ColArray: Integer;
ReportRow: string;
begin
CounterRow := 0;
ColArray := Length(ColumnsCont);
repeat
ReportRow := ReportRow + '| ' + ColumnsCont[CounterRow].Strings[IncRowTXT] + ' |';
Inc(CounterRow, 1);
until CounterRow = ColArray;
Result := ReportRow;
end;
function TLittleReport.GetDataRowsHTML: string;
var
CounterRow, ColArray: Integer;
ReportRow: string;
begin
CounterRow := 0;
ColArray := Length(ColumnsCont);
repeat
ReportRow := ReportRow + '</TD><TD></TD><TD>' +
ColumnsCont[CounterRow].Strings[IncRowHTML] + '</TD><TD></TD><TD>';
Inc(CounterRow, 1);
until CounterRow = ColArray;
ReportRow := '<TR><TD>' + ReportRow + '</TD></TR>';
Result := ReportRow;
end;
end.
Delphi - .....................................
neoturk: ...Create a dataset lookup field at runtime ?...
// example: create lookup field (string, size: 50) at runtime
with TStringField.Create(YourDataSet) do
begin
FieldName := 'FieldName';
FieldKind := fkLookup;
DataSet := YourDataSet;
Name := DataSet.Name + FieldName;
KeyFields := 'YourKeyFields';
LookupDataSet := YourLookupDataSet;
LookupKeyFields := 'YourLookupKeyFields';
LookupResultField := 'YourLookupResultField';
FieldDefs.Add(FieldName, ftString, 50, False);
end;
Delphi - .....................................
neoturk: ...Create a dataset lookup field at runtime ?...
// example: create lookup field (string, size: 50) at runtime
with TStringField.Create(YourDataSet) do
begin
FieldName := 'FieldName';
FieldKind := fkLookup;
DataSet := YourDataSet;
Name := DataSet.Name + FieldName;
KeyFields := 'YourKeyFields';
LookupDataSet := YourLookupDataSet;
LookupKeyFields := 'YourLookupKeyFields';
LookupResultField := 'YourLookupResultField';
FieldDefs.Add(FieldName, ftString, 50, False);
end;
Delphi - .....................................
neoturk: ...Get the size of a string in a stored procedure-trigger [interbase] ?...
1) Zuerst wird eine (bekannte) Hilfsfunktion benötigt: FILLCHAR
---------------------------------------------------------------
CREATE PROCEDURE FILLCHAR (
AFILLCHAR CHAR (1),
ARESULTLEN INTEGER)
RETURNS (
ARESULTSTRING VARCHAR (255))
AS
DECLARE VARIABLE ACOUNTER INTEGER;
BEGIN
ARESULTSTRING = ' ';
ACOUNTER = 0;
While ( :ACOUNTER < :aResultLen ) Do
Begin
ARESULTSTRING = :ARESULTSTRING || :aFillChar;
ACOUNTER = :ACOUNTER + 1;
END
SUSPEND;
END
Anmerkung:
Das "Suspend" dürfte überflüssig sein.
Allerdings läßt sich dann die Funktion nicht "debuggen", wenn z.B.
Marathon (siehe http://alanti.net/firebird/marathon/ ) oder QuickDesk
als Frontend bemüht werden.
(throw the suspend away, if you don't need to debug)
2) Dann kommt die eigentliche Funktion zum Tragen: GETLENGHT
------------------------------------------------------------
CREATE PROCEDURE GETLENGHT (
INPUTSTRING VARCHAR (255))
RETURNS (
THELENGTH INTEGER)
AS
DECLARE VARIABLE LCOUNTER INTEGER;
DECLARE VARIABLE DUMMYSTRING VARCHAR(255);
DECLARE VARIABLE TEMPSTRING VARCHAR(255);
DECLARE VARIABLE C CHAR(1);
BEGIN
THELENGTH = 0;
DUMMYSTRING = '';
C = '0';
LCOUNTER = 0;
TEMPSTRING = '';
if (:INPUTSTRING IS NULL) then
BEGIN
EXIT;
END
WHILE (LCOUNTER < 255) DO
BEGIN
TheLength = :LCOUNTER;
EXECUTE PROCEDURE FILLCHAR ( :C, :LCOUNTER ) RETURNING_VALUES :DUMMYSTRING;
TEMPSTRING = Cast ( :INPUTSTRING || :DUMMYSTRING as CHAR(255));
LCOUNTER = LCOUNTER + 1;
WHEN ANY DO
BEGIN
TheLength = 255 - :LCOUNTER;
SUSPEND;
EXIT;
END
END
SUSPEND;
END
Anmerkungen:
Auch hier dürfte man sich die "SUSPEND" im Normalbetrieb ersparren
können...
Die maximale Länge des zu prüfenden String wurde willkürlich auf
255 Zeichen gesetzt. Bei Bedarf kann man diesen Wert "vorsichtig"
anpassen: Wird dieser Wert zu groß gewählt und werden kleine
Zeichenketten mit dieser Funktion bearbeitet, dann erhöht sich
natürlich die Dauer der Verarbeitung entsprechend.
3) Usage:
---------
CREATE PROCEDURE TEST_GETLENGHT
AS
DECLARE VARIABLE L INTEGER;
DECLARE VARIABLE S VARCHAR(255);
DECLARE VARIABLE Meldung VARCHAR(255);
BEGIN
L = 0;
MELDUNG = '';
S = '12345678901234567890';
EXECUTE PROCEDURE GETLENGHT ( :S ) RETURNING_VALUES :L;
/* ab hier steht in "L" die Länge des Strings "S" */
IF (L<21) THEN
BEGIN
MELDUNG = 'Noch ' || CAST( ( 20 - :L ) as VARCHAR(3)) || ' Zeichen übrig...';
END
ELSE
BEGIN
MELDUNG = 'Stringlänge = ' || CAST( :L as VARCHAR(3)) || ' => String zu lang! (maximal 20 Zeichen)';
END
/* ... */
SUSPEND;
END
Bemerkungen:
Es lassen sich viele andere String-Funktionen mittels Stored
Procedures nachbilden.
Allerdings ist eine Datenbank bzw. einen Datenbank-Server nicht
besonders dafür ausgelegt... Zumindest nicht, wenn rechenintensive
Aufgabe anfallen.
Andererseits kann die Anwendung solchen "Tricks" die Menge der
zwischen Client und Server übertragenen Daten erheblich reduziert
werden: gewisse Prüfungen können dann VOR der Datenübertragung
stattfinden.
Viel Spaß
Delphi - .....................................
neoturk: ...Get the size of a string in a stored procedure-trigger [interbase] ?...
1) Zuerst wird eine (bekannte) Hilfsfunktion benötigt: FILLCHAR
---------------------------------------------------------------
CREATE PROCEDURE FILLCHAR (
AFILLCHAR CHAR (1),
ARESULTLEN INTEGER)
RETURNS (
ARESULTSTRING VARCHAR (255))
AS
DECLARE VARIABLE ACOUNTER INTEGER;
BEGIN
ARESULTSTRING = ' ';
ACOUNTER = 0;
While ( :ACOUNTER < :aResultLen ) Do
Begin
ARESULTSTRING = :ARESULTSTRING || :aFillChar;
ACOUNTER = :ACOUNTER + 1;
END
SUSPEND;
END
Anmerkung:
Das "Suspend" dürfte überflüssig sein.
Allerdings läßt sich dann die Funktion nicht "debuggen", wenn z.B.
Marathon (siehe http://alanti.net/firebird/marathon/ ) oder QuickDesk
als Frontend bemüht werden.
(throw the suspend away, if you don't need to debug)
2) Dann kommt die eigentliche Funktion zum Tragen: GETLENGHT
------------------------------------------------------------
CREATE PROCEDURE GETLENGHT (
INPUTSTRING VARCHAR (255))
RETURNS (
THELENGTH INTEGER)
AS
DECLARE VARIABLE LCOUNTER INTEGER;
DECLARE VARIABLE DUMMYSTRING VARCHAR(255);
DECLARE VARIABLE TEMPSTRING VARCHAR(255);
DECLARE VARIABLE C CHAR(1);
BEGIN
THELENGTH = 0;
DUMMYSTRING = '';
C = '0';
LCOUNTER = 0;
TEMPSTRING = '';
if (:INPUTSTRING IS NULL) then
BEGIN
EXIT;
END
WHILE (LCOUNTER < 255) DO
BEGIN
TheLength = :LCOUNTER;
EXECUTE PROCEDURE FILLCHAR ( :C, :LCOUNTER ) RETURNING_VALUES :DUMMYSTRING;
TEMPSTRING = Cast ( :INPUTSTRING || :DUMMYSTRING as CHAR(255));
LCOUNTER = LCOUNTER + 1;
WHEN ANY DO
BEGIN
TheLength = 255 - :LCOUNTER;
SUSPEND;
EXIT;
END
END
SUSPEND;
END
Anmerkungen:
Auch hier dürfte man sich die "SUSPEND" im Normalbetrieb ersparren
können...
Die maximale Länge des zu prüfenden String wurde willkürlich auf
255 Zeichen gesetzt. Bei Bedarf kann man diesen Wert "vorsichtig"
anpassen: Wird dieser Wert zu groß gewählt und werden kleine
Zeichenketten mit dieser Funktion bearbeitet, dann erhöht sich
natürlich die Dauer der Verarbeitung entsprechend.
3) Usage:
---------
CREATE PROCEDURE TEST_GETLENGHT
AS
DECLARE VARIABLE L INTEGER;
DECLARE VARIABLE S VARCHAR(255);
DECLARE VARIABLE Meldung VARCHAR(255);
BEGIN
L = 0;
MELDUNG = '';
S = '12345678901234567890';
EXECUTE PROCEDURE GETLENGHT ( :S ) RETURNING_VALUES :L;
/* ab hier steht in "L" die Länge des Strings "S" */
IF (L<21) THEN
BEGIN
MELDUNG = 'Noch ' || CAST( ( 20 - :L ) as VARCHAR(3)) || ' Zeichen übrig...';
END
ELSE
BEGIN
MELDUNG = 'Stringlänge = ' || CAST( :L as VARCHAR(3)) || ' => String zu lang! (maximal 20 Zeichen)';
END
/* ... */
SUSPEND;
END
Bemerkungen:
Es lassen sich viele andere String-Funktionen mittels Stored
Procedures nachbilden.
Allerdings ist eine Datenbank bzw. einen Datenbank-Server nicht
besonders dafür ausgelegt... Zumindest nicht, wenn rechenintensive
Aufgabe anfallen.
Andererseits kann die Anwendung solchen "Tricks" die Menge der
zwischen Client und Server übertragenen Daten erheblich reduziert
werden: gewisse Prüfungen können dann VOR der Datenübertragung
stattfinden.
Viel Spaß
Delphi - .....................................
neoturk: ...Use pesrian alphabet in sqlserver on win2000 ?...
procedure TMainForm.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
// replacing persian incorrect char on get from keyboard, in all of the Tcontrols!
// without this code,ms-sql server have incorrect result set after sort on persian field.
// some perisan char in win2000 have same shape but differ in ordering
if Msg.message = WM_CHAR then // for settting char ( kaf) in win2000
begin
if Msg.wParam = 152 then
Msg.wParam := 223
// and more......
end;
end;
Delphi - .....................................
neoturk: ...Use pesrian alphabet in sqlserver on win2000 ?...
procedure TMainForm.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
// replacing persian incorrect char on get from keyboard, in all of the Tcontrols!
// without this code,ms-sql server have incorrect result set after sort on persian field.
// some perisan char in win2000 have same shape but differ in ordering
if Msg.message = WM_CHAR then // for settting char ( kaf) in win2000
begin
if Msg.wParam = 152 then
Msg.wParam := 223
// and more......
end;
end;
Delphi - .....................................
neoturk: ...Add a row number in your dbgrid ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1. create new blank field in dbgrid
2. rename the title with 'No'
3. put this code in OnDrawColumncell
4. Now your Grid has a row number
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if DataSource1.DataSet.RecNo > 0 then
begin
if Column.Title.Caption = 'No' then
DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
end;
end;
Delphi - .....................................
neoturk: ...Add a row number in your dbgrid ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1. create new blank field in dbgrid
2. rename the title with 'No'
3. put this code in OnDrawColumncell
4. Now your Grid has a row number
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if DataSource1.DataSet.RecNo > 0 then
begin
if Column.Title.Caption = 'No' then
DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
end;
end;
Delphi - .....................................
neoturk: ...Get all foreignkeys in use in a given table [ms sql server] ?...
{++++ GERMAN +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Im folgenden ein Beispiel, wie man alle Fremdschlüssel einer
Tabelle im MS SQL-Server 2000 auslesen kann.
Die gespeicherte Systemprocedure des SQL-Servers >> exec sp_fkeys [Tabellenname] <<
liefert ausschließlich die Schlüssel, die auf die gewählte Tabelle
zeigen.
Testen:
Unter BStartClick bei Aufruf der Procedure GetForeignKeys den Tabellenname
anpassen.
Anwendung erstellen, neue AdoConnection, AdoConnection.Name = ADOConnection1,
Verbindung zur Datenbank herstellen, neuer Button, Button.Name = BStart,
Neues Memo, Memo.Name = Memo1,
Doppelclick auf den Button.
Version:
Getestet unter Delphi 7(Ent) und WinXP
Weitergabe:
Diese Unit kann beliebig weitergegeben und verändert werden.
+++++ ENGLISH ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
The system stored procedure "sp_fkeys ([tablename])" will only give
a list of foreign key references to the given table.
The "GetForeignKeys" function above will give you the list of fields
that are "foreign hold" from other tables.
Try out: You'll need an AdoConnection to your DB ...
Tested with: Delphi 7(Ent) und WinXP
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, DBGrids, DB, ADODB, StdCtrls, DBCtrls;
type
TForm1 = class(TForm)
ADOConnection1: TADOConnection;
Memo1: TMemo;
BStart: TButton;
procedure BStartClick(Sender: TObject);
private
procedure GetForeignKeys(sTableName: string;
MyConnection: TADOConnection;
var SlForeignKeyName,
SlKeysActTable,
SlKeysForeignTable,
SlForeignKeyTable: TStringList);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
(* Get foreign keys *)
procedure TForm1.GetForeignKeys(sTableName: string;
MyConnection: TADOConnection;
var SlForeignKeyName,
SlKeysActTable,
SlKeysForeignTable,
SlForeignKeyTable: TStringList);
var
MySelectQuery, MyRecordQuery: TADOQuery;
i: Integer;
SlKeysAct, SlKeysFor: TStringList;
sConstraintName, sForeignKeys, sForeignTable: string;
(* Schlüssel ermitteln *)
procedure GetKeys(sKeyList: string; fAct: Boolean);
var
i: Integer;
sKey: string;
begin
i := 0;
repeat
Inc(i);
if sKeyList[i] <> ',' then
begin
sKey := sKey + sKeyList[i];
end
else
begin
if fAct then
begin
SlKeysAct.Add(sKey);
end
else
begin
SlKeysFor.Add(sKey);
end;
if (Length(sKey) + 1) < i then
begin
if sKey[(i + 1)] = ' ' then
begin
Inc(i);
end;
end;
sKey := '';
end;
until (i = Length(sKeyList));
if sKey <> '' then
begin
if fAct then
begin
SlKeysAct.Add(sKey);
end
else
begin
SlKeysFor.Add(sKey);
end;
end;
end;
procedure GetForeignKeyFieldsAndTable(sSQL: string);
var
i: Integer;
sValue: string;
iPos: Integer;
fAddValue: Boolean;
fInFields: Boolean;
begin
if Length(sSQL) >= 10 then
begin
(* REFERENCES entfernen *)
sValue := Copy(sSQL, 1, 10);
if AnsiUpperCase(sValue) = 'REFERENCES' then
begin
Delete(sSQL, 1, 11);
end;
i := 0;
iPos := 0;
sValue := '';
fInFields := False;
repeat
Inc(i);
fAddValue := False;
(* "normal" lesen *)
if (sSQL[i] <> '.') and
(sSQL[i] <> ' ') and
(sSQL[i] <> '(') and
(sSQL[i] <> ')') and
(fInFields = False) then
begin
sValue := sValue + sSQL[i];
fAddValue := True;
end;
(* In Felder *)
if sSQL[i] = '(' then
begin
fInFields := True;
end;
if (fInFields) and (sSQL[i] <> '(') and (sSQL[i] <> ')') then
begin
sValue := sValue + sSQL[i];
end;
(* Felder verlassen *)
if sSQL[i] = ')' then
begin
fInFields := False;
end;
if (fAddValue = False) and (fInFields = False) then
begin
case iPos of
(* Datenbank *)
0:
begin
sValue := '';
Inc(iPos);
end;
(* Ower *)
1:
begin
sValue := '';
Inc(iPos);
end;
(* Tabelle *)
2:
begin
sForeignTable := sValue;
sValue := '';
Inc(iPos);
end;
(* Felder *)
3:
begin
sForeignKeys := sValue;
sValue := '';
Inc(iPos);
end;
else
begin
end;
end;
end;
until (i = Length(sSQL));
end;
end;
begin
try
MySelectQuery := TADOQuery.Create(Application);
with MySelectQuery do
begin
Name := 'MyHelpSelectQuery';
Connection := MyConnection;
SQL.Add('sp_help ' + sTableName);
Active := True;
end;
try
MyRecordQuery := TADOQuery.Create(Application);
with MySelectQuery do
begin
Name := 'MyHelpRecordQuery';
Connection := MyConnection;
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
if MySelectQuery.State = dsBrowse then
begin
Recordset := MySelectQuery.NextRecordset(i);
if FindField('Constraint_Type') <> nil then
begin
SlKeysAct := TStringList.Create;
SlKeysFor := TStringList.Create;
try
while not EOF do
begin
if AnsiUpperCase(FieldByName('Constraint_Type').AsString) =
AnsiUpperCase('FOREIGN KEY') then
begin
SlKeysAct.Clear;
(* In einzelne Felder teilen *)
GetKeys(FieldByName('Constraint_Keys').AsString, True);
(* Constraint festhalten *)
sConstraintName := FieldByName('Constraint_Name').AsString;
(* Referenz steht im nächsten Datensatz *)
Next;
(* Tabelle und Felder auflösen *)
GetForeignKeyFieldsAndTable(FieldByName('Constraint_Keys').AsString);
(* In einzelne Felder teilen *)
SlKeysFor.Clear;
GetKeys(sForeignKeys, False);
for i := 0 to (SlKeysAct.Count - 1) do
begin
SlForeignKeyName.Add(sConstraintName);
SlKeysActTable.Add(SlKeysAct.Strings[i]);
SlKeysForeignTable.Add(SlKeysFor.Strings[i]);
SlForeignKeyTable.Add(sForeignTable);
end;
end;
Next;
end;
finally
FreeAndNil(SlKeysAct);
FreeAndNil(SlKeysFor);
end;
end;
end;
end;
finally
FreeAndNil(MyRecordQuery);
end;
finally
FreeAndNil(MySelectQuery);
end;
end;
procedure TForm1.BStartClick(Sender: TObject);
var
SlForeignKeyName, SlKeysActTable, SlKeysForeignTable, SlForeignKeyTable: TStringList;
i: Integer;
begin
try
SlForeignKeyName := TStringList.Create;
SlKeysActTable := TStringList.Create;
SlKeysForeignTable := TStringList.Create;
SlForeignKeyTable := TStringList.Create;
GetForeignKeys('Kundendaten', // Tabellenname
ADOConnection1, // ADO-Connection
SlForeignKeyName, // Fremdschlüsselname
SlKeysActTable, // Alle Schlüsselfelder der aktuellen Tabelle
SlKeysForeignTable, // Alle Fremdschlüsselfelder
SlForeignKeyTable); // Fremdschlüsseltabellenname
(* Ins Memo schreiben ... *)
for i := 0 to (SlForeignKeyName.Count - 1) do
begin
if i > 0 then
begin
Memo1.Lines.Add('');
end;
Memo1.Lines.Add(SlForeignKeyName.Strings[i]);
Memo1.Lines.Add(SlKeysActTable.Strings[i]);
Memo1.Lines.Add(SlKeysForeignTable.Strings[i]);
Memo1.Lines.Add(SlForeignKeyTable.Strings[i]);
end;
finally
FreeAndNil(SlForeignKeyName);
FreeAndNil(SlKeysActTable);
FreeAndNil(SlKeysForeignTable);
FreeAndNil(SlForeignKeyTable);
end;
end;
end.
Delphi - .....................................
neoturk: ...Get all foreignkeys in use in a given table [ms sql server] ?...
{++++ GERMAN +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Im folgenden ein Beispiel, wie man alle Fremdschlüssel einer
Tabelle im MS SQL-Server 2000 auslesen kann.
Die gespeicherte Systemprocedure des SQL-Servers >> exec sp_fkeys [Tabellenname] <<
liefert ausschließlich die Schlüssel, die auf die gewählte Tabelle
zeigen.
Testen:
Unter BStartClick bei Aufruf der Procedure GetForeignKeys den Tabellenname
anpassen.
Anwendung erstellen, neue AdoConnection, AdoConnection.Name = ADOConnection1,
Verbindung zur Datenbank herstellen, neuer Button, Button.Name = BStart,
Neues Memo, Memo.Name = Memo1,
Doppelclick auf den Button.
Version:
Getestet unter Delphi 7(Ent) und WinXP
Weitergabe:
Diese Unit kann beliebig weitergegeben und verändert werden.
+++++ ENGLISH ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
The system stored procedure "sp_fkeys ([tablename])" will only give
a list of foreign key references to the given table.
The "GetForeignKeys" function above will give you the list of fields
that are "foreign hold" from other tables.
Try out: You'll need an AdoConnection to your DB ...
Tested with: Delphi 7(Ent) und WinXP
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, DBGrids, DB, ADODB, StdCtrls, DBCtrls;
type
TForm1 = class(TForm)
ADOConnection1: TADOConnection;
Memo1: TMemo;
BStart: TButton;
procedure BStartClick(Sender: TObject);
private
procedure GetForeignKeys(sTableName: string;
MyConnection: TADOConnection;
var SlForeignKeyName,
SlKeysActTable,
SlKeysForeignTable,
SlForeignKeyTable: TStringList);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
(* Get foreign keys *)
procedure TForm1.GetForeignKeys(sTableName: string;
MyConnection: TADOConnection;
var SlForeignKeyName,
SlKeysActTable,
SlKeysForeignTable,
SlForeignKeyTable: TStringList);
var
MySelectQuery, MyRecordQuery: TADOQuery;
i: Integer;
SlKeysAct, SlKeysFor: TStringList;
sConstraintName, sForeignKeys, sForeignTable: string;
(* Schlüssel ermitteln *)
procedure GetKeys(sKeyList: string; fAct: Boolean);
var
i: Integer;
sKey: string;
begin
i := 0;
repeat
Inc(i);
if sKeyList[i] <> ',' then
begin
sKey := sKey + sKeyList[i];
end
else
begin
if fAct then
begin
SlKeysAct.Add(sKey);
end
else
begin
SlKeysFor.Add(sKey);
end;
if (Length(sKey) + 1) < i then
begin
if sKey[(i + 1)] = ' ' then
begin
Inc(i);
end;
end;
sKey := '';
end;
until (i = Length(sKeyList));
if sKey <> '' then
begin
if fAct then
begin
SlKeysAct.Add(sKey);
end
else
begin
SlKeysFor.Add(sKey);
end;
end;
end;
procedure GetForeignKeyFieldsAndTable(sSQL: string);
var
i: Integer;
sValue: string;
iPos: Integer;
fAddValue: Boolean;
fInFields: Boolean;
begin
if Length(sSQL) >= 10 then
begin
(* REFERENCES entfernen *)
sValue := Copy(sSQL, 1, 10);
if AnsiUpperCase(sValue) = 'REFERENCES' then
begin
Delete(sSQL, 1, 11);
end;
i := 0;
iPos := 0;
sValue := '';
fInFields := False;
repeat
Inc(i);
fAddValue := False;
(* "normal" lesen *)
if (sSQL[i] <> '.') and
(sSQL[i] <> ' ') and
(sSQL[i] <> '(') and
(sSQL[i] <> ')') and
(fInFields = False) then
begin
sValue := sValue + sSQL[i];
fAddValue := True;
end;
(* In Felder *)
if sSQL[i] = '(' then
begin
fInFields := True;
end;
if (fInFields) and (sSQL[i] <> '(') and (sSQL[i] <> ')') then
begin
sValue := sValue + sSQL[i];
end;
(* Felder verlassen *)
if sSQL[i] = ')' then
begin
fInFields := False;
end;
if (fAddValue = False) and (fInFields = False) then
begin
case iPos of
(* Datenbank *)
0:
begin
sValue := '';
Inc(iPos);
end;
(* Ower *)
1:
begin
sValue := '';
Inc(iPos);
end;
(* Tabelle *)
2:
begin
sForeignTable := sValue;
sValue := '';
Inc(iPos);
end;
(* Felder *)
3:
begin
sForeignKeys := sValue;
sValue := '';
Inc(iPos);
end;
else
begin
end;
end;
end;
until (i = Length(sSQL));
end;
end;
begin
try
MySelectQuery := TADOQuery.Create(Application);
with MySelectQuery do
begin
Name := 'MyHelpSelectQuery';
Connection := MyConnection;
SQL.Add('sp_help ' + sTableName);
Active := True;
end;
try
MyRecordQuery := TADOQuery.Create(Application);
with MySelectQuery do
begin
Name := 'MyHelpRecordQuery';
Connection := MyConnection;
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
Recordset := MySelectQuery.NextRecordset(i);
if MySelectQuery.State = dsBrowse then
begin
Recordset := MySelectQuery.NextRecordset(i);
if FindField('Constraint_Type') <> nil then
begin
SlKeysAct := TStringList.Create;
SlKeysFor := TStringList.Create;
try
while not EOF do
begin
if AnsiUpperCase(FieldByName('Constraint_Type').AsString) =
AnsiUpperCase('FOREIGN KEY') then
begin
SlKeysAct.Clear;
(* In einzelne Felder teilen *)
GetKeys(FieldByName('Constraint_Keys').AsString, True);
(* Constraint festhalten *)
sConstraintName := FieldByName('Constraint_Name').AsString;
(* Referenz steht im nächsten Datensatz *)
Next;
(* Tabelle und Felder auflösen *)
GetForeignKeyFieldsAndTable(FieldByName('Constraint_Keys').AsString);
(* In einzelne Felder teilen *)
SlKeysFor.Clear;
GetKeys(sForeignKeys, False);
for i := 0 to (SlKeysAct.Count - 1) do
begin
SlForeignKeyName.Add(sConstraintName);
SlKeysActTable.Add(SlKeysAct.Strings[i]);
SlKeysForeignTable.Add(SlKeysFor.Strings[i]);
SlForeignKeyTable.Add(sForeignTable);
end;
end;
Next;
end;
finally
FreeAndNil(SlKeysAct);
FreeAndNil(SlKeysFor);
end;
end;
end;
end;
finally
FreeAndNil(MyRecordQuery);
end;
finally
FreeAndNil(MySelectQuery);
end;
end;
procedure TForm1.BStartClick(Sender: TObject);
var
SlForeignKeyName, SlKeysActTable, SlKeysForeignTable, SlForeignKeyTable: TStringList;
i: Integer;
begin
try
SlForeignKeyName := TStringList.Create;
SlKeysActTable := TStringList.Create;
SlKeysForeignTable := TStringList.Create;
SlForeignKeyTable := TStringList.Create;
GetForeignKeys('Kundendaten', // Tabellenname
ADOConnection1, // ADO-Connection
SlForeignKeyName, // Fremdschlüsselname
SlKeysActTable, // Alle Schlüsselfelder der aktuellen Tabelle
SlKeysForeignTable, // Alle Fremdschlüsselfelder
SlForeignKeyTable); // Fremdschlüsseltabellenname
(* Ins Memo schreiben ... *)
for i := 0 to (SlForeignKeyName.Count - 1) do
begin
if i > 0 then
begin
Memo1.Lines.Add('');
end;
Memo1.Lines.Add(SlForeignKeyName.Strings[i]);
Memo1.Lines.Add(SlKeysActTable.Strings[i]);
Memo1.Lines.Add(SlKeysForeignTable.Strings[i]);
Memo1.Lines.Add(SlForeignKeyTable.Strings[i]);
end;
finally
FreeAndNil(SlForeignKeyName);
FreeAndNil(SlKeysActTable);
FreeAndNil(SlKeysForeignTable);
FreeAndNil(SlForeignKeyTable);
end;
end;
end.
Delphi - .....................................
neoturk: ...Let build windows an ado connection string ?...
{I see always people manually building the connection string.
Wy not use the dialog that windows provide for us ? Of course
it is possible to use the PromptDataSource in ADODB, but this
give not the opportunity to see if the user has pressed OK or
Cancel, so we dont know when to save the changes. So I use this
code instead. I hope it benefit many people. Rgds, Wilfried}
uses OleDB, ComObj, ActiveX;
function ADOConnectionString(ParentHandle: THandle; InitialString: WideString;
out NewString: string): Boolean;
var
DataInit: IDataInitialize;
DBPrompt: IDBPromptInitialize;
DataSource: IUnknown;
InitStr: PWideChar;
begin
Result := False;
DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
if InitialString <> '' then
DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER, PWideChar(InitialString),
IUnknown, DataSource);
DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;
if Succeeded(DBPrompt.PromptDataSource(nil, ParentHandle,
DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource)) then
begin
InitStr := nil;
DataInit.GetInitializationString(DataSource, True, InitStr);
NewString := InitStr;
Result := True;
end;
end;
Delphi - .....................................
neoturk: ...Let build windows an ado connection string ?...
{I see always people manually building the connection string.
Wy not use the dialog that windows provide for us ? Of course
it is possible to use the PromptDataSource in ADODB, but this
give not the opportunity to see if the user has pressed OK or
Cancel, so we dont know when to save the changes. So I use this
code instead. I hope it benefit many people. Rgds, Wilfried}
uses OleDB, ComObj, ActiveX;
function ADOConnectionString(ParentHandle: THandle; InitialString: WideString;
out NewString: string): Boolean;
var
DataInit: IDataInitialize;
DBPrompt: IDBPromptInitialize;
DataSource: IUnknown;
InitStr: PWideChar;
begin
Result := False;
DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
if InitialString <> '' then
DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER, PWideChar(InitialString),
IUnknown, DataSource);
DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;
if Succeeded(DBPrompt.PromptDataSource(nil, ParentHandle,
DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource)) then
begin
InitStr := nil;
DataInit.GetInitializationString(DataSource, True, InitStr);
NewString := InitStr;
Result := True;
end;
end;
Delphi - .....................................
neoturk: ...Showing progress while loading blobs from ib-fb with ibx ?...
uses
Windows, SysUtils, Variants, Classes, Graphics,
IBHeader, IBBlob, IBIntf, IB, IBErrorcodes;
type
TCBBlobCallBackMode = (bcbmStart, bcbmProgress, bcbmEnd);
TCBBlobCallBack = procedure(ATotal, AReceived: Integer;
AMode: TCBBlobCallBackMode) of object;
//------------------------------------------------------------------------------
function cbGetBlobWithCallBack(ABlobID: TISC_Quad;
ADBHandle: PISC_DB_Handle;
ATRHandle: PISC_TR_Handle;
AFileName: string; ACallBack: TCBBlobCallBack): Boolean;
...interface
//------------------------------------------------------------------------------
function cbGetBlobWithCallBack(ABlobID: TISC_Quad;
ADBHandle: PISC_DB_Handle;
ATRHandle: PISC_TR_Handle;
AFileName: string; ACallBack: TCBBlobCallBack): Boolean;
var
LBlobHandle: TISC_BLOB_HANDLE;
LSeg, LSize, LTotal: LongInt;
LType: Short;
LBuffer: PChar;
LCurPos: LongInt;
LBytesRead, LSegLen: Word;
LLocalBuffer: PChar;
LStream: TMemoryStream;
begin
Result := False;
LBlobHandle := nil;
// open the blob file; especially get the BlobHandle
GetGDSLibrary.isc_open_blob2(StatusVector, ADBHandle, ATRHandle,
@LBlobHandle, @ABlobID, 0, nil);
try
// get the informations of the blob;
// segment count, segment size, total size, blob type
IBBlob.GetBlobInfo(@LBlobHandle, LSeg, LSize, LTotal, LType);
// raise the first callback
if Assigned(ACallBack) then
ACallBack(LTotal, 0, bcbmStart);
// assign the variables and allocate memory
LBuffer := nil;
ReallocMem(LBuffer, LTotal);
LLocalBuffer := LBuffer;
LCurPos := 0;
LSegLen := Word(DefaultBlobSegmentSize);
while (LCurPos < LTotal) do
begin
if (LCurPos + LSegLen > LTotal) then
LSegLen := LTotal - LCurPos;
// receive the segments
if not ((GetGDSLibrary.isc_get_segment(StatusVector, @LBlobHandle,
@LBytesRead, LSegLen, LLocalBuffer) = 0) or
(StatusVectorArray[1] = isc_segment)) then
IBDatabaseError;
Inc(LLocalBuffer, LBytesRead);
Inc(LCurPos, LBytesRead);
// raise the callback
if Assigned(ACallBack) then
ACallBack(LTotal, LBytesRead, bcbmProgress);
LBytesRead := 0;
end;
// raise the last callback
if Assigned(ACallBack) then
ACallBack(LTotal, LBytesRead, bcbmEnd);
// save the file
LStream := TMemoryStream.Create;
try
LStream.WriteBuffer(LBuffer ^, LTotal);
LStream.SaveToFile(AFileName);
finally
FreeAndNil(LStream);
end;
finally
// close the blob
GetGDSLibrary.isc_close_blob(StatusVector, @LBlobHandle);
Result := True;
end;
end;
// Beispielaufuf
// Samplecall
// ich habe auf dem Formular eine TISQL-Komponente liegen
// Die TISQL-Komponente habe ich vor dem getBlob mit ExecSQL aufgemacht
// Man kann auch TIBCUstomDataset-Komponenten verwenden
//
// I use an IBSQL component, but it is also possible to use an IBCustomDataset
procedure TTestForm.getBlob(ADestfile: string);
begin
// der aufruf unter verwendung von TIBSQL
// the call with IBSQL
cbGetBlobWithCallBack(IBSQLUpdates.FieldByName('Update_File').AsQuad,
IBSQLUpdates.DBHandle, IBSQLUpdates.TRHandle, ADestFile, blobCallBack);
{// die variante mit TIBDataset
// the alternative with IBCustomDataset
cbGetBlobWithCallBack(IBDSUpdates.Current.ByName('Update_File').AsQuad,
IBUpdates.DBHandle, IBUpdates.TRHandle, ADestFile, blobCallBack);}
end;
// nun noch der Callback
// zu testzwecken habe ich eine Progressbar auf das Formular gelegt
//
// The Callback
// Put a progressbar on you form testing purposes
procedure TTestForm.blobCallBack(ATotal, AReceived: Integer;
AMode: TCBBlobCallBackMode);
begin
case AMode of
bcbmStart: Progressbar1.Max := ATotal;
bcbmProgress: ProgressBar1.Value := AReceived;
bcbmEnd: ProgressBar1.Value := ATotal;
end;
end;
Delphi - .....................................
neoturk: ...Showing progress while loading blobs from ib-fb with ibx ?...
uses
Windows, SysUtils, Variants, Classes, Graphics,
IBHeader, IBBlob, IBIntf, IB, IBErrorcodes;
type
TCBBlobCallBackMode = (bcbmStart, bcbmProgress, bcbmEnd);
TCBBlobCallBack = procedure(ATotal, AReceived: Integer;
AMode: TCBBlobCallBackMode) of object;
//------------------------------------------------------------------------------
function cbGetBlobWithCallBack(ABlobID: TISC_Quad;
ADBHandle: PISC_DB_Handle;
ATRHandle: PISC_TR_Handle;
AFileName: string; ACallBack: TCBBlobCallBack): Boolean;
...interface
//------------------------------------------------------------------------------
function cbGetBlobWithCallBack(ABlobID: TISC_Quad;
ADBHandle: PISC_DB_Handle;
ATRHandle: PISC_TR_Handle;
AFileName: string; ACallBack: TCBBlobCallBack): Boolean;
var
LBlobHandle: TISC_BLOB_HANDLE;
LSeg, LSize, LTotal: LongInt;
LType: Short;
LBuffer: PChar;
LCurPos: LongInt;
LBytesRead, LSegLen: Word;
LLocalBuffer: PChar;
LStream: TMemoryStream;
begin
Result := False;
LBlobHandle := nil;
// open the blob file; especially get the BlobHandle
GetGDSLibrary.isc_open_blob2(StatusVector, ADBHandle, ATRHandle,
@LBlobHandle, @ABlobID, 0, nil);
try
// get the informations of the blob;
// segment count, segment size, total size, blob type
IBBlob.GetBlobInfo(@LBlobHandle, LSeg, LSize, LTotal, LType);
// raise the first callback
if Assigned(ACallBack) then
ACallBack(LTotal, 0, bcbmStart);
// assign the variables and allocate memory
LBuffer := nil;
ReallocMem(LBuffer, LTotal);
LLocalBuffer := LBuffer;
LCurPos := 0;
LSegLen := Word(DefaultBlobSegmentSize);
while (LCurPos < LTotal) do
begin
if (LCurPos + LSegLen > LTotal) then
LSegLen := LTotal - LCurPos;
// receive the segments
if not ((GetGDSLibrary.isc_get_segment(StatusVector, @LBlobHandle,
@LBytesRead, LSegLen, LLocalBuffer) = 0) or
(StatusVectorArray[1] = isc_segment)) then
IBDatabaseError;
Inc(LLocalBuffer, LBytesRead);
Inc(LCurPos, LBytesRead);
// raise the callback
if Assigned(ACallBack) then
ACallBack(LTotal, LBytesRead, bcbmProgress);
LBytesRead := 0;
end;
// raise the last callback
if Assigned(ACallBack) then
ACallBack(LTotal, LBytesRead, bcbmEnd);
// save the file
LStream := TMemoryStream.Create;
try
LStream.WriteBuffer(LBuffer ^, LTotal);
LStream.SaveToFile(AFileName);
finally
FreeAndNil(LStream);
end;
finally
// close the blob
GetGDSLibrary.isc_close_blob(StatusVector, @LBlobHandle);
Result := True;
end;
end;
// Beispielaufuf
// Samplecall
// ich habe auf dem Formular eine TISQL-Komponente liegen
// Die TISQL-Komponente habe ich vor dem getBlob mit ExecSQL aufgemacht
// Man kann auch TIBCUstomDataset-Komponenten verwenden
//
// I use an IBSQL component, but it is also possible to use an IBCustomDataset
procedure TTestForm.getBlob(ADestfile: string);
begin
// der aufruf unter verwendung von TIBSQL
// the call with IBSQL
cbGetBlobWithCallBack(IBSQLUpdates.FieldByName('Update_File').AsQuad,
IBSQLUpdates.DBHandle, IBSQLUpdates.TRHandle, ADestFile, blobCallBack);
{// die variante mit TIBDataset
// the alternative with IBCustomDataset
cbGetBlobWithCallBack(IBDSUpdates.Current.ByName('Update_File').AsQuad,
IBUpdates.DBHandle, IBUpdates.TRHandle, ADestFile, blobCallBack);}
end;
// nun noch der Callback
// zu testzwecken habe ich eine Progressbar auf das Formular gelegt
//
// The Callback
// Put a progressbar on you form testing purposes
procedure TTestForm.blobCallBack(ATotal, AReceived: Integer;
AMode: TCBBlobCallBackMode);
begin
case AMode of
bcbmStart: Progressbar1.Max := ATotal;
bcbmProgress: ProgressBar1.Value := AReceived;
bcbmEnd: ProgressBar1.Value := ATotal;
end;
end;
Delphi - .....................................
neoturk: ...Get different background color of dbgrid for odd and even rows [2] ?...
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//source for main form :
//...
uses
// ...
Grids, DBGrids, db
//...
procedure artgrid(Sender: TObject; const Rect: TRect; DataCol: Integer;
Column: TColumn; State: TGridDrawState);
//...
implementation
//...
procedure TForm1.artgrid(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if ((Sender as tdbgrid).DataSource.DataSet.RecNo mod 2) = 0 then
(Sender as tdbgrid).Canvas.Brush.Color := clblue; //or any color
(Sender as tdbgrid).DefaultDrawColumnCell(rect, datacol, column, state);
end;
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// for all DrawColumnCell event of DBGrid in any Form (here "Form2"):
procedure TForm2.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
Form1.artgrid(Sender, Rect, DataCol, Column, State);
end;
Delphi - .....................................
neoturk: ...Get different background color of dbgrid for odd and even rows [2] ?...
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//source for main form :
//...
uses
// ...
Grids, DBGrids, db
//...
procedure artgrid(Sender: TObject; const Rect: TRect; DataCol: Integer;
Column: TColumn; State: TGridDrawState);
//...
implementation
//...
procedure TForm1.artgrid(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if ((Sender as tdbgrid).DataSource.DataSet.RecNo mod 2) = 0 then
(Sender as tdbgrid).Canvas.Brush.Color := clblue; //or any color
(Sender as tdbgrid).DefaultDrawColumnCell(rect, datacol, column, state);
end;
//++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// for all DrawColumnCell event of DBGrid in any Form (here "Form2"):
procedure TForm2.DBGrid2DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
begin
Form1.artgrid(Sender, Rect, DataCol, Column, State);
end;
