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
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);
السلام عليكم
بارك الله فيك
المشكلة في نسخة Office المستعلمة، أنت استعملت وحدة النسخة excel97 والتي معي في Delphi7 هي ExcelXP.
أيضا غيرت EmptyParam الى EmptyStr.
مع حذف الوحدة Outline فهي غير ضرورية، وكذلك DirOutln وSpin وCalendar وOleServer
الطريقة جميلة وديناميكية، إلا أنها نوعا ما ثقيلة.
شكرا كثيرا.
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
//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
// 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;
18-07-2010, 07:53 PM (آخر تعديل لهذه المشاركة: 10-12-2010, 07:35 AM بواسطة 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)];
في المرفقات مكتبة uExportToExcel للقيام بنفس العمل مع ميزات (التعليقات بالصينية)
أيضا هناك مكون AExport الذي يستخدم AExcel فيه بعض الأخطاء
مثال آخر مشابه هنا:
18-07-2010, 09:30 PM (آخر تعديل لهذه المشاركة: 10-12-2010, 07:36 AM بواسطة 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;
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;
(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;
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/
رائعة ،
جزاك الله خيرا.
اللهم اجعلني من أهل القرآن ، الذين هم أهلك و خاصتك. تذكر بأن الوقت الذي تلهو فيه ، غيرك يبني مجده فيه.
![[-]](https://delphi4arab.net/forum/D4A2020/collapse.png)
