procedure لتصدير Dataset نحو Excel
#1
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;


الملفات المرفقة
.rar   Delphi_export_dataset_to_excel.rar (الحجم : 8.71 KB / التحميلات : 796)
[-] كل من 1 user says قال شكرا ل getsource على المشاركة المفيدة
  • أبو معاذ
الرد
#2
Unit1.pas(7): File not found: excel97.dcu
الرد
#3
ربما أنت تستعمل نسخة دلفي 7

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

وشكرا على الكود
الرد
#6
إقتباس :كيف التعديل بين نسخة office97 و office2k
يتم ذلك أثناء تنصيب نسخة دلفي على الجهاز.
اللهم احقن دماء المسلمين، لا تنسوهم بالدعاء...
الرد
#7
السلام عليكم

تم تحسين الكود إلى الأفضل حيث أصبحت سرعة نقل البيانات سريعة جدا
كود :
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;
[-] كل من 1 user says قال شكرا ل getsource على المشاركة المفيدة
  • أبو معاذ
الرد
#8
الإجراء الذي أرفقته يستخدم المكتبة Excel97 وتابع ReplaceStr معرف في إحدى وحداتك الخاصة Smile

هنا إجراء لنقل البيانات من 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

بالتوفيق.


الملفات المرفقة
.rar   uExportToExcel.rar (الحجم : 2.26 KB / التحميلات : 250)
.rar   QExport+AExcel.rar (الحجم : 256.71 KB / التحميلات : 500)
[-] كل من 1 user says قال شكرا ل kachwahed على المشاركة المفيدة
  • أبو معاذ
الرد
#9
طريقة أخرى للحفظ بصيغة 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/
الرد
#10
(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/

رائعة ،
جزاك الله خيرا.
اللهم اجعلني من أهل القرآن ، الذين هم أهلك و خاصتك.
تذكر بأن الوقت الذي تلهو فيه ، غيرك يبني مجده فيه.
الرد


التنقل السريع :


مستخدمين يتصفحوا هذا الموضوع: 1 ضيف