+- delphi4arab منتديات دلفي للعرب (https://delphi4arab.net/forum)
+-- قسم : منتديات دلفي للعرب التعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=3)
+--- قسم : مصادر دلفي مفتوحة تعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=14)
+--- الموضوع : procedure لتصدير Dataset نحو Excel (/showthread.php?tid=1046)
procedure لتصدير Dataset نحو Excel - getsource - 12-07-2009
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;procedure لتصدير Dataset نحو Excel - kachwahed - 12-07-2009
Unit1.pas(7): File not found: excel97.dcu
procedure لتصدير Dataset نحو Excel - getsource - 12-07-2009
ربما أنت تستعمل نسخة دلفي 7
لم أجرب البرنامج على دلفي7 ، جربه على نسخة 5
شكرا
procedure لتصدير Dataset نحو Excel - kachwahed - 12-07-2009
السلام عليكم
بارك الله فيك
المشكلة في نسخة Office المستعلمة، أنت استعملت وحدة النسخة excel97 والتي معي في Delphi7 هي ExcelXP.
أيضا غيرت EmptyParam الى EmptyStr.
مع حذف الوحدة Outline فهي غير ضرورية، وكذلك DirOutln وSpin وCalendar وOleServer
الطريقة جميلة وديناميكية، إلا أنها نوعا ما ثقيلة.
شكرا كثيرا.
procedure لتصدير Dataset نحو Excel - henry14 - 27-03-2010
كيف التعديل بين نسخة office97 و office2k
وشكرا على الكود
procedure لتصدير Dataset نحو Excel - kachwahed - 27-03-2010
إقتباس :كيف التعديل بين نسخة office97 و office2kيتم ذلك أثناء تنصيب نسخة دلفي على الجهاز.
procedure لتصدير Dataset نحو Excel - getsource - 18-07-2010
السلام عليكم
تم تحسين الكود إلى الأفضل حيث أصبحت سرعة نقل البيانات سريعة جدا
كود :
PROCEDURE ExportDataSetToExcel;(DataSet: Tdataset;Orientation,TitleColor,TitleFontSize,DataFontSize: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:=titlefontsize;END;
WITH feuille.Range[AdrsStr(1,1),AdrsStr(lin,col)] DO
BEGIN Font.Size:=datafontsize;Borders.LineStyle:=linestyle;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;procedure لتصدير Dataset نحو Excel - kachwahed - 18-07-2010
الإجراء الذي أرفقته يستخدم المكتبة 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;أيضا هناك مكون AExport الذي يستخدم AExcel فيه بعض الأخطاء
مثال آخر مشابه هنا:
كود :
http://www.delphi3000.com/articles/article_2292.asp?SK=هناك من يستخدم موزع ADO ويستغني عن OLE:
كود :
http://www.swissdelphicenter.ch/torry/printcode.php?id=1427بالتوفيق.
procedure لتصدير Dataset نحو Excel - kachwahed - 18-07-2010
طريقة أخرى للحفظ بصيغة 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/RE: procedure لتصدير Dataset نحو Excel - أبو معاذ - 05-02-2019
(18-07-2010, 09:30 PM)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/
رائعة ،
جزاك الله خيرا.