rm_cross.pas

进销存·完整的·有数据库的·非常完整·只得参考

unit RM_Cross;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus, ExtCtrls, DB, RM_Class, RM_DSet, RM_DBRel, Buttons
{$IFDEF Delphi6}
  , Variants
{$ENDIF};

const
  flCrossShowRowTotal = $2;
  flCrossShowColTotal = $4;
  flCrossShowIndicator = $8;
  flCrossSortColHeader = $10;
  flCrossSortRowHeader = $20;
  flCrossMergeRowHeader = $40;
  flCrossShowRowNo = $80;

type
  TRMCrossObject = class(TComponent) // fake component
  end;

  TIntArrayCell = array[0..0] of Integer;
  PIntArrayCell = ^TIntArrayCell;

  { TRMQuickIntarray }
  TRMQuickIntArray = class
  private
    arr: PIntArrayCell;
    len: Integer;
    function GetCell(Index: Integer): Integer;
    procedure SetCell(Index: Integer; const Value: Integer);
  public
    constructor Create(Length: Integer);
    destructor Destroy; override;
    property Cell[Index: Integer]: Integer read GetCell write SetCell; default;
  end;

  { TRMArray }
  TRMArray = class(TObject)
  private
    FFlag_Insert: Boolean;
    FInsertPos: Integer;
    FSortColHeader, FSortRowHeader: Boolean;
    FRows: TStringList;
    FColumns: TStringList;
    FCellItemsCount: Integer;
    function GetCell(const Row, Col: string; Index3: Integer): Variant;
    procedure SetCell(const Row, Col: string; Index3: Integer; Value: Variant);
    function GetCellByIndex(Row, Col, Index3: Integer): Variant;
    function GetCellArray(Row, Col: Integer): Variant;
    procedure SetCellArray(Row, Col: Integer; Value: Variant);
    procedure SetSortColHeader(Value: Boolean);
    procedure SetSortRowHeader(Value: Boolean);
  public
    constructor Create(CellItemsCount: Integer);
    destructor Destroy; override;
    procedure Clear;
    property Columns: TStringList read FColumns;
    property Rows: TStringList read FRows;
    property CellItemsCount: Integer read FCellItemsCount;
    property Cell[const Row, Col: string; Index3: Integer]: Variant read GetCell write SetCell;
    property CellByIndex[Row, Col, Index3: Integer]: Variant read GetCellByIndex;
    property CellArray[Row, Col: Integer]: Variant read GetCellArray write SetCellArray;
    property SortColHeader: Boolean read FSortColHeader write SetSortColHeader;
    property SortRowHeader: Boolean read FSortRowHeader write SetSortRowHeader;
  end;

  { TRMCross }
  TRMCross = class(TRMArray)
  private
    FDataSet: TDataSet;
    FRowFields, FColFields, FCellFields: TStringList;
    FRowTypes, FColTypes: array[0..31] of Variant;
    FTopLeftSize: TSize;
    FHeaderString: string;
    FRowTotalString: string;
    FRowGrandTotalString: string;
    FColumnTotalString: string;
    FColumnGrandTotalString: string;
    FAddColumnsHeader: TStringList;

    function GetIsTotalRow(Index: Integer): Boolean;
    function GetIsTotalColumn(Index: Integer): Boolean;
  public
    DoDataCol: Boolean;
    ShowRowNo: Boolean;
    DataStr: string;
    constructor Create(DS: TDataSet; RowFields, ColFields, CellFields: string);
    destructor Destroy; override;
    procedure Build;
    property HeaderString: string read FHeaderString write FHeaderString;
    property RowTotalString: string read FRowTotalString write FRowTotalString;
    property RowGrandTotalString: string read FRowGrandTotalString write FRowGrandTotalString;
    property ColumnTotalString: string read FColumnTotalString write FColumnTotalString;
    property ColumnGrandTotalString: string read FColumnGrandTotalString write FColumnGrandTotalString;
    property TopLeftSize: TSize read FTopLeftSize;
    property IsTotalRow[Index: Integer]: Boolean read GetIsTotalRow;
    property IsTotalColumn[Index: Integer]: Boolean read GetIsTotalColumn;
  end;

  { TRMCrossView }
  TRMCrossView = class(TRMView)
  private
    FDataHeight, FDataWidth: Integer;
    FHeaderHeight, FHeaderWidth: String;
    FCross: TRMCross;
    FColumnWidths: TRMQuickIntArray;
    FColumnHeights: TRMQuickIntArray;
    FLastTotalCol: TRMQuickIntArray;
    FFlag: Boolean;
    FSkip: Boolean;
    FRowDS: TRMUserDataset;
    FColumnDS: TRMUserDataset;
    FRepeatCaptions: Boolean;
    FInternalFrame: Boolean;
    FReport: TRMReport;
    FShowHeader: Boolean;
    FDefDY: Integer;
    FLastX: Integer;
    FMaxGTHeight, FMaxCellHeight: Integer;
    FMaxString: string;
    FDictionary: TStringList;
    FAddColumnsHeader: TStringList;

    FSavedOnBeginDoc: TRMBeginDocEvent;
    FSavedOnBeforePrint: TRMEnterRectEvent;
    FSavedOnPrintColumn: TRMPrintColumnEvent;
    FSavedOnEndDoc: TRMEndDocEvent;

    function OneObject(p: TRMPage; Name1, Name2: string): TRMMemoView;
    function ParentPage: TRMPage;
    procedure CreateObjects;
    procedure CalcWidths;
    procedure MakeBands;
    procedure ReportPrintColumn(ColNo: Integer; var Width: Integer);
    procedure ReportBeforePrint(Memo: TStringList; View: TRMView);
    procedure ReportEndDoc;
    procedure ReportBeginDoc;
    procedure P1Click(Sender: TObject);
    procedure P2Click(Sender: TObject);
    procedure P3Click(Sender: TObject);

    function GetShowRowTotal: Boolean;
    procedure SetShowRowTotal(Value: Boolean);
    function GetShowColTotal: Boolean;
    procedure SetShowColTotal(Value: Boolean);
    function GetShowIndicator: Boolean;
    procedure SetShowIndicator(Value: Boolean);
    function GetSortColHeader: Boolean;
    procedure SetSortColHeader(Value: Boolean);
    function GetSortRowHeader: Boolean;
    procedure SetSortRowHeader(Value: Boolean);
    function GetMergeRowHeader: Boolean;
    procedure SetMergeRowHeader(Value: Boolean);
    function GetShowRowNo: Boolean;
    procedure SetShowRowNo(Value: Boolean);

    function GetDictName(s: string): string;
    function GetDataCellText: string;

    function GetHeaderHeight(aIndex: Integer): Integer;
    function GetHeaderWidth(aIndex: Integer): Integer;

    procedure DictionaryEditor(Sender: TObject);
    procedure AddColumnHeaderEditor(Sender: TObject);
    procedure OnColumnDSFirst(Sender: TObject);
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
  public
    RowNoHeader: string;
    class function CanPlaceOnGridView: Boolean; override;
    constructor Create; override;
    destructor Destroy; override;
    procedure Draw(aCanvas: TCanvas); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;

    property RowDS: TRMUserDataset read FRowDS;
    property ColumnDS: TRMUserDataset read FColumnDS;
    property PShowRowTotal: Boolean read GetShowRowTotal write SetShowRowTotal;
    property PShowColTotal: Boolean read GetShowColTotal write SetShowColTotal;
    property PShowIndicator: Boolean read GetShowIndicator write SetShowIndicator;
    property PSortColHeader: Boolean read GetSortColHeader write SetSortColHeader;
    property PSortRowHeader: Boolean read GetSortRowHeader write SetSortRowHeader;
    property PMergeRowHeader: Boolean read GetMergeRowHeader write SetMergeRowHeader;
    property PShowRowNo: Boolean read GetShowRowNo write SetShowRowNo;
  end;

  { TRMCrossForm }
  TRMCrossForm = class(TForm)
    GroupBox1: TGroupBox;
    ListBox2: TListBox;
    ListBox3: TListBox;
    ListBox4: TListBox;
    Shape1: TShape;
    Shape2: TShape;
    GroupBox2: TGroupBox;
    DatasetsLB: TComboBox;
    FieldsLB: TListBox;
    btnOK: TButton;
    btnCancel: TButton;
    Label1: TLabel;
    ComboBox2: TComboBox;
    CheckBox1: TCheckBox;
    btnExchange: TSpeedButton;
    procedure FormShow(Sender: TObject);
    procedure DatasetsLBClick(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure ListBox3Enter(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure ListBox3Click(Sender: TObject);
    procedure ListBox4Click(Sender: TObject);
    procedure ComboBox2Click(Sender: TObject);
    procedure ListBox4DrawItem(Control: TWinControl; Index: Integer;
      ARect: TRect; State: TOwnerDrawState);
    procedure FieldsLBDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure FieldsLBDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure ListBox3DblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnExchangeClick(Sender: TObject);
    procedure ListBox3KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    { Private declarations }
    FListBox: TListBox;
    FBusy: Boolean;
    DrawPanel: TPanel;
    procedure FillDatasetsLB;
    procedure Localize;
    procedure ClearSelection(Sender: TObject);
  public
    { Public declarations }
    Cross: TRMCrossView;
  end;

implementation

{$R *.DFM}

uses RM_CmpReg, RM_Const, RM_Utils, RM_Ledit;

type
  PRMArrayCell = ^TRMArrayCell;
  TRMArrayCell = record
    Items: Variant;
  end;

  { TRMCrossGroupItem }
  TRMCrossGroupItem = class(TObject)
  private
    Parent: TRMCross;
    FArray: Variant;
    FCellItemsCount: Integer;
    FGroupName: TStringList;
    FIndex: Integer;
    FCount: TRMQuickIntArray;
    FStartFrom: Integer;
    procedure Reset(NewGroupName: string; StartFrom: Integer);
    procedure AddValue(Value: Variant);
    function IsBreak(GroupName: string): Boolean;
    procedure CheckAvg;
    property Value: Variant read FArray;
  public
    constructor Create(AParent: TRMCross; GroupName: string; Index, CellItemsCount: Integer);
    destructor Destroy; override;
  end;

  { TRMCrossList }
  TRMCrossList = class
  private
    FList: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(v: TRMCrossView);
    procedure Delete(v: TRMCrossView);
  end;

  TDrawPanel = class(TPanel)
  private
    FColumnFields: TStrings;
    FRowFields: TStrings;
    FCellFields: TStrings;
    LastX, LastY, DefDx, DefDy: Integer;
    procedure Draw(x, y, dx, dy: Integer; s: string);
    procedure DrawColumnCells;
    procedure DrawRowCells;
    procedure DrawCellField;
    procedure DrawBorderLines(pos: byte);
  public
    procedure Paint; override;
  end;

var
  FCrossList: TRMCrossList;

function RMCrossList: TRMCrossList;
begin
  if FCrossList = nil then
  begin
    FCrossList := TRMCrossList.Create;
  end;
  Result := FCrossList;
end;

function HasTotal(s: string): Boolean;
begin
  Result := Pos('+', s) <> 0;
end;

function FuncName(s: string): string;
begin
  if HasTotal(s) then
  begin
    Result := LowerCase(Copy(s, Pos('+', s) + 1, 255));
    if Result = '' then
      Result := 'sum';
  end
  else
    Result := '';
end;

function PureName(s: string): string;
begin
  if HasTotal(s) then
    Result := Copy(s, 1, Pos('+', s) - 1)
  else
    Result := s;
end;

function CharCount(ch: Char; s: string): Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 1 to Length(s) do
  begin
    if s[i] = ch then
      Inc(Result);
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMCrossGroupItem }

constructor TRMCrossGroupItem.Create(AParent: TRMCross; GroupName: string;
  Index, CellItemsCount: Integer);
begin
  inherited Create;
  Parent := AParent;
  FCellItemsCount := CellItemsCount;
  FArray := VarArrayCreate([0, CellItemsCount - 1], varVariant);
  FCount := TRMQuickIntArray.Create(CellItemsCount);
  FGroupName := TStringList.Create;
  FIndex := Index;
  Reset(GroupName, 0);
end;

destructor TRMCrossGroupItem.Destroy;
begin
  FGroupName.Free;
  VarClear(FArray);
  FCount.Free;
  inherited Destroy;
end;

procedure TRMCrossGroupItem.Reset(NewGroupName: string; StartFrom: Integer);
var
  i: Integer;
  s: string;
begin
  FStartFrom := StartFrom;
  RMSetCommaText(NewGroupName, FGroupName);
  for i := 0 to FCellItemsCount - 1 do
  begin
    FCount[i] := 0;
    s := FuncName(Parent.FCellFields[i]);
    if (s = 'max') or (s = 'min') then
      FArray[i] := Null
    else
      FArray[i] := 0;
  end;
end;

function TRMCrossGroupItem.IsBreak(GroupName: string): Boolean;
var
  sl: TStringList;
begin
  sl := TStringList.Create;
  RMSetCommaText(GroupName, sl);
  Result := (FIndex < sl.Count) and (FIndex < FGroupName.Count) and
    (sl[FIndex] <> FGroupName[FIndex]);
  sl.Free;
end;

procedure TRMCrossGroupItem.AddValue(Value: Variant);
var
  i: Integer;
  s: string;
begin
  if TVarData(Value).VType >= varArray then
  begin
    for i := 0 to FCellItemsCount - 1 do
    begin
      if (Value[i] <> Null) and HasTotal(Parent.FCellFields[i]) then
      begin
        s := FuncName(Parent.FCellFields[i]);
        if (s = 'sum') or (s = 'count') then
          FArray[i] := FArray[i] + Value[i]
        else if s = 'min' then
        begin
          if (FArray[i] = Null) or (FArray[i] > Value[i]) then
            FArray[i] := Value[i];
        end
        else if s = 'max' then
        begin
          if FArray[i] < Value[i] then
            FArray[i] := Value[i];
        end
        else if s = 'avg' then
        begin
          FArray[i] := FArray[i] + Value[i];
          FCount[i] := FCount[i] + 1;
        end;
      end;
    end;
  end;
end;

procedure TRMCrossGroupItem.CheckAvg;
var
  i: Integer;
  s: string;
begin
  for i := 0 to FCellItemsCount - 1 do
  begin
    s := FuncName(Parent.FCellFields[i]);
    if s = 'avg' then
    begin
      if FCount[i] <> 0 then
        FArray[i] := FArray[i] / FCount[i]
      else
        FArray[i] := Null;
    end;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMArray }

constructor TRMArray.Create(CellItemsCount: Integer);
begin
  inherited Create;
  FCellItemsCount := CellItemsCount;
  FRows := TStringList.Create;
  FRows.Sorted := True;
  FColumns := TStringList.Create;
  FColumns.Sorted := True;
end;

destructor TRMArray.Destroy;