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,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;

[kachwahed]

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

هنا إجراء لنقل البيانات من TDBGrid إلى Excel باستخدام الوحدة Excel2000 المرفقة مع دلفي:

كود PHP:

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***91;I***93;.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***91;'A' + IntToStr(Row), 'A' + IntToStr(Row)***93;;
        for I := 0 to aDataSet.Fields.Count - 1 do
        begin
          RangeE.Value := aDataSet.Fields***91;I***93;.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***91;'A1', chr(64 + aDataSet.Fields.Count) + IntToStr(Row - 1)***93;;

  RangeE.AutoFormat(8, NULL, NULL, NULL, NULL, NULL, NULL);
  PreviewToExcel.Visible***91;0***93; := 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

كود PHP:

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***91;1***93;.WorkSheets***91;1***93;.Name := 'Export Data';
          Sheet := XLApp.WorkBooks***91;1***93;.WorkSheets***91;'Export data'***93;;
          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***91;I***93;.Visible then
              Continue;
            Sheet.Cells***91;J, I + 1***93; := dbgridname.Columns***91;I***93;.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***91;I***93;.Visible then
                Continue;
              Sheet.Cells***91;J, I + 1***93; :=
                Trim(DBGridName.DataSource.DataSet.FieldByName(
                DBGridName.Columns***91;i***93;.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***91;J***93;.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***91;J***93;.Visible) then
            Continue;
          WordTable.Cell(1, ColIndex).Range.InsertAfter(
            DBGridName.Columns***91;J***93;.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***91;j***93;.Visible <> False) then
              begin
                WordTable.Cell(RowIndex, ColIndex).Range.InsertAfter
                (DBGridName.DataSource.DataSet.FieldByName(
                  DBGridName.Columns***91;j***93;.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/