excel导出多表头

[delphi]代码库

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Grids, DBGridEh, DB, ADODB, StdCtrls, Excel2000,
  OleServer;

type
  TForm1 = class(TForm)
    ADOConnection1: TADOConnection;
    ADOQuery1: TADOQuery;
    DataSource1: TDataSource;
    DBGridEh1: TDBGridEh;
    Panel1: TPanel;
    ComboBox1: TComboBox;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    ExcelApplication1: TExcelApplication;
    ExcelWorksheet1: TExcelWorksheet;
    ExcelWorkbook1: TExcelWorkbook;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses ExportMultiTitle;

{$R *.dfm}

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action:=caFree;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  conStr:string;
  i :integer;
begin
  conStr:='Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=';
  conStr:=conStr+ExtractFilePath(Application.ExeName)+'test.mdb;';
  conStr:=conStr+'Mode=Share Deny None;Extended Properties="";Jet OLEDB:System database="";Jet OLEDB:Registry Path="";Jet OLEDB:Database Password="";';
  conStr:=conStr+'Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;';
  conStr:=conStr+'Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="";';
  conStr:=conStr+'Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don''t Copy Locale on Compact=False;';
  conStr:=conStr+'Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False';
  ADOConnection1.ConnectionString:=conStr;
  ADOConnection1.Open;
  ADOQuery1.Open;
  for i:=0 to AdoQuery1.Fields.Count-1 do
    combobox1.Items.Add(AdoQuery1.Fields[i].FieldName);
  ComboBox1.ItemIndex:=0;
  ComboBox1.OnChange(Self);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ADOQuery1.Close;
  ADOConnection1.Close;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
  Edit1.Text:=ADOQuery1.Fields[ComboBox1.ItemIndex].DisplayLabel;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ADOQuery1.Fields[ComboBox1.ItemIndex].DisplayLabel:=Edit1.Text;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  i,j:Integer;
  dT,dL,dR,dB:Integer;
  Ra:Variant;
begin
  Try
    ExcelApplication1.Connect;
    ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks.Add(EmptyParam,0));
    ExcelWorkSheet1.ConnectTo(ExcelWorkBook1.Sheets[1] as _WorkSheet);
    ExcelApplication1.Caption := '通用客户打印调用 Microsoft Excel';
    ExcelApplication1.Visible[0]:=True;
    ExportMyCell(ADOQuery1.Fields);
    for i:=0 to r-1 do
      for j:=0 to c-1 do
        if MyCells[i,j].Used then
        begin
          if (MyCells[i,j].Rect.Top=MyCells[i,j].Rect.Bottom)
            and (MyCells[i,j].Rect.Left=MyCells[i,j].Rect.Right) then
          begin
            dT:=MyCells[i,j].Rect.Top+1;
            dL:=MyCells[i,j].Rect.Left+1;
            ExcelWorksheet1.Cells.Item[dt,dl]:=MyCells[i,j].Text;
          end
          else
          begin
            dT:=MyCells[i,j].Rect.Top+1;
            dL:=MyCells[i,j].Rect.Left+1;
            dR:=MyCells[i,j].Rect.Right+1;
            dB:=MyCells[i,j].Rect.Bottom+1;
          //合并
            ExcelWorksheet1.Cells.Item[dt,dl]:=MyCells[i,j].Text;
            Ra:=ExcelWorksheet1.Range[ExcelWorksheet1.Cells.Item[dt,dl],ExcelWorksheet1.Cells.Item[db,dr]];
            Ra.MergeCells:=True;
          end;
        end;
    ExcelWorkSheet1.Columns.AutoFit;
  Finally
    ExcelWorkSheet1.Disconnect;
    ExcelWorkBook1.Disconnect;
    ExcelApplication1.Disconnect;
    Ra:=Unassigned;
  end;
end;

end.



uses
  Windows, DB;

type
  PMyCell=^MyCell;
  MyCell=Record
    Text:String;
    Parent:PMyCell;
    Used:Boolean;
    Rect:TRect;
  end;

var
  MyCells: Array of Array of MyCell;
  R,C:Integer;

procedure ExportMyCell(AField:TFields);  

implementation

procedure ExportMyCell(AField:TFields);

  //取得列标题行数
  function GetTitleRow(ColTitle:String):Integer;
  var
    ii:Integer;
  begin
    Result:=1;
    for ii:=1 to Length(ColTitle) do
      if ColTitle[ii]='|' then Result:=Result+1;
  end;

  Function GetMaxTitleRow(AFields:TFields):Integer;
  var
    ii,jj:Integer;
  begin
    Result:=1;
    for ii:=0 to AFields.Count-1 do
    begin
      jj:=GetTitleRow(AFields[ii].DisplayLabel);
      if Result<jj then Result:=jj;
    end;
  end;

  procedure initMycells;
  var
    i,j:Integer;
  begin
    SetLength(MyCells,R);
    for i:=0 to R-1 do
    begin
      SetLength(MyCells[i],C);
      for j:=0 to C-1 do
      begin
        MyCells[i,j].Text:='';
        MyCells[i,j].Used:=True;
        MyCells[i,j].Rect.Left:=j;
        MyCells[i,j].Rect.Right:=j;
        MyCells[i,j].Rect.Top:=i;
        MyCells[i,j].Rect.Bottom:=i;
        if i=0 then MyCells[i,j].Parent:=nil
        else MyCells[i,j].Parent:=@MyCells[i-1,j];
      end;
    end;
  end;

  procedure GetFieldToMycells(AFields:TFields);
  var
    i,j:Integer;
    TmpStr:String;
  begin
    initMycells;
    for i:=0 to C-1 do
    begin
      TmpStr:=AFields[i].DisplayLabel;
      j:=0;
      while Pos('|',TmpStr)>0 do
      begin
        MyCells[j,i].Text:=Copy(TmpStr,1,Pos('|',TmpStr)-1);
        MyCells[j,i].Used:=True;
        if j<>0 then MyCells[j,i].Parent:=@MyCells[i-1,j];
        TmpStr:=Copy(TmpStr,Pos('|',TmpStr)+1,Length(TmpStr));
        Inc(j);
      end;
      MyCells[j,i].Text:=TmpStr;
    end;
  end;

  //合并过程(核心)
  procedure uniteMyCell;
  var
    i :integer;
    procedure MoveToLastCell(MR,MC:Integer);
    var
      i :integer;
    begin
      for i:=MR-1 downto 0 do
        if MyCells[i,MC].Text='' then Continue
        else
        begin
          MyCells[R-1,MC].Text:=MyCells[i,MC].Text;
          MyCells[i,MC].Text:='';
          Break;
        end;
    end;

    procedure CheckLastRow;//检测最后行
    var
      i:Integer;
    begin
      for i:=0 to C-1 do
        if MyCells[R-1,i].Text='' then MoveToLastCell(R-1,i);//移动最后一个有数据的单元格到最后一行
    end;

    //合并当前行
    procedure UionCurrRowCell(CR:Integer);
    var
      i,SC:integer;
      function GetNextCUCell(SC:Integer):Integer;
      var
        i:Integer;
      begin
        Result:=-1;
        i:=SC+1;
        while (Result=-1) and (i<C) do
          begin
            if not MyCells[CR,i].Used then Inc(i)
            else
              if (MyCells[CR,i].Text<>'') then Result:=i;
            MyCells[CR+1,i].Parent:=@MyCells[CR,i];
            Inc(i);
          end;
      end;
    begin
      SC:=GetNextCUCell(-1);//得到下一个可用单元
      if SC=-1 then Exit;
      //开始比较
      i:=SC+1;
      while (i<c) and (SC<>-1) do
      begin
        if MyCells[CR,i].Used then
        begin
          if (MyCells[CR,SC].Text=MyCells[CR,i].Text) then
          begin
            MyCells[CR,SC].Rect.Right:=i;
            MyCells[CR,i].Used:=False;
            MyCells[CR,i].Parent:=@MyCells[CR,SC];
            MyCells[CR+1,i].Parent:=@MyCells[CR,SC];
          end
          else SC:=i;
        end;
        i:=GetNextCUCell(i);
        if i=-1 then SC:=-1;
      end;
    end;

    procedure MoveUpCol(MR,MC:Integer);
    var
      i :integer;
    begin
      for i:=MR to R-1 do
        if (MyCells[i,MC].Text='') then Continue
        else
        begin
          MyCells[MR,MC].Text:=MyCells[i,MC].Text;
          MyCells[i,MC].Text:='';
          Break;
        end;
    end;

    //检测当前行单元是否为空,为空则将有数据的列上来
    procedure CheckCurrRow(CR:Integer);
    var
      i :integer;
    begin
      for i:=0 to C-1 do
      begin
        if (MyCells[CR,i].Used) and (MyCells[CR,i].Text='') then
        begin
          MoveUpCol(CR,i);
        end;
      end;
    end;

    //在范围内查找空行
    function FindEmpty(SR:Integer{开始行};FindRect:TRect;var RR:Integer):Boolean;
    var
      i,j :integer;
      Same:Boolean;
    begin
      Result:=False;
      for i:=SR to R-1 do
      begin
        Same:=True;
        for j:=FindRect.Left to FindRect.Right do
          if MyCells[i,j].Used and (MyCells[i,j].Text='') then Continue
          else
          begin
            Same:=False;
            Break;
          end;
        if Same then
        begin
          RR:=i;
          Result:=True;
          Break;
        end;
      end;
    end;
    //当前行与上一行交换
    procedure ChangeCell(CRect:TRect;RR:Integer);
    var
      i :integer;
    begin
      for i:= CRect.Left to CRect.Right do
      begin
        MyCells[RR,i].Text:=MyCells[RR-1,i].Text;
        MyCells[RR-1,i].Text:='';
      end;
    end;
    //提升空行
    procedure DoUpCol(CR,CC:Integer);
    var
      i,RR:integer;
    begin
      for i:=CR+2 to R-2 do
      //在范围内查找空行,并交换行
        if FindEmpty(i,MyCells[CR,CC].Rect,RR) then ChangeCell(MyCells[CR,CC].Rect,RR);
    end;
    //合并列
    procedure DoUionCell(CR,CC:Integer);
    var
      i,RR,j:Integer;
    begin
      for i:=CR+1 to R-1 do
      begin
        if FindEmpty(i,MyCells[CR,CC].Rect,RR) then
        begin
          if RR>CR then
          begin
            MyCells[CR,CC].Rect.Bottom:=RR;
            for j:=MyCells[CR,CC].Rect.Left to MyCells[CR,CC].Rect.Right do
            begin
              MyCells[RR,j].Used:=False;
              MyCells[RR,j].Parent:=@MyCells[CR,CC];
            end;
          end
          else Break;
        end else Break;
      end;
    end;
    //向下合并列 :)
    procedure UionCurrRowColCell(CR :integer);
    var
      i:integer;
    begin
      for i:=0 to C-1 do
      begin
        if MyCells[CR,i].Used then DoUpCol(CR,i);//提升空行
      end;
      for i:=0 to C-1 do
      begin
        if MyCells[CR,i].Used then DoUionCell(CR,i);//合并列
      end;
    end;
  begin
    CheckLastRow;         //检测最后行
    for i:=0 to R-2 do    //最后一行不管
    begin
      UionCurrRowCell(i); //合并当前行
      CheckCurrRow(i);    //检测当前行单元是否为空,为空则将有数据的列上来
      UionCurrRowColCell(i); //向下合并列 :)
    end;
  end;
begin
  R:=GetMaxTitleRow(AField);
  C:=AField.Count;
  GetFieldToMycells(AField);
  uniteMyCell; 
end;

end.