neoturk: ...Save a formula one spreadsheet to a blob field ?...
uses vcf1, dbtables;
procedure SaveSpreadsheet(F1Book: TF1Book);
var
BlobStream: TBlobStream;
MyBlob: HGlobal;
pblob: Pointer;
begin
with Datamodule1.Query1 do
begin
Set8087CW($133f);
try
Application.ProcessMessages;
F1Book.SaveWindowInfo;
MyBlob := GlobalAlloc(GMEM_MOVEABLE, 2000);
try
F1Book.WriteToBlob(MyBlob, 0);
pBlob := globalLock(MyBlob);
try
Blobstream := TBlobStream.Create(TBlobField(FieldByName('QUOTE_BLOB')),
bmWrite);
try
Blobstream.Write(pBlob^, GlobalSize(myBlob));
finally
Blobstream.Free;
end;
finally
globalUnlock(MyBlob);
end;
F1book.IF1Book_Modified := False;
finally
globalFree(myblob);
end;
finally
Set8087CW(Default8087CW);
Application.ProcessMessages;
end;
end;
end;
//Depending on your Delphi Version (<D4), you will need:
//D4 und frühere Versionen brauchen noch:
var
Default8087CW: Word = $1332;
procedure Set8087CW(NewCW: Word);
asm
MOV Default8087CW,AX
FLDCW Default8087CW
end;
Delphi - .....................................
neoturk: ...Remove a dbase index flag ?...
function UnCheckIndex(FileDbf: string): Boolean;
var
Dbf: file;
Car: Char;
begin
Result := T;
AssignFile(Dbf, FileDbf);
Car := #0;
{$I-}
Reset(Dbf, 1);
if not ErrorIO(FileDbf, IoResult) then
begin
Seek(Dbf, 28);
{Flag's position}
if not ErrorIO(FileDbf, IoResult) then
BlockWrite(Dbf, Car, 1, Num_R)
else
Result := F;
CloseFile(Dbf);
if ErrorIO(FileDbf, IoResult) then
Result := F;
end
else
Result := F;
{$I+}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if UnCheckIndex('MyBase.dbf') then
ShowMessage('Flag removed');
end;
Delphi - .....................................
neoturk: ...Remove a dbase index flag ?...
function UnCheckIndex(FileDbf: string): Boolean;
var
Dbf: file;
Car: Char;
begin
Result := T;
AssignFile(Dbf, FileDbf);
Car := #0;
{$I-}
Reset(Dbf, 1);
if not ErrorIO(FileDbf, IoResult) then
begin
Seek(Dbf, 28);
{Flag's position}
if not ErrorIO(FileDbf, IoResult) then
BlockWrite(Dbf, Car, 1, Num_R)
else
Result := F;
CloseFile(Dbf);
if ErrorIO(FileDbf, IoResult) then
Result := F;
end
else
Result := F;
{$I+}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if UnCheckIndex('MyBase.dbf') then
ShowMessage('Flag removed');
end;
Delphi - .....................................
neoturk: ...Pack a table ?...
function dgPackParadoxTable(Tbl: TTable; Db: TDatabase): DBIResult;
{ Packs a Paradox table by calling the BDE DbiDoRestructure
function. The TTable passed as the first parameter must
be closed. The TDatabase passed as the second parameter
must be connected. }
var
TblDesc: CRTblDesc;
begin
Result := DBIERR_NA;
FillChar(TblDesc, SizeOf(CRTblDesc), 0);
StrPCopy(TblDesc.szTblName, Tbl.TableName);
TblDesc.bPack := True;
Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False);
end;
function dgPackDbaseTable(Tbl: TTable): DBIResult;
{ Pack a dBASE table by calling DbiPackTable. The table
passed as a parameter will be opened if it isn't open. }
begin
Result := DBIERR_NA;
if Tbl.Active = False then
Tbl.Open;
Result := DbiPackTable(Tbl.DBHandle, Tbl.Handle,
nil, nil, True);
end;
Delphi - .....................................
neoturk: ...Pack a table ?...
function dgPackParadoxTable(Tbl: TTable; Db: TDatabase): DBIResult;
{ Packs a Paradox table by calling the BDE DbiDoRestructure
function. The TTable passed as the first parameter must
be closed. The TDatabase passed as the second parameter
must be connected. }
var
TblDesc: CRTblDesc;
begin
Result := DBIERR_NA;
FillChar(TblDesc, SizeOf(CRTblDesc), 0);
StrPCopy(TblDesc.szTblName, Tbl.TableName);
TblDesc.bPack := True;
Result := DbiDoRestructure(Db.Handle, 1, @TblDesc, nil, nil, nil, False);
end;
function dgPackDbaseTable(Tbl: TTable): DBIResult;
{ Pack a dBASE table by calling DbiPackTable. The table
passed as a parameter will be opened if it isn't open. }
begin
Result := DBIERR_NA;
if Tbl.Active = False then
Tbl.Open;
Result := DbiPackTable(Tbl.DBHandle, Tbl.Handle,
nil, nil, True);
end;
Delphi - .....................................
neoturk: ...Select all fields in a tdbgrid ?...
function GridSelectAll(Grid: TDBGrid): Longint;
begin
Result := 0;
Grid.SelectedRows.Clear;
with Grid.DataSource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
Grid.SelectedRows.CurrentRowSelected := True;
Inc(Result);
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GridSelectAll(DBGrid1);
end;
Delphi - .....................................
neoturk: ...Select all fields in a tdbgrid ?...
function GridSelectAll(Grid: TDBGrid): Longint;
begin
Result := 0;
Grid.SelectedRows.Clear;
with Grid.DataSource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
Grid.SelectedRows.CurrentRowSelected := True;
Inc(Result);
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GridSelectAll(DBGrid1);
end;
Delphi - .....................................
neoturk: ...Extract the odbc system data sources ?...
uses
Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
n: Integer;
List: TStringList;
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.LazyWrite := False;
Reg.OpenKey('SoftwareODBCODBC.INIODBC Data Sources', False);
List := TStringList.Create;
Reg.GetValueNames(List);
ListBox1.Clear;
for n := 0 to List.Count - 1 do
ListBox1.Items.Add(List.Strings[n]);
Reg.CloseKey;
finally
Reg.Free;
end;
end;
Delphi - .....................................
neoturk: ...Extract the odbc system data sources ?...
uses
Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
n: Integer;
List: TStringList;
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.LazyWrite := False;
Reg.OpenKey('SoftwareODBCODBC.INIODBC Data Sources', False);
List := TStringList.Create;
Reg.GetValueNames(List);
ListBox1.Clear;
for n := 0 to List.Count - 1 do
ListBox1.Items.Add(List.Strings[n]);
Reg.CloseKey;
finally
Reg.Free;
end;
end;
Delphi - .....................................
neoturk: ...Accelerate database searches ?...
type
TForm1 = class(TForm)
DataSource1: TDataSource;
Table1: TTable;
Button1: TButton;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
SeekValue: string;
begin
Table1.DisableControls;
Table1.FindKey([SeekValue]);
Table1.EnableControls;
end;
Delphi - .....................................
neoturk: ...Accelerate database searches ?...
type
TForm1 = class(TForm)
DataSource1: TDataSource;
Table1: TTable;
Button1: TButton;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
SeekValue: string;
begin
Table1.DisableControls;
Table1.FindKey([SeekValue]);
Table1.EnableControls;
end;
Delphi - .....................................
neoturk: ...Check, if the borland database engine [bde] is installed ?...
uses
BDE;
function CheckBDEInstalled: Boolean;
begin
Result := (dbiInit(nil) = DBIERR_NONE)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if CheckBDEInstalled then
ShowMessage('BDE is installed.')
else
ShowMessage('BDE is not installed.')
end;
Delphi - .....................................
neoturk: ...Check, if the borland database engine [bde] is installed ?...
uses
BDE;
function CheckBDEInstalled: Boolean;
begin
Result := (dbiInit(nil) = DBIERR_NONE)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if CheckBDEInstalled then
ShowMessage('BDE is installed.')
else
ShowMessage('BDE is not installed.')
end;
Delphi - .....................................
neoturk: ...Make an adodb connection using ole-automation ?...
uses
ComObj;
function OpenConnection(ConnectionString: AnsiString): Integer;
var
ADODBConnection: OleVariant;
begin
ADODBConnection := CreateOleObject('ADODB.Connection');
ADODBConnection.CursorLocation := 3; // User client
ADODBConnection.ConnectionString := ConnectionString;
Result := 0;
try
ADODBConnection.Open;
except
Result := -1;
end;
end;
function DataBaseConnection_Test(bMessage: Boolean): AnsiString;
var
asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;
iReturn: Integer;
OldCursor: TCursor;
begin
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
asTimeout := '150';
asUserName := 'NT_Server';
asPassword := 'SA';
asDataSource := 'SQL Server - My DataBase';
ConnectionString := 'Data Source = ' + asDataSource +
'User ID = ' + asUserName +
'Password = ' + asPassword +
'Mode = Read|Write;Connect Timeout = ' + asTimeout;
try
iReturn := OpenConnection(ConnectionString);
if (bMessage) then
begin
if (iReturn = 0) then
Application.MessageBox('Connection OK!', 'Information', MB_OK)
else if (iReturn = -1) then
Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK);
end;
if (iReturn = 0) then
Result := ConnectionString
else if (iReturn = -1) then
Result := '';
finally
Screen.Cursor := OldCursor;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DataBaseConnection_Test(True);
end;
Delphi - .....................................
neoturk: ...Make an adodb connection using ole-automation ?...
uses
ComObj;
function OpenConnection(ConnectionString: AnsiString): Integer;
var
ADODBConnection: OleVariant;
begin
ADODBConnection := CreateOleObject('ADODB.Connection');
ADODBConnection.CursorLocation := 3; // User client
ADODBConnection.ConnectionString := ConnectionString;
Result := 0;
try
ADODBConnection.Open;
except
Result := -1;
end;
end;
function DataBaseConnection_Test(bMessage: Boolean): AnsiString;
var
asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;
iReturn: Integer;
OldCursor: TCursor;
begin
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
asTimeout := '150';
asUserName := 'NT_Server';
asPassword := 'SA';
asDataSource := 'SQL Server - My DataBase';
ConnectionString := 'Data Source = ' + asDataSource +
'User ID = ' + asUserName +
'Password = ' + asPassword +
'Mode = Read|Write;Connect Timeout = ' + asTimeout;
try
iReturn := OpenConnection(ConnectionString);
if (bMessage) then
begin
if (iReturn = 0) then
Application.MessageBox('Connection OK!', 'Information', MB_OK)
else if (iReturn = -1) then
Application.MessageBox('Connection Error!', 'Error', MB_ICONERROR + MB_OK);
end;
if (iReturn = 0) then
Result := ConnectionString
else if (iReturn = -1) then
Result := '';
finally
Screen.Cursor := OldCursor;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DataBaseConnection_Test(True);
end;
Delphi - .....................................
neoturk: ...Detect, which version of ado is installed ?...
{
With different versions of MDAC available it is sometimes
useful to know that your application won't fail because a user
hasn't got the latest version installed.
The following function returns the ADO version installed,
you need to place ComObj in the uses clause to use this function.
}
function GetADOVersion: Double;
var
ADO: OLEVariant;
begin
try
ADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(ADO.Version);
ADO := Null;
except
Result := 0.0;
end;
end;
// To use this function try something like:
procedure TForm1.Button1Click(Sender: TObject);
const
ADOVersionNeeded = 2.5;
begin
if GetADOVersion then
ShowMessage('Need to install MDAC version 2.7')
else
ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion]));
end;
Delphi - .....................................
neoturk: ...Detect, which version of ado is installed ?...
{
With different versions of MDAC available it is sometimes
useful to know that your application won't fail because a user
hasn't got the latest version installed.
The following function returns the ADO version installed,
you need to place ComObj in the uses clause to use this function.
}
function GetADOVersion: Double;
var
ADO: OLEVariant;
begin
try
ADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(ADO.Version);
ADO := Null;
except
Result := 0.0;
end;
end;
// To use this function try something like:
procedure TForm1.Button1Click(Sender: TObject);
const
ADOVersionNeeded = 2.5;
begin
if GetADOVersion then
ShowMessage('Need to install MDAC version 2.7')
else
ShowMessage(Format('ADO Version %n, is OK', [GetADOVersion]));
end;
Delphi - .....................................
neoturk: ...Load all records at once into a stringlist ?...
{ Loading millions of records into a stringlist can be very slow }
procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
StringList.Clear;
with SourceTable do
begin
Open;
DisableControls;
try
while not EOF do
begin
StringList.Add(FieldByName('OriginalData').AsString);
Next;
end;
finally
EnableControls;
Close;
end;
end;
end;
{ This is much, much faster }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
with CacheTable do
begin
Open;
try
StringList.Text := FieldByName('Data').AsString;
finally
Close;
end;
end;
end;
{ How can this be done?
In Microsoft SQL Server 7, you can write a stored procedure that updates every night
a cache table that holds all the data you want in a single column and row.
In this example, you get the data from a SourceTable and put it all in a Cachetable.
The CacheTable has one blob column and must have only one row.
Here it is the SQL code: }
Create Table CacheTable
(Data Text NULL)
GO
Create
procedure PopulateCacheTable as
begin
set NOCOUNT on
DECLARE @ptrval binary(16), @Value varchar(600) -
- a good Value for the expected maximum Length
- - You must set 'select into/bulkcopy' option to True in order to run this sp
DECLARE @dbname nvarchar(128)
set @dbname = db_name()
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
- - Declare a cursor
DECLARE scr CURSOR for
SELECT OriginalData + char(13) + char(10) - - each line in a TStringList is
separated by a #13#10
FROM SourceTable
- - The CacheTable Table must have only one record
if EXISTS (SELECT * FROM CacheTable)
Update CacheTable set Data = ''
else
Insert CacheTable VALUES('')
- - Get a Pointer to the field we want to Update
SELECT @ptrval = TEXTPTR(Data) FROM CacheTable
Open scr
FETCH Next FROM scr INTO @Value
while @ @FETCH_STATUS = 0
begin - - This UPDATETEXT appends each Value to the
end
of the blob field
UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
FETCH Next FROM scr INTO @Value
end
Close scr
DEALLOCATE scr
- - Reset this option to False
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO
{ You may need to increase the BLOB SIZE parameter if you use BDE }
Delphi - .....................................
neoturk: ...Load all records at once into a stringlist ?...
{ Loading millions of records into a stringlist can be very slow }
procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
StringList.Clear;
with SourceTable do
begin
Open;
DisableControls;
try
while not EOF do
begin
StringList.Add(FieldByName('OriginalData').AsString);
Next;
end;
finally
EnableControls;
Close;
end;
end;
end;
{ This is much, much faster }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
with CacheTable do
begin
Open;
try
StringList.Text := FieldByName('Data').AsString;
finally
Close;
end;
end;
end;
{ How can this be done?
In Microsoft SQL Server 7, you can write a stored procedure that updates every night
a cache table that holds all the data you want in a single column and row.
In this example, you get the data from a SourceTable and put it all in a Cachetable.
The CacheTable has one blob column and must have only one row.
Here it is the SQL code: }
Create Table CacheTable
(Data Text NULL)
GO
Create
procedure PopulateCacheTable as
begin
set NOCOUNT on
DECLARE @ptrval binary(16), @Value varchar(600) -
- a good Value for the expected maximum Length
- - You must set 'select into/bulkcopy' option to True in order to run this sp
DECLARE @dbname nvarchar(128)
set @dbname = db_name()
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
- - Declare a cursor
DECLARE scr CURSOR for
SELECT OriginalData + char(13) + char(10) - - each line in a TStringList is
separated by a #13#10
FROM SourceTable
- - The CacheTable Table must have only one record
if EXISTS (SELECT * FROM CacheTable)
Update CacheTable set Data = ''
else
Insert CacheTable VALUES('')
- - Get a Pointer to the field we want to Update
SELECT @ptrval = TEXTPTR(Data) FROM CacheTable
Open scr
FETCH Next FROM scr INTO @Value
while @ @FETCH_STATUS = 0
begin - - This UPDATETEXT appends each Value to the
end
of the blob field
UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
FETCH Next FROM scr INTO @Value
end
Close scr
DEALLOCATE scr
- - Reset this option to False
EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO
{ You may need to increase the BLOB SIZE parameter if you use BDE }
Delphi - .....................................
neoturk: ...Move columns in a tdbgrid ?...
type
THackAccess = class(TCustomGrid);
{
THackAccess Is needed because TCustomGrid.MoveColumn is
protected and you can't access it directly.
THackAccess Braucht man, da TCustomGrid.MoveColumn in der
Protected-Sektion steht und nicht direkt darauf zugegriffen werden kann.
}
// In the implementation-Section:
procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer);
begin
THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn);
end;
{Example/ Beispiel}
procedure TForm1.Button1Click(Sender: TObject);
begin
MoveDBGridColumns(DBGrid1, 1, 2)
end;
Delphi - .....................................
neoturk: ...Move columns in a tdbgrid ?...
type
THackAccess = class(TCustomGrid);
{
THackAccess Is needed because TCustomGrid.MoveColumn is
protected and you can't access it directly.
THackAccess Braucht man, da TCustomGrid.MoveColumn in der
Protected-Sektion steht und nicht direkt darauf zugegriffen werden kann.
}
// In the implementation-Section:
procedure MoveDBGridColumns(DBGrid: TDBGrid; FromColumn, ToColumn: Integer);
begin
THackAccess(DBGrid).MoveColumn(FromColumn, ToColumn);
end;
{Example/ Beispiel}
procedure TForm1.Button1Click(Sender: TObject);
begin
MoveDBGridColumns(DBGrid1, 1, 2)
end;
Delphi - .....................................
neoturk: ...Use a database on a shared network ?...
If you use a database (tables) on a shared network,
you can enhance efficiency by setting a number of properties
of the TSession component.
The TSession component manages a database session.
First of all, Session.PrivateDir should be assigned to a local directory,
like C:WINDOWSTEMP (you can do this in the OnCreate event of your DataModule,
for example).
The PrivateDir will contain the result of a local Query
(which is a table in itself), and a local table is of course much faster
than a table on the network (LAN or otherwise).
Second, Session.NetFileDir should be assigned to the same physical value
for every user, like 'X:BORLAND.COMBDE' (this also can be done during
initialisation).
{***}
Um auf eine PARADOX-DB von mehreren Benutzern aus zugreifen zu können,
muss als Grundlage natürlich erst mal die BDE überall installiert sein.
Zuerst soll Session.PrivateDir ein lokales Verzeichnis zugewiesen werden.
(z.B C:WINDOWSTEMP). Dieses Verzeichnis enthält dann die Rückgabedaten aus
einer Abfrage.
Die Datenbanken an sich können dann zentral auf einem Netzlaufwerk
(hier z.B. 'X:BORLAND.COMBDE') abgelegt werden, sodass alle Benutzer
darauf zugreifen können.
Es ist allerdings wichtig, dass SESSION.NETFILEDIR im Programm definiert wird.
procedure TForm1.FormCreate(Sender: TObject);
begin
session.netfiledir:= 'X:BORLAND.COMBDE' ;
end;
Delphi - .....................................
neoturk: ...Use a database on a shared network ?...
If you use a database (tables) on a shared network,
you can enhance efficiency by setting a number of properties
of the TSession component.
The TSession component manages a database session.
First of all, Session.PrivateDir should be assigned to a local directory,
like C:WINDOWSTEMP (you can do this in the OnCreate event of your DataModule,
for example).
The PrivateDir will contain the result of a local Query
(which is a table in itself), and a local table is of course much faster
than a table on the network (LAN or otherwise).
Second, Session.NetFileDir should be assigned to the same physical value
for every user, like 'X:BORLAND.COMBDE' (this also can be done during
initialisation).
{***}
Um auf eine PARADOX-DB von mehreren Benutzern aus zugreifen zu können,
muss als Grundlage natürlich erst mal die BDE überall installiert sein.
Zuerst soll Session.PrivateDir ein lokales Verzeichnis zugewiesen werden.
(z.B C:WINDOWSTEMP). Dieses Verzeichnis enthält dann die Rückgabedaten aus
einer Abfrage.
Die Datenbanken an sich können dann zentral auf einem Netzlaufwerk
(hier z.B. 'X:BORLAND.COMBDE') abgelegt werden, sodass alle Benutzer
darauf zugreifen können.
Es ist allerdings wichtig, dass SESSION.NETFILEDIR im Programm definiert wird.
procedure TForm1.FormCreate(Sender: TObject);
begin
session.netfiledir:= 'X:BORLAND.COMBDE' ;
end;
Delphi - .....................................
neoturk: ...Prevent data corruption ?...
{
Wenn eine Datenbank bzw. eine Tabelle (Paradox oder DBase)
lokal auf einem PC installiert ist und BDE-Einstellung
"LOCAL SHARE" FALSE ist, dann werden Änderungen des Tabelleninhalts
durch die BDE zwischengespeichert.
Diese Daten sind bei einem Chrash weg.
Daher kann es sich empfehlen die Zwischenspeicherung zu umgehen:
If a database or a table is local on a PC installed (Paradox or Dbase)
and the BDE-setting "LOCAL SHARE" is FALSE, then changings are not
stored immediatly but are kept in the memory.
This changings are gone after a chrash.
So it might be better after changing to store the data physically on the disk:
}
uses
BDE;
procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
DbiSaveChanges(Table1.Handle);
end;
Delphi - .....................................
neoturk: ...Prevent data corruption ?...
{
Wenn eine Datenbank bzw. eine Tabelle (Paradox oder DBase)
lokal auf einem PC installiert ist und BDE-Einstellung
"LOCAL SHARE" FALSE ist, dann werden Änderungen des Tabelleninhalts
durch die BDE zwischengespeichert.
Diese Daten sind bei einem Chrash weg.
Daher kann es sich empfehlen die Zwischenspeicherung zu umgehen:
If a database or a table is local on a PC installed (Paradox or Dbase)
and the BDE-setting "LOCAL SHARE" is FALSE, then changings are not
stored immediatly but are kept in the memory.
This changings are gone after a chrash.
So it might be better after changing to store the data physically on the disk:
}
uses
BDE;
procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
DbiSaveChanges(Table1.Handle);
end;
Delphi - .....................................
neoturk: ...Get the installed bde version ?...
uses
BDE;
{Without the Registry:}
procedure TForm1.Button1Click(Sender: TObject);
var
ThisVersion: SYSVersion;
begin
DbiGetSysVersion(ThisVersion);
ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion));
end;
{With the Registry:}
function GetBDEVersion: string;
var
h: hwnd;
ptr: Pointer;
proc: TSYSVerProc;
ver: SYSVersion;
idapi: string;
reg: TRegistry;
begin
try
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('CLSID{FB99D710-18B9-11D0-A4CF-00A024C91936}InProcServer32', False);
idapi := reg.ReadString('');
reg.CloseKey;
finally
reg.Free;
end;
Result := '<BDE Bulunamadi>';
h := LoadLibrary(PChar(idapi));
if h <> 0 then
try
ptr := GetProcAddress(h, 'DbiGetSysVersion');
if ptr <> nil then
begin
proc := ptr;
Proc(Ver);
Result := IntToStr(ver.iVersion);
Insert('.', Result, 2);
end;
finally
FreeLibrary(h);
end;
end;
Delphi - .....................................
neoturk: ...Get the installed bde version ?...
uses
BDE;
{Without the Registry:}
procedure TForm1.Button1Click(Sender: TObject);
var
ThisVersion: SYSVersion;
begin
DbiGetSysVersion(ThisVersion);
ShowMessage('BORLAND DATABASE ENGINE VERSION = ' + IntToStr(ThisVersion.iVersion));
end;
{With the Registry:}
function GetBDEVersion: string;
var
h: hwnd;
ptr: Pointer;
proc: TSYSVerProc;
ver: SYSVersion;
idapi: string;
reg: TRegistry;
begin
try
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('CLSID{FB99D710-18B9-11D0-A4CF-00A024C91936}InProcServer32', False);
idapi := reg.ReadString('');
reg.CloseKey;
finally
reg.Free;
end;
Result := '<BDE Bulunamadi>';
h := LoadLibrary(PChar(idapi));
if h <> 0 then
try
ptr := GetProcAddress(h, 'DbiGetSysVersion');
if ptr <> nil then
begin
proc := ptr;
Proc(Ver);
Result := IntToStr(ver.iVersion);
Insert('.', Result, 2);
end;
finally
FreeLibrary(h);
end;
end;
Delphi - .....................................
neoturk: ...Recover a damaged dbtable ?...
How to recover Data in a damaged Header of DbTables.
(Paradox or Dbase) Tables
If this problem occurs and we have not copies of data.
Paradox can't directly open those damaged Tables so
Paradox can't repair those tables.
solution :
T1: the Damaged Table
1- We Have to create an empty Table (T2.Db or
T2.Dbf) that have the same structure of damaged table
(T1.DB or T1.Dbf).
2- With Dos Prompts or excutable batch File we have to
execute this command:
Copy T2.Db+T1.db T3.Db
or
Copy T2.Dbf+T1.dbf T3.Dbf
3-Finally with paradox browser we can open T3 Table
we have to delete bad records.
and copy t3 to t1 table.
Delphi - .....................................
neoturk: ...Recover a damaged dbtable ?...
How to recover Data in a damaged Header of DbTables.
(Paradox or Dbase) Tables
If this problem occurs and we have not copies of data.
Paradox can't directly open those damaged Tables so
Paradox can't repair those tables.
solution :
T1: the Damaged Table
1- We Have to create an empty Table (T2.Db or
T2.Dbf) that have the same structure of damaged table
(T1.DB or T1.Dbf).
2- With Dos Prompts or excutable batch File we have to
execute this command:
Copy T2.Db+T1.db T3.Db
or
Copy T2.Dbf+T1.dbf T3.Dbf
3-Finally with paradox browser we can open T3 Table
we have to delete bad records.
and copy t3 to t1 table.
Delphi - .....................................
neoturk: ...Export a tdataset to a xml file ?...
{Unit to export a dataset to XML}
unit DS2XML;
interface
uses
Classes, DB;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);
function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.ReadOnly then
Result := Result + ' readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' +
'<DATAPACKET Version="2.0">');
WriteString(Stream, '<METADATA><FIELDS>');
{write th metadata}
with Dataset do
for i := 0 to FieldCount - 1 do
begin
WriteString(Stream, '<FIELD attrname="' +
Fields[i].FieldName +
'" fieldtype=' +
XMLFieldType(Fields[i]) +
'/>');
end;
WriteString(Stream, '</FIELDS>');
WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
WriteString(Stream, '</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;
function GetFieldStr(Field: TField): string;
function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while (Length(Result) < j) do
Result := '0' + Result;
end;
var
Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime:
begin
Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount - 1 do
WriteData(Stream, nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount - 1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.
//Beispiel, Example:
uses DS2XML;
procedure TForm1.Button1Click(Sender: TObject);
begin DatasetToXML(Table1, 'test.xml');
end;
Delphi - .....................................
neoturk: ...Export a tdataset to a xml file ?...
{Unit to export a dataset to XML}
unit DS2XML;
interface
uses
Classes, DB;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);
function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.ReadOnly then
Result := Result + ' readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' +
'<DATAPACKET Version="2.0">');
WriteString(Stream, '<METADATA><FIELDS>');
{write th metadata}
with Dataset do
for i := 0 to FieldCount - 1 do
begin
WriteString(Stream, '<FIELD attrname="' +
Fields[i].FieldName +
'" fieldtype=' +
XMLFieldType(Fields[i]) +
'/>');
end;
WriteString(Stream, '</FIELDS>');
WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
WriteString(Stream, '</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;
function GetFieldStr(Field: TField): string;
function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while (Length(Result) < j) do
Result := '0' + Result;
end;
var
Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime:
begin
Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount - 1 do
WriteData(Stream, nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount - 1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.
//Beispiel, Example:
uses DS2XML;
procedure TForm1.Button1Click(Sender: TObject);
begin DatasetToXML(Table1, 'test.xml');
end;
Delphi - .....................................
neoturk: ...Convert tdatetime to unix timestamp ?...
{
Sometimes you want to communicate with mySQL or other databases using
the unix timestamp. To solve this difference you may want to convert your
TDateTime to the unix timestamp format and vice versa.
Um den in einigen Datenbanken verwendeten Unix Timestamp für die Kommunikation
mit Delphi nutzbar zu machen, kann man mit dieser Unit das TDateTime Format
in den Unix Timestamp und umgekehrt umwandeln.
}
unit unix_utils;
interface
implementation
const
// Sets UnixStartDate to TDateTime of 01/01/1970
UnixStartDate: TDateTime = 25569.0;
function DateTimeToUnix(ConvDate: TDateTime): Longint;
begin
//example: DateTimeToUnix(now);
Result := Round((ConvDate - UnixStartDate) * 86400);
end;
function UnixToDateTime(USec: Longint): TDateTime;
begin
//Example: UnixToDateTime(1003187418);
Result := (Usec / 86400) + UnixStartDate;
end;
end.
Delphi - .....................................
neoturk: ...Convert tdatetime to unix timestamp ?...
{
Sometimes you want to communicate with mySQL or other databases using
the unix timestamp. To solve this difference you may want to convert your
TDateTime to the unix timestamp format and vice versa.
Um den in einigen Datenbanken verwendeten Unix Timestamp für die Kommunikation
mit Delphi nutzbar zu machen, kann man mit dieser Unit das TDateTime Format
in den Unix Timestamp und umgekehrt umwandeln.
}
unit unix_utils;
interface
implementation
const
// Sets UnixStartDate to TDateTime of 01/01/1970
UnixStartDate: TDateTime = 25569.0;
function DateTimeToUnix(ConvDate: TDateTime): Longint;
begin
//example: DateTimeToUnix(now);
Result := Round((ConvDate - UnixStartDate) * 86400);
end;
function UnixToDateTime(USec: Longint): TDateTime;
begin
//Example: UnixToDateTime(1003187418);
Result := (Usec / 86400) + UnixStartDate;
end;
end.
Delphi - .....................................
neoturk: ...Color a tdbgrid ?...
// Function to color a DBGrid (declared as private)
// Funktion zum Einfärben des DBGrids (als private deklariert)
procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
iValue: LongInt;
begin
// color only the first field
// nur erstes Feld einfärben
if (DataCol = 0) then
begin
// Check the field value and assign a color
// Feld-Wert prüfen und entsprechende Farbe wählen
iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
case iValue of
1: dbgIn.Canvas.Brush.Color := clGreen;
2: dbgIn.Canvas.Brush.Color := clLime;
3: dbgIn.Canvas.Brush.Color := clYellow;
4: dbgIn.Canvas.Brush.Color := clRed;
end;
// Draw the field
// Feld zeichnen
dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
end;
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;
Delphi - .....................................
neoturk: ...Color a tdbgrid ?...
// Function to color a DBGrid (declared as private)
// Funktion zum Einfärben des DBGrids (als private deklariert)
procedure TForm1.ColorGrid(dbgIn: TDBGrid; qryIn: TQuery; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
iValue: LongInt;
begin
// color only the first field
// nur erstes Feld einfärben
if (DataCol = 0) then
begin
// Check the field value and assign a color
// Feld-Wert prüfen und entsprechende Farbe wählen
iValue := qryIn.FieldByName('HINWEIS_COLOR').AsInteger;
case iValue of
1: dbgIn.Canvas.Brush.Color := clGreen;
2: dbgIn.Canvas.Brush.Color := clLime;
3: dbgIn.Canvas.Brush.Color := clYellow;
4: dbgIn.Canvas.Brush.Color := clRed;
end;
// Draw the field
// Feld zeichnen
dbgIn.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
end;
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
ColorGrid(DBGrid1, Query1, Rect, DataCol, Column, State);
end;
Delphi - .....................................
neoturk: ...Create objects without worrying of destroying ?...
type
ISelfDestroy = interface;
//forget about GUID, if you are not using COM
TSelfDestroy = class(TInterfacedObject, ISelfDestroy)
private
FObject: TObject;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
implementation
constructor TSelfDestroy.Create(AObject: TObject);
begin
FObject := AObject;
end;
destructor TSelfDestroy.Destroy;
begin
FreeAndNil(FObject);
inherited;
end;
// So when you use, just do like this...
procedure TForm1.Button1Click(Sender: TObject);
var
MyObject: TMyObject;
SelfDestroy: TSelfDestroy;
begin
MyObject := TMyObject.Create;
SelfDestroy := TSelfDestroy.Create(MyObject);
// The MyObject will free automatically as soon as TSelfDestroy
// goes out of scope.
// Carry on your code here...
end;
Delphi - .....................................
neoturk: ...Create objects without worrying of destroying ?...
type
ISelfDestroy = interface;
//forget about GUID, if you are not using COM
TSelfDestroy = class(TInterfacedObject, ISelfDestroy)
private
FObject: TObject;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
implementation
constructor TSelfDestroy.Create(AObject: TObject);
begin
FObject := AObject;
end;
destructor TSelfDestroy.Destroy;
begin
FreeAndNil(FObject);
inherited;
end;
// So when you use, just do like this...
procedure TForm1.Button1Click(Sender: TObject);
var
MyObject: TMyObject;
SelfDestroy: TSelfDestroy;
begin
MyObject := TMyObject.Create;
SelfDestroy := TSelfDestroy.Create(MyObject);
// The MyObject will free automatically as soon as TSelfDestroy
// goes out of scope.
// Carry on your code here...
end;
Delphi - .....................................
neoturk: ...Process selected rows in a tdbgrid ?...
{
In the "Object Inspector" set your DBGrid's Option for dgMultiSelect = True.
The Grid_Edit function calls for each selected DBGrid-Row a data-processing
function.
Return value is the number of processed rows.
Im Objektinspektor unter Options des DBGrids die Option "dgMultiSelect"
auf TRUE setzen.
Ruft zu jeder markierten DBGrid-Zeile eine Bearbeitungs-Funktion auf
Rückgabewert = Anzahl bearbeiteter Zeilen
}
function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint;
// declared in the private section
// als private deklariert
begin
Result := 0;
with dbgIn.DataSource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
if (dbgIn.SelectedRows.CurrentRowSelected = True) then
begin
{ +++ Call here the data-processing function +++
+++ HIER DIE BEARBEITUNGS_FKT AUFRUFEN +++
zb. iValue := qryIn.FieldByName('FELDNAME').AsInteger;
und so weiter...
}
Inc(Result);
end;
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Caption := 'Processed: ' + IntToStr(Grid_Edit(DBGrid1, Query1));
end;
Delphi - .....................................
neoturk: ...Process selected rows in a tdbgrid ?...
{
In the "Object Inspector" set your DBGrid's Option for dgMultiSelect = True.
The Grid_Edit function calls for each selected DBGrid-Row a data-processing
function.
Return value is the number of processed rows.
Im Objektinspektor unter Options des DBGrids die Option "dgMultiSelect"
auf TRUE setzen.
Ruft zu jeder markierten DBGrid-Zeile eine Bearbeitungs-Funktion auf
Rückgabewert = Anzahl bearbeiteter Zeilen
}
function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint;
// declared in the private section
// als private deklariert
begin
Result := 0;
with dbgIn.DataSource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
if (dbgIn.SelectedRows.CurrentRowSelected = True) then
begin
{ +++ Call here the data-processing function +++
+++ HIER DIE BEARBEITUNGS_FKT AUFRUFEN +++
zb. iValue := qryIn.FieldByName('FELDNAME').AsInteger;
und so weiter...
}
Inc(Result);
end;
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Caption := 'Processed: ' + IntToStr(Grid_Edit(DBGrid1, Query1));
end;
