exportmultititle.pas

DBGridEh多表头输出到Excel.zip

unit ExportMultiTitle;
//==============================================================================
// 多表头输出模块
// 最近有用到DBGridEh,但是多表头的输出一直是个问题,于是根据DisplayLabel自己写了个模块
// 因为时间的关系,算法一直没有精简,如果你有改进请发给我一份!
// 程序设计:JIT
// EMail: [e-mail]
//==============================================================================
interface

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.