procedure لتصدير Dataset نحو Excel

[getsource]

procedure من أجل تصدير ملف قاعدة بيانات إلى ملف إكسل بطريقة لبقة

procedure export_Dataset_to_excel(Dataset :tdataset);
var
//procedure permet de transférer les données d'un dataset ver un fichier excel
// fait par Bendib yassine

XLApp : TexcelApplication;
Classeur : _workbook;
feuille: _worksheet;
i,j,cmt: integer;
Formtmp: TForm;
label1,label2 : TLabel;
St: string[100];

begin
Application.CreateForm(TForm, Formtmp);

With formtmp do
begin
Position := poScreenCenter;
BorderStyle := bsToolWindow;
Width := 400;
Height := 70;
Caption := 'Transfère des données encoure... ';
end;

Label1 :=TLabel.Create(nil) ;
with (label1) do
begin
Name := 'label1';
Caption := 'copie l''enregistrement ';
parent := Formtmp;
Align := alTop;
Font.Size := 16;
Font.Style := [Fsbold];
Alignment := taCenter;
end;

Label2 :=TLabel.Create(nil) ;
with (label2) do
begin
Name := 'label2';
Caption := 'Veuillez Patientez SVP ';
parent := Formtmp;
Align := alBottom;
Font.Size := 12;
Font.Style := [Fsbold];
Font.Color := clred;
Alignment := taCenter;
end;

formtmp.Show;
//--
XLApp := TExcelApplication.Create(Application);
Xlapp.Connect;
Classeur:=XlApp.Workbooks.Add(EmptyParam,0);
Feuille:=Classeur.Worksheets[1] as _worksheet;

// feuille.DisplayRightToLeft[1]:=1; ///activier cette ligne si vous utliser une table contient des données en arabe

Dataset.DisableControls;
Dataset.First;
cmt := 1;
for j := 0 to dataset.FieldCount-1 do
begin
st :=dataset.fields[j].DisplayName;
st :=StringReplace (trim(st),'_',' ',[rfReplaceAll]);
Feuille.Cells.Item[1,1+j].value:= st;
end;
i:=0;
while not dataset.Eof do
begin
for j := 0 to dataset.FieldCount-1 do
Feuille.Cells.Item[2+i,1+j].value:=dataset.fields[j].AsString ;
label1.Caption := 'copie l''enregistrement '+inttostr(cmt) + '/'+inttostr(dataset.recordcount);

Formtmp.Update;
dataset.next;
cmt:= cmt+1;
i:=i+1;

end;
Dataset.EnableControls;
//--
Formtmp.Close;
Formtmp.free;
ShowMessage ('Terminé...');
XLApp.Visible[1]:=true ;
XLApp.Disconnect;
XLApp.free;
end;

[kachwahed]

Unit1.pas(7): File not found: excel97.dcu

[getsource]

ربما أنت تستعمل نسخة دلفي 7

لم أجرب البرنامج على دلفي7 ، جربه على نسخة 5
شكرا

[kachwahed]

السلام عليكم
بارك الله فيك
المشكلة في نسخة Office المستعلمة، أنت استعملت وحدة النسخة excel97 والتي معي في Delphi7 هي ExcelXP.
أيضا غيرت EmptyParam الى EmptyStr.
مع حذف الوحدة Outline فهي غير ضرورية، وكذلك DirOutln وSpin وCalendar وOleServer
الطريقة جميلة وديناميكية، إلا أنها نوعا ما ثقيلة.
شكرا كثيرا.

[henry14]

كيف التعديل بين نسخة office97 و office2k

وشكرا على الكود

[kachwahed]

كيف التعديل بين نسخة office97 و office2k
يتم ذلك أثناء تنصيب نسخة دلفي على الجهاز.

[getsource]

السلام عليكم

تم تحسين الكود إلى الأفضل حيث أصبحت سرعة نقل البيانات سريعة جدا

PROCEDURE ExportDataSetToExcel;(DataSet: Tdataset;Orientation,TitleColor,TitleFontSize,Data FontSize:integer;LineStyle: XlLineStyle);

VAR
XLApp : TexcelApplication;
Classeur : _workbook;
Feuille : _worksheet;
i,j,lin,col : integer;
FormTmp : TForm;
Label1,Label2 : TLabel;
Matrix : Variant;
BookMark : TBookmark;
//----------------------------------------------
FUNCTION AdrsStr(Lin,col:Integer): string;
const T ='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var i,j,x: integer; TT: array[1..729] of string[2];

BEGIN
FOR i:=1 TO 26 DO TT[i]:=T[i];
x:=27;
FOR i:=1 TO 26 DO for j:=1 to 26 do
BEGIN TT[x]:=T[i]+T[j]; x:=x+1; END;
Result:=tt[COL]+inttostr(LIN);
END;
//-------------------------------------------
BEGIN
Application.CreateForm(TForm, Formtmp);
WITH FormTmp DO
BEGIN
Position := poScreenCenter; BorderIcons := [bisystemMenu];
//FormStyle := fsStayOnTop;
Width:=370;Height := 120;
Caption := ' Exporter des données vers Excel ... ';
END;
Label1 :=TLabel.Create(nil);
WITH (label1) DO
BEGIN
Name := 'label1'; Caption := 'copie l''enregistrement ';
parent := Formtmp; Align := altop;
Font.Size := 16; Font.Style := [Fsbold];
Alignment := taCenter; Height := 40;
END;
Label2 :=TLabel.Create(nil);
WITH (label2) DO
BEGIN
Name := 'label2'; Caption := 'Veuillez Patientez SVP ';
parent := Formtmp; Align := altop;
Font.Size := 12; Font.Style := [Fsbold];
Font.Color := clred; Alignment := taCenter; Height := 40;
END;


IF MessageDlg('Etes-vous sûr de vouloir copie cette liste sur une feuille Excel ?', mtConfirmation , mbYesNoCancel ,0) = mryes THEN
BEGIN
FORMTMP.Show;
// Formtmp.Update;
XLApp := TExcelApplication.Create(Application);
TRY
Xlapp.Connect;
EXCEPT
Showmessage('Echec de connection vers Excel...!!!');
Formtmp.Close; Formtmp.free; XLApp.free;
exit;
END;

Classeur := XlApp.Workbooks.Add(EmptyParam,0);
Feuille := Classeur.Worksheets[1] as _worksheet;
lin := dataset.RecordCount+1; // Nombre des lignes dans la source de données "datset"
col := dataset.Fields.Count; // Nombre des champs dans la source de données

// Déclaré un tableau deux dimension Lin X Col Array [lin,col] de type varie
// peut avoir n'importe quelle valeur

matrix := VarArrayCreate([0,lin,0,col], varVariant );

//Orienter la page excel gaucheDroite(0) ou droitegauche(1)

TRY feuille.DisplayRightToLeft[1]:= Orientation; EXCEPT END;
Formtmp.Update;

//Charger l'entete de fichier (nom ou displayName de DataSet

FOR i:=0 TO col-1 DO
matrix[0,i]:= ReplaceStr(dataset.Fields[i].DisplayName,'-_()',' ');;

Dataset.DisableControls; // Désactivé les controls sur dataset pour accélérer le parcour
BookMark := dataset.GetBookmark; // Sauvgarder la postition de pointeur sur l'eneregistrement encoure
dataset.First;
j:=1;
WHILE NOT dataset.Eof DO
BEGIN
// Charger le contenu de l'eneregistrement encoure dans la matrice Matrix

FOR i:=0 TO col-1 DO
TRY matrix[j,i]:=dataset.Fields[i].Value;EXCEPT END;
label1.Caption := 'copie l''eneregistrement '+inttostr(j)+'/'+inttostr(lin-1);
Formtmp.Update;
dataset.next;
j:=j+1;

END;;

// Remplire La feuille excel par le contenu de la matrice Matrix

XLApp.EnableEvents := false;
feuille.Range[AdrsStr(1,1),AdrsStr(lin,col)].value := matrix;

// mise en forme la feuille excel font de titre et le contenu

WITH feuille.Range[AdrsStr(1,1),AdrsStr(1,col)] DO
BEGIN Interior.Color:=titlecolor;Font.Size:=titlefontsiz e;END;
WITH feuille.Range[AdrsStr(1,1),AdrsStr(lin,col)] DO
BEGIN Font.Size:=datafontsize;Borders.LineStyle:=linesty le;END;

XLApp.EnableEvents := true;
dataset.GotoBookmark(BookMark);
Dataset.EnableControls;

Label2.Caption :='Copie des données Terminé...';
ShowMessage('Copie des données Terminé...');

XLApp.Visible[1]:=true ;
TRY
Feuille.Activate(1);
EXCEPT
END;
XLApp.Disconnect;
XLApp.free;
VarClear(Matrix);
formtmp.Close;
Formtmp.free;
END ELSE BEGIN Formtmp.Close;Formtmp.free; END;
END;

[kachwahed]

الإجراء الذي أرفقته يستخدم المكتبة Excel97 وتابع ReplaceStr معرف في إحدى وحداتك الخاصة :)

هنا إجراء لنقل البيانات من TDBGrid إلى Excel باستخدام الوحدة Excel2000 المرفقة مع دلفي:
uses
ComObj, ActiveX, Excel2000; // or Excel97
//Excel2000 can be found in '%ProgramFiles%\Borland\Delphi7\Ocx\Servers'
procedure SendToExcel(aDataSet: TDataSet);
var
PreviewToExcel: TExcelApplication;
RangeE: ExcelRange; //or RangeE: Excel97.Range
I, Row: integer;
Bookmark: TBookmarkStr;
begin
PreviewToExcel := TExcelApplication.Create(nil); //Or TExcelApplication.Create(Application)
PreviewToExcel.Connect;
PreviewToExcel.Workbooks.Add(NULL, 0);
RangeE := PreviewToExcel.ActiveCell;

for I := 0 to aDataSet.Fields.Count - 1 do
begin
RangeE.Value := aDataSet.Fields[I].DisplayLabel;
RangeE := RangeE.Next;
end;

aDataSet.DisableControls;
try
Bookmark := aDataSet.Bookmark;
try
aDataSet.First;
Row := 2;
while not aDataSet.EOF do
begin
//Write down Record As Row in msExcel
RangeE := PreviewToExcel.Range['A' + IntToStr(Row), 'A' + IntToStr(Row)];
for I := 0 to aDataSet.Fields.Count - 1 do
begin
RangeE.Value := aDataSet.Fields[I].AsString;
RangeE := RangeE.Next;
end;
aDataSet.Next;
Inc(Row);
end;
finally
aDataSet.Bookmark := Bookmark;
end;
finally
aDataSet.EnableControls;
end;

//Creating Preview from Range A1..ColumnX
//Calculating ASCII 64 (Character Before "A") With Dataset FieldsCount
//This Method can only handle range A1..Z?, if want to be excel column type
//support, exp "AA"/"IV"
RangeE := PreviewToExcel.Range['A1', chr(64 + aDataSet.Fields.Count) + IntToStr(Row - 1)];

RangeE.AutoFormat(8, NULL, NULL, NULL, NULL, NULL, NULL);
PreviewToExcel.Visible[0] := True;
PreviewToExcel.Disconnect;
end;

في المرفقات مكتبة uExportToExcel للقيام بنفس العمل مع ميزات (التعليقات بالصينية)
أيضا هناك مكون AExport الذي يستخدم AExcel فيه بعض الأخطاء
مثال آخر مشابه هنا:
http://www.delphi3000.com/articles/article_2292.asp?SK=

هناك من يستخدم موزع ADO ويستغني عن OLE:
http://www.swissdelphicenter.ch/torry/printcode.php?id=1427

بالتوفيق.

[kachwahed]

طريقة أخرى للحفظ بصيغة Excel أو Word

uses
ComObj, ActiveX;

procedure SaveToExcelFile(DBGridName: TDBGrid);
var
XLApp: variant;
Sheet: variant;
WordApp, WordDoc, WordParagraph, WordRange, WordTable: variant;
I, J: integer;
SaveDialog: TSaveDialog;
pBookMark: TBookMark;
StrSaveFile: string;
IntFileType: integer;
SltRec, SltCol: integer;
ColIndex, RowIndex: integer;
begin
if DBGridName.DataSource.DataSet.IsEmpty then
begin
MessageBox(Application.Handle, 'There is no data to save!', 'Warning', MB_OK);
Abort;
end;
SaveDialog := TSaveDialog.Create(nil);
SaveDialog.Filter := 'Microsoft Excel files |*.xls|Microsoft Word Document |*.doc ';
SaveDialog.Execute;
IntFileType := SaveDialog.FilterIndex;
StrSaveFile := SaveDialog.FileName;
if Length(StrSaveFile) = 0 then
Exit;
try
Screen.Cursor := crHourGlass;
case IntFileType of
1:
begin
try
XLApp := CreateOleObject('Excel.Application');
XLApp.WorkBooks.Add(-4167);
XLApp.WorkBooks[1].WorkSheets[1].Name := 'Export Data';
Sheet := XLApp.WorkBooks[1].WorkSheets['Export data'];
J := 1;
except
MessageBox(GetActiveWindow,
'Can''t call Microsoft Excel!' + chr(13) + chr(10) +
'Please check whether the installed Mircorsoft Excel.',
'', MB_OK + MB_ICONINFORMATION);
Exit;
end;
with DBGridName.DataSource.DataSet do
begin
pBookMark := GetBookmark;
DisableControls;
for I := 0 to DBGridName.Columns.Count - 1 do
begin
if not DBGridName.Columns[I].Visible then
Continue;
Sheet.Cells[J, I + 1] := dbgridname.Columns[I].Title.Caption;
end;
Inc(J);
First;
while not EOF do
begin
for I := 0 to DBGridName.Columns.Count - 1 do
begin
if not DBGridName.Columns[I].Visible then
Continue;
Sheet.Cells[J, I + 1] :=
Trim(DBGridName.DataSource.DataSet.FieldByName(
DBGridName.Columns[i].FieldName).AsString);
end;
Inc(J);
Next;
end;
GotoBookmark(pBookMark);
FreeBookmark(pBookMark);
EnableControls;
end;
XLApp.activeworkbook.saveas(StrSaveFile);
Application.ProcessMessages;
XLApp.Application.Quit;
end;
2:
begin
try
if VarIsEmpty(WordApp) then
WordApp := CreateOleObject('word.Application');
WordDoc := WordApp.Documents.Add;
WordParagraph := WordApp.ActiveDocument.Paragraphs.Add;
WordRange := WordParagraph.Range;
WordRange.Font.Size := 15;
WordRange.Font.Name := '?? ';
except
MessageBox(GetActiveWindow,
'can not call Mircorsoft Word!' + chr(13) + chr(10) +
'Please check whether the installed Mircorsoft Word.',
'Tips', MB_OK + MB_ICONINFORMATION);
Abort;
end;
SltRec := DBGridName.SelectedRows.Count;
SltCol := 0;
for J := 0 to DBGridName.Columns.Count - 1 do
begin
if DBGridName.Columns[J].Visible then
SltCol := SltCol + 1;
end;

WordRange := WordApp.ActiveDocument.Content;
WordTable := WordApp.ActiveDocument.Tables.Add(
WordRange, SltRec + 1, SltCol);
ColIndex := 1;

for J := 0 to DBGridName.Columns.Count - 1 do
begin
if (not DBGridName.Columns[J].Visible) then
Continue;
WordTable.Cell(1, ColIndex).Range.InsertAfter(
DBGridName.Columns[J].Title.Caption);
ColIndex := ColIndex + 1;
end;

RowIndex := 2;
ColIndex := 1;
with DBGridName.DataSource.DataSet do
begin
First;
pBookMark := GetBookmark;
DisableControls;
while not EOF do
begin
for j := 0 to DBGridName.Columns.Count - 1 do
begin
if (DBGridName.Columns[j].Visible <> False) then
begin
WordTable.Cell(RowIndex, ColIndex).Range.InsertAfter
(DBGridName.DataSource.DataSet.FieldByName(
DBGridName.Columns[j].FieldName).AsString);
ColIndex := ColIndex + 1;
end;
end;
RowIndex := RowIndex + 1;
ColIndex := 1;
Next;
end;
GotoBookmark(pBookMark);
FreeBookmark(pBookMark);
EnableControls;
end;
WordApp.ActiveDocument.SaveAs(StrSaveFile);
Application.ProcessMessages;
WordApp.Application.Quit;
end;
end;
finally
SaveDialog.Free;
Screen.Cursor := crDefault;
end;
end;
هناك مكونات تجارية تقوم بهذا الغرض، منها:
http://www.scalabium.com/sme/