موضوع: نکات برنامه نویسی در دلفی ‏

کد:
uses
ComObj;

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

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

try

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


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

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

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

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

end;

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

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

کد:
unit ExportADOTable;

interface

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

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

//Export procedures
//"FiledNames" is a comma separated list of the names of the fields you want to export
//"FileName" is the name of the output file (including the complete path)
//if the dataset is filtered (Filtered = true and Filter <> ''), then I append
//the filter string to the sql command in the "where" directive
//if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the
//"order by" directive

procedure ExportToExcel(FieldNames: string; FileName: string;
SheetName: string; IsamFormat: string);
procedure ExportToHtml(FieldNames: string; FileName: string);
procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string);
procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string);
procedure ExportToTxt(FieldNames: string; FileName: string);
published
{ Published declarations }
end;

procedure Register;

implementation

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

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

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


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

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

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

IsamFormat := 'HTML Export';

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


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

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

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

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

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

IsamFormat := 'Text';

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

end.

کد:
unit DBGridExportToExcel;

interface

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


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

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


implementation

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

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

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

//This is the procedure which make the work:

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

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

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


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

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

ADOQuery.Close;
ADOConnection.Close;

ADOQuery.Free;
ADOConnection.Free;

end;

end;

end.

کد:
A:
This Technical Information document will help step thru concepts regarding
the creation and use of ALIASES within your Delphi Applications.

Typically, you use the BDE Configuration Utility BDECFG.EXE to create and
configure aliases outside of Delphi. However, with the use of the TDatabase
component, you have the ability to create and use this ALIAS within your
application-- not pre-defined in the IDAPI.CFG.

The ability to create Aliases that are only available within your
application is important. Aliases specify the location of database tables
and connection parameters for database servers.
Ultimately, you can gain the advantages of using ALIASES within your
applications-- without having to worry about the existance of a
configuration entry in the IDAPI.CFG when you deploy your
application. }

{Summary of Examples:}
{Example #1:}
{Example #1 creates and configures an Alias to use
STANDARD (.DB, .DBF) databases. The Alias is
then used by a TTable component.}
{Example #2:}
{Example #2 creates and configures an Alias to use
an INTERBASE database (.gdb). The Alias is then
used by a TQuery component to join two tables of
the database.}
{Example #3:}
{Example #3 creates and configures an Alias to use
STANDARD (.DB, .DBF) databases. This example
demonstrates how user input can be used to
configure the Alias during run-time.}


{Example #1: Use of a .DB or .DBF database (STANDARD)}

{1. Create a New Project.

2. Place the following components on the form: - TDatabase, TTable,
TDataSource, TDBGrid, and TButton.

3. Double-click on the TDatabase component or choose Database Editor from
the TDatabase SpeedMenu to launch the Database Property editor.

4. Set the Database Name to 'MyNewAlias'. This name will serve as your
ALIAS name used in the DatabaseName Property for dataset components such as
TTable, TQuery, TStoredProc.

5. Select STANDARD as the Driveer Name.

6. Click on the Defaults Button. This will automatically add a PATH= in
the Parameter Overrides section.

7. Set the PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA)

8. Click the OK button to close the Database Dialog.

9. Set the TTable DatabaseName Property to 'MyNewAlias'.

10. Set the TDataSource's DataSet Property to 'Table1'.

11. Set the DBGrid's DataSource Property to 'DataSource1'.

12. Place the following code inside of the TButton's OnClick event.}

procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
end;

{13. Run the application.}


{*** If you want an alternative way to steps 3 - 11, place the following
code inside of the TButton's OnClick event.}

procedure TForm1.Button1Click(Sender: TObject);
begin
Database1.DatabaseName := 'MyNewAlias';
Database1.DriverName := 'STANDARD';
Database1.Params.Clear;
Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA');
Table1.DatabaseName := 'MyNewAlias';
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
DataSource1.DataSet := Table1;
DBGrid1.DataSource := DataSource1;
end;

{Example #2: Use of a INTERBASE database}

{1. Create a New Project.

2. Place the following components on the form: - TDatabase, TQuery,
TDataSource, TDBGrid, and TButton.

3. Double-click on the TDatabase component or choose Database Editor from
the TDatabase SpeedMenu to launch the Database Property editor.

4. Set the Database Name to 'MyNewAlias'. This name will serve as your
ALIAS name used in the DatabaseName Property for dataset components such as
TTable, TQuery, TStoredProc.

5. Select INTRBASE as the Driver Name.

6. Click on the Defaults Button. This will automatically add the
following entries in the Parameter Overrides section.

SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB
USER NAME=MYNAME
OPEN MODE=READ/WRITE
SCHEMA CACHE SIZE=8
LANGDRIVER=
SQLQRYMODE=
SQLPASSTHRU MODE=NOT SHARED
SCHEMA CACHE TIME=-1
PASSWORD=

7. Set the following parameters

SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB
USER NAME=SYSDBA
OPEN MODE=READ/WRITE
SCHEMA CACHE SIZE=8
LANGDRIVER=
SQLQRYMODE=
SQLPASSTHRU MODE=NOT SHARED
SCHEMA CACHE TIME=-1
PASSWORD=masterkey

8. Set the TDatabase LoginPrompt Property to 'False'. If you supply the
PASSWORD in the Parameter Overrides section and set the LoginPrompt to
'False', you will not be prompted for the
password when connecting to the database. WARNING: If an incorrect
password in entered in the Parameter Overrides section and LoginPrompt is
set to 'False', you are not prompted by the Password dialog to re-enter a
valid password.

9. Click the OK button to close the Database Dialog.

10. Set the TQuery DatabaseName Property to 'MyNewAliias'.

11. Set the TDataSource's DataSet Property to 'Query1'.

12. Set the DBGrid's DataSource Property to 'DataSource1'.

13. Place the following code inside of the TButton's OnClick event.}

procedure TForm1.Button1Click(Sender: TObject);
begin
Query1.SQL.Clear;
Query1.SQL.Add('SELECT DISTINCT * FROM CUSTOMER C, SALES S
WHERE(S.CUST_NO = C.CUST_NO)
ORDER BY C.CUST_NO, C.CUSTOMER');
Query1.Active := True;
end;

{14. Run the application.}


{Example #3: User-defined Alias Configuration}

{This example brings up a input dialog and prompts the user to enter the
directory to which the ALIAS is to be configured to.

The directory, servername, path, database name, and other neccessary Alias
parameters can be read into the application from use of an input dialog or
.INI file.

1. Follow the steps (1-11) in Example #1.

2. Place the following code inside of the TButton's OnClick event.}

procedure TForm1.Buttton1Click(Sender: TObject);
var
NewString: string;
ClickedOK: Boolean;
begin
NewString := 'C:\';
ClickedOK := InputQuery('Database Path',
'Path: --> C:\DELPHI\DEMOS\DATA', NewString);
if ClickedOK then
begin
Database1.DatabaseName := 'MyNewAlias';
Database1.DriverName := 'STANDARD';
Database1.Params.Clear;
Database1.Params.Add('Path=' + NewString);
Table1.DatabaseName := 'MyNewAlias';
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
DataSource1.DataSet := Table1;
DBGrid1.DataSource := DataSource1;
end;
end;

//3. Run the Application

کد:
unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type
TInMemoryTable = class(TTable)
private
hCursor: hDBICur;
procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
const Name: string; DataType: TFieldType; Size: Word);
function CreateHandle: HDBICur; override;
public
procedure CreateTable;
end;

implementation

{
Luckely this function is virtual - so I could override it. In the
original VCL code for TTable this function actually opens the table -
but since we already have the handle to the table - we just return it
}

function TInMemoryTable.CreateHandle;
begin
Result := hCursor;
end;

{
This function is cut-and-pasted from the VCL source code. I had to do
this because it is declared private in the TTable component so I had no
access to it from here.
}

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
const Name: string; DataType: TFieldType; Size: Word);
const
TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16,
fldINT32, fldUINT16, fldBOOL,
fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
with FieldDesc do
begin
AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
iFldType := TypeMap[DataType];
case DataType of
ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
iUnits1 := Size;
ftBCD:
begin
iUnits1 := 32;
iUnits2 := Size;
end;
end;
case DataType of
ftCurrency:
iSubType := fldstMONEY;
ftBlob:
iSubType := fldstBINARY;
ftMemo:
iSubType := fldstMEMO;
ftGraphic:
iSubType := fldstGRAPHIC;
end;
end;
end;

{
This is where all the fun happens. I copied this function from the VCL
source and then changed it to use DbiCreateInMemoryTable instead of
DbiCreateTable.

Since InMemory tables do not support Indexes - I took all of the
index-related things out
}

procedure TInMemoryTable.CreateTable;
var
I: Integer;
pFieldDesc: pFLDDesc;
szTblName: DBITBLNAME;
iFields: Word;
Dogs: pfldDesc;
begin
CheckInactive;
if FieldDefs.Count = 0 then
for I := 0 to FieldCount - 1 do
with Fields[I] do
if not Calculated then
FieldDefs.Add(FieldName, DataType, Size, Required);
pFieldDesc := nil;
SetDBFlag(dbfTable, True);
try
AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
iFields := FieldDefs.Count;
pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
for I := 0 to FieldDefs.Count - 1 do
with FieldDefs[I] do
begin
EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,
DataType, Size);
end;
{ the driver type is nil = logical fields }
Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
nil, nil, pFieldDesc));
{ here we go - this is where hCursor gets its value }
Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
finally
if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
SetDBFlag(dbfTable, False);
end;
end;

end.

کد:
procedure TForm1.Button1Click(Sender: TObject);
begin
with Query1 do
begin
DatabaseName := 'DBDemos';
with SQL do
begin
Clear;
{
CREATE TABLE creates a table with the given name in the
current database

CREATE TABLE erzeugt eine Tabelle mit einem angegebenen
Namen in der aktuellen Datenbank
}
Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
Add('Name CHAR(255),');
Add('PRIMARY KEY(ID))');
{
Call ExecSQL to execute the SQL statement currently
assigned to the SQL property.

Mit ExecSQL wird die Anweisung ausgeführt,
welche aktuell in der Eigenschaft SQL enthalten ist.
}
ExecSQL;
Clear;
Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
ExecSQL;
end;
end;
end;

کد:
procedure TVCLScanner.PostUser(const Email, FirstName, LastName: WideString);
var
Connection: TSQLConnection;
DataSet: TSQLDataSet;
begin
Connection := TSQLConnection.Create(nil);
with Connection do
begin
ConnectionName := 'VCLScanner';
DriverName := 'INTERBASE';
LibraryName := 'dbexpint.dll';
VendorLib := 'GDS32.DLL';
GetDriverFunc := 'getSQLDriverINTERBASE';
Params.Add('User_Name=SYSDBA');
Params.Add('Password=masterkey');
Params.Add('Database=milo2:\frank\webservices\um lbank.gdb');
LoginPrompt := False;
Open;
end;
DataSet := TSQLDataSet.Create(nil);
with DataSet do
begin
SQLConnection := Connection;
CommandText := Format('INSERT INTO kings VALUES("%s","%s","%s")',
[Email, FirstN, LastN]);
try
ExecSQL;
except
end;
end;
Connection.Close;
DataSet.Free;
Connection.Free;
end;

کد:
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;

کد:
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').AsStrin g);
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

کد:
Procedure BreakMoreMenu(fSubMenu:TmenuItem;
fMode:TMenuBreak=mbBarBreak);
var
fMnuHeight:Integer;
ScrHeight:Integer;
Count:integer;
i:integer;
items:integer;
begin
fMnuHeight:=GetSystemMetrics(SM_CYMENU);
If fMnuHeight<1 then
fMnuHeight:=4
else
fMnuHeight:=fMnuHeight+3;
ScrHeight:=(screen.Height)-(fMnuHeight *5) ;
Count:=(ScrHeight div fMnuHeight);//Menus in screen
items:=0;
for i:=0 to fSubMenu.Count-1 do begin
If items>=Count then begin
fSubMenu.Items[i].Break:=fMode;
items:=0;
end;
items:=items+1;
end;
end;

کد:
procedure AngleTextOut(Acanvas:Tcanvas;Angle,x,y:integer;Str :String);
var
LogRec:TLogFont;
OldFontHandle,
NewFontHandle:Hfont;
begin
GetObject(Acanvas.Font.Handle,SizeOf(LogRec),Addr( LogRec));
LogRec.lfEscapement:=Angle*10;
NewFontHandle:=CreateFontIndirect(logRec);
OldFontHandle:=SelectObject(Acanvas.handle,NewFont Handle);
ACanvas.TextOut(x,y,Str);
NewFontHandle:=SelectObject(Acanvas.handle,OldFont Handle);
DeleteObject(NewFontHandle);
end;

اصلاح شد: با نام فایل هایی که فاصله داشتن مشکل داشت!

کد:
function FindFile(Path,Files:String):TStrings;
Var
Dirs,Fill:String;
IO,len,i:Integer;
Search:TsearchRec;
Begin
Result:=TStringList.Create;
If Path='' then exit;
//While Pos(';',files)>0 do
// Files[Pos(';',Files)]:=' '; //****
Dirs:='';
If Path[Length(Path)]='\' then
Delete(path,length(path),1);
Repeat
I:=Length(Files);
Repeat
Fill:='';
While (I>0) and (files[I]<>';') do //' ') do //******
Begin
Fill:=files[I]+Fill;
I:=i-1;
end;
I:=i-1;
IO:=findFirst(path+'\'+fill,faAnyFile-faDirectory,Search);
While Io=0 do
Begin
If (search.Name<>'.') and (search.name<>'..') then
Result.Add(path+'\'+Search.name);
IO:=FindNext(Search);
end;
FindClose(search);
until I<1;
IO:=FindFirst(Path+'\*.*',faAnyFile,Search);
While IO=0 do
Begin
If (search.Name<>'.') and (search.name<>'..') and (search.Attr and FaDirectory>0) then
Dirs:=Dirs+Path+'\'+Search.Name+#13;
Io:=FindNext(search);
end;
FindClose(search);
Len:=length(Dirs)-1;
Io:=len;
If Len>0 then
Begin
While (IO>0) and (Dirs[IO]<>#13) do Io:=IO-1;
Path:=Copy(Dirs,IO+1,Len-IO);
SetLength(Dirs,IO);
end;
Until(len<0);
end;

کد:
const
TH32CS_SNAPPROCESS = $00000002;
SYNCHRONIZE = $00100000;
PROCESS_TERMINATE = $0001;

type
TProcessEntry32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;

function CreateToolhelp32Snapshot (dwFlags, th32ProcessID: DWORD):THandle stdcall;external kernel32 name 'CreateToolhelp32Snapshot';
function Process32First(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32First';
function Process32Next(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL stdcall;external kernel32 name 'Process32Next';
function OpenProcess(dwDesiredAccess: DWORD; bInheritHandle: BOOL;dwProcessId: DWORD): THandle; stdcall;external kernel32 name'OpenProcess';
function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall;external kernel32 name 'TerminateProcess';

Function FindInProcess(name:string;SearchInOther:Boolean;var FileName:string):THandle;
var
fData: TProcessEntry32;
fHandler: THandle;
fFileN:string;

Function SearchProcess:THandle;
begin
fFileN:=fData.szExeFile;
fFileN:=extractFileName(fFileN);
result:=0;
name:=LowerCase(name);
fFileN:=LowerCase(fFileN);
If name=fFileN then
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID)
else
If SearchInOther then
If pos(name,fFileN)<>0 then
Result:=OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False,fData.th32ProcessID);
If Result<>0 then
FileName:=fData.szExeFile ;
//result:=fData.th32ProcessID;
end;

begin
fData.dwSize := SizeOf(fData);
fHandler := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
result:=0;
FileName:='';
try
if Process32First(fHandler, fData) then
begin
result:=SearchProcess;
If result<>0 then exit;

while Process32Next(fHandler, fData) do
begin
result:=SearchProcess;
If result<>0 then exit;
end;
end;
finally
CloseHandle(fHandler);
end;

end;

کد:
procedure TranparentForm(Form:Tform;HaveCaption,HaveMenu:Boolean);
var
frmRegion,
tempRegion:HRGN;
i:Integer;
Arect:Trect;
begin
frmRegion:=0;
For i:=0 to Form.controlcount -1 do
begin
Arect:=Form.controls[i].BoundsRect;
Offsetrect(Arect,Form.ClientOrigin.x-Form.left,Form.ClientOrigin.y-Form.top);
tempRegion:=CreateRectRgnIndirect(Arect);
if frmRegion=0 then
begin
frmRegion:=tempRegion;
end
else
Begin
CombineRgn(frmRegion,frmRegion,TempRegion,RGN_OR);
DeleteObject(tempRegion);
end;
end;
tempRegion:=0;
If HaveCaption and HaveMenu then
tempRegion:= CreateRectRgn(0,0,Form.Width,
GetSystemMetrics(SM_CYCAPTION)+
GetSystemMetrics(SM_CYSIZEFRAME)+
GetSystemMetrics(SM_CYMENU)*ORD(Form.Menu<>nil));
If (HaveCaption=false) and HaveMenu then
tempRegion:= CreateRectRgn(0,GetSystemMetrics(SM_CYCAPTION)+GetSystemMetrics( SM_CYSIZEFRAmE),Form.Width,
(GetSystemMetrics(SM_CYSIZEFRAmE)+GetSystemMetrics(SM_CYMENU)*OR D(Form.Menu<>nil))+GetSystemMetrics(SM_CYCAPTION));
If HaveCaption and (HaveMenu=false) then
tempRegion:= CreateRectRgn(0,0,Form.Width,
GetSystemMetrics(SM_CYCAPTION)+
GetSystemMetrics(SM_CYSIZEFRAmE));
If (HaveCaption=false) and (HaveMenu=false) then
tempRegion:= CreateRectRgn(0,0,Form.Width,0);

CombineRgn(frmregion,frmregion,tempregion,rgn_or);
Deleteobject(tempregion);
setwindowrgn(Form.handle,frmregion,true);
end;