xlsadapter.pas

来自「DELPHI界面增强控件,非常好,里面有显示GIF的图片控件,更美观的下拉框控件」· PAS 代码 · 共 1,566 行 · 第 1/4 页

unit XLSAdapter;
{$IFDEF LINUX}{$INCLUDE ../FLXCONFIG.INC}{$ELSE}{$INCLUDE ..\FLXCONFIG.INC}{$ENDIF}

//Note: Excel uses 1-Based arrays, and that's the interface we present to our users.
// but, TExcelWorkbook uses 0-Based arrays, to be consistent with the file format (made in C)
//So here we have to add and substract 1 everywere to be consistent.

interface
{$R EmptySheet.res}
uses
  SysUtils, Classes,
  UExcelAdapter, XlsBaseTemplateStore, UFlxMessages, UExcelRecords, XlsMessages,
  UFlxRowComments,
  {$IFDEF WIN32}Windows, WOLE2Stream,{$ENDIF} //Here is not VCL/CLX, but Linux/Windows
  {$IFDEF LINUX}KGsfStream,{$ENDIF}
  {$IFDEF FLX_VCL}Clipbrd,{$ENDIF}
  {$IFDEF FLX_CLX}QClipbrd, {$ENDIF}

  {$IFDEF ConditionalExpressions}{$if CompilerVersion >= 14} variants, Types, {$IFEND}{$ENDIF} //Delphi 6 or above
  UXlsSheet, UFlxFormats, UXlsRowColEntries,
  {$IFNDEF TMSASG}
  UTextDelim,
  {$ENDIF}
  UXlsXF;

type
  TExcelSaveFormatNative= (
    snXLS, snCSVComma, snCSVSemiColon, snTabDelimited
    );

  TSetOfExcelSaveFormatNative = Set Of TExcelSaveFormatNative;


type
  TXLSAdapter = class(TExcelAdapter)
  private
    FTemplateStore: TXlsBaseTemplateStore;
    FSaveFormat: TSetOfExcelSaveFormatNative;
    procedure SetTemplateStore(const Value: TXLSBaseTemplateStore);
    { Private declarations }
  protected
    { Protected declarations }
  public
    constructor Create(AOwner:TComponent);override;
    function GetWorkbook: TExcelFile;override;
    { Public declarations }
  published
    property SaveFormat: TSetOfExcelSaveFormatNative read FSaveFormat write FSaveFormat default [snXLS];
    property TemplateStore: TXLSBaseTemplateStore read FTemplateStore write SetTemplateStore;
    { Published declarations }
  end;

  TXLSFile = class(TExcelFile)
  private
    FAdapter: TXLSAdapter;
    FActiveSheet: integer;

    FWorkbook: TWorkbook;
    FTemplate: TXlsStorageList;
    FTmpTemplate: TXlsStorageList;

    FirstColumn,LastColumn: integer;

    RowPictures: TRowComments;
    procedure ParsePictures;
    procedure PasteFromStream(const Row, Col: integer; const Stream: TStream);
    procedure OpenFileOrStream(const FileName: TFileName; const aStream: TStream);
    procedure PasteFromBiff8(const Row, Col: integer);
    procedure PasteFromText(const Row, Col: integer);

    procedure SaveAsXls(const FileName: string; const DataStream: TStream);
    procedure SaveAsTextDelimited(const FileName: string; const DataStream: TStream; const Delim: char);

    procedure InternalSetCellString(const aRow, aCol: integer; const Text: Widestring; const Fm: PFlxFormat; const DateFormat, TimeFormat: widestring);
    procedure SetCellValueAndFmt(const aRow, aCol: integer; const v: variant; const Fm: PFlxFormat);

  protected
    function GetActiveSheet: integer; override;
    procedure SetActiveSheet(const Value: integer); override;
    function GetActiveSheetName: WideString; override;
    procedure SetActiveSheetName(const Value: WideString); override;

    function GetColumnWidth(aCol: integer): integer;override;
    function GetRowHeight(aRow: integer): integer;override;
    procedure SetColumnWidth(aCol: integer; const Value: integer);override;
    procedure SetRowHeight(aRow: integer; const Value: integer);override;

    function GetDefaultColWidth: integer;override;
    function GetDefaultRowHeight: integer;override;

    function GetCommentsCount(Row: integer): integer; override;
    function GetCommentText(Row, aPos: integer): widestring; override;
    function GetCommentColumn(Row, aPos: integer): integer; override;
    function GetPictureName(Row, aPos: integer): widestring;  override; //use row < 0 to return all
    function GetPicturesCount(Row: integer): integer;  override; //use row < 0 to return all

    function GetCellValue(aRow, aCol: integer): Variant; override;
    procedure SetCellValue(aRow, aCol: integer; const Value: Variant); override;
    function GetCellValueX(aRow, aCol: integer): TXlsCellValue; override;
    procedure SetCellValueX(aRow, aCol: integer; const Value: TXlsCellValue); override;

    function GetCellFormula(aRow, aCol: integer): widestring; override;
    procedure SetCellFormula(aRow, aCol: integer; const Value: widestring); override;

    function GetAutoRowHeight(Row: integer): boolean;override;
    procedure SetAutoRowHeight(Row: integer; const Value: boolean);override;

    function GetColumnFormat(aColumn: integer): integer; override;
    function GetRowFormat(aRow: integer): integer;override;
    procedure SetColumnFormat(aColumn: integer; const Value: integer);override;
    procedure SetRowFormat(aRow: integer; const Value: integer);override;

    function GetCellFormat(aRow, aCol: integer): integer; override;
    procedure SetCellFormat(aRow, aCol: integer; const Value: integer); override;

    function GetColorPalette(Index: TColorPaletteRange): LongWord; override;
    procedure SetColorPalette(Index: TColorPaletteRange; const Value: LongWord); override;

    function GetFormatList(index: integer): TFlxFormat; override;

    function GetPageFooter: WideString;override;
    function GetPageHeader: WideString;override;
    procedure SetPageFooter(const Value: WideString);override;
    procedure SetPageHeader(const Value: WideString);override;

    function GetShowGridLines: boolean; override;
    procedure SetShowGridLines(const Value: boolean); override;
    function GetPrintGridLines: boolean; override;
    procedure SetPrintGridLines(const Value: boolean); override;

    function GetSheetZoom: integer;override;
    procedure SetSheetZoom(const Value: integer);override;

    function GetMargins: TXlsMargins;override;
    procedure SetMargins(const Value: TXlsMargins);override;

    function GetPrintNumberOfHorizontalPages: word;override;
    function GetPrintNumberOfVerticalPages: word;override;
    function GetPrintScale: integer;override;
    function GetPrintToFit: boolean;override;
    procedure SetPrintNumberOfHorizontalPages(const Value: word);override;
    procedure SetPrintNumberOfVerticalPages(const Value: word);override;
    procedure SetPrintScale(const Value: integer);override;
    procedure SetPrintToFit(const Value: boolean);override;

    function GetCellMergedBounds(aRow, aCol: integer): TXlsCellRange; override;

  public
    constructor Create(const aAdapter: TXLSAdapter );
    destructor Destroy; override;

    procedure Connect;override;
    procedure Disconnect;override;

    procedure NewFile;override;
    procedure OpenFile(const FileName: TFileName);override;
    procedure LoadFromStream(const aStream: TStream);override;
    procedure CloseFile; override;

    procedure InsertAndCopySheets (const CopyFrom, InsertBefore, SheetCount: integer);override;
    function SheetCount: integer;override;
    procedure SelectSheet(const SheetNo:integer); override;

    procedure DeleteMarkedRows(const Mark: widestring);override;
    procedure RefreshChartRanges(const VarStr: string);override;
    procedure MakePageBreaks(const Mark: widestring);override;
    procedure InsertHPageBreak(const Row: integer); override;
    procedure InsertVPageBreak(const Col: integer); override;
    procedure DeleteHPageBreak(const Row: integer); override;
    procedure DeleteVPageBreak(const Col: integer); override;
    function HasHPageBreak(const Row: integer): boolean;override;
    function HasVPageBreak(const Col: integer): boolean;override;
    procedure RefreshPivotTables;override;

    procedure Save(const AutoClose: boolean; const FileName: string; const OnGetFileName: TOnGetFileNameEvent; const OnGetOutStream: TOnGetOutStreamEvent=nil; const DataStream: TStream=nil);override;

    procedure InsertAndCopyRows(const FirstRow, LastRow, DestRow, aCount: integer; const OnlyFormulas: boolean);override;
    procedure DeleteRows(const aRow, aCount: integer);override;

    procedure BeginSheet;override;
    procedure EndSheet(const RowOffset: integer);override;

    function CanOptimizeRead: boolean; override;


    function GetExcelNameCount: integer;  override;
    function GetRangeName(index: integer): widestring;  override;
    function GetRangeR1(index: integer): integer; override;
    function GetRangeR2(index: integer): integer; override;
    function GetRangeC1(index: integer): integer; override;
    function GetRangeC2(index: integer): integer; override;
    function GetRangeSheet(index: integer): integer; override;

    procedure AssignPicture(const Row, aPos: integer; const Pic: string; const PicType: TXlsImgTypes); override; //use row < 0 to return all
    procedure GetPicture(const Row, aPos: integer; const Pic: TStream; var PicType: TXlsImgTypes; var Anchor: TClientAnchor); override; //use row < 0 to return all

    procedure DeleteImage(const Index: integer);override;
    procedure ClearImage(const Index: integer);override;
    procedure AddImage(const Data: string; const DataType: TXlsImgTypes; const Properties: TImageProperties;const Anchor: TFlxAnchorType);override;

    procedure AssignComment(const Row, aPos: integer; const Comment: widestring); override;
    function GetCellComment(Row, Col: integer): widestring; override;
    procedure SetCellComment(Row, Col: integer; const Value: widestring; const Properties: TImageProperties); override;

    procedure MergeCells(const FirstRow, FirstCol, LastRow, LastCol: integer); override;

    function CellCount(const aRow: integer): integer;override;
    function GetCellData(const aRow, aColOffset: integer): variant;override;
    function GetCellDataX(const aRow, aColOffset: integer): TXlsCellValue;override;
    procedure AssignCellData(const aRow, aColOffset: integer; const Value: variant);override;
    procedure AssignCellDataX(const aRow, aColOffset: integer; const Value: TXlsCellValue);override;
    procedure SetCellString(const aRow, aCol: integer; const Text: Widestring; const DateFormat: widestring=''; const TimeFormat: widestring='');overload;override;
    procedure SetCellString(const aRow, aCol: integer; const Text: Widestring; const Fm: TFlxFormat; const DateFormat: widestring=''; const TimeFormat: widestring='');overload;override;
    function MaxRow: integer; override;
    function MaxCol: integer; override;
    function IsEmptyRow(const aRow: integer): boolean; override;

    function ColByIndex(const Row, ColIndex: integer): integer;override;
    function ColIndexCount(const Row: integer): integer; override;
    function ColIndex(const Row, Col: integer): integer;override;

    procedure SetBounds(const aRangePos: integer);override;
    function GetFirstColumn: integer; override;

    procedure PrepareBlockData(const R1,C1,R2,C2: integer);override;
    procedure AssignBlockData(const Row,Col: integer; const v: variant);override;
    procedure PasteBlockData;override;

    function IsWorksheet(const index: integer): boolean; override;

    function FormatListCount: integer;override;
    function AddFormat (const Fmt: TFlxFormat): integer; override;

    procedure CopyToClipboard; overload; override;
    procedure CopyToClipboard(const Range: TXlsCellRange);overload;override;
    procedure PasteFromClipboard(const Row, Col: integer);override;

    procedure ParseComments; override;
  end;


{$IFNDEF TMSASG}
  procedure Register;
{$ENDIF}
implementation

uses UXlsBaseRecordLists, UXlsBaseRecords, UXlsNotes;
{$IFNDEF TMSASG}
  {$R IXLSAdapter.res}

procedure Register;
begin
  RegisterComponents('FlexCel', [TXLSAdapter]);
end;
{$ENDIF}
{ TXLSAdapter }

constructor TXLSAdapter.Create(AOwner: TComponent);
begin
  inherited;
  FSaveFormat:=[snXLS];
end;

function TXLSAdapter.GetWorkbook: TExcelFile;
begin
  Result:= TXLSFile.Create(Self);
end;

procedure TXLSAdapter.SetTemplateStore(const Value: TXLSBaseTemplateStore);
begin
  FTemplateStore := Value;
end;

{ TXLSFile }

procedure TXLSFile.AssignCellData(const aRow, aColOffset: integer; const Value: variant);
var
  V: TXlsCellValue;
begin
  if not FWorkbook.IsWorkSheet(FActiveSheet-1) then exit;
    V.Value:=Value; V.XF:=-1;
    FWorkbook.WorkSheets[FActiveSheet-1].Cells.CellList.Value[aRow-1, FirstColumn + aColOffset]:=V;
end;

procedure TXLSFile.SetCellValueAndFmt(const aRow, aCol: integer; const v: variant; const Fm: PFlxFormat);
var
  Value: TXlsCellValue;
begin
  if Fm=nil then SetCellValue(ARow, ACol, v) else
  begin
    Value.XF:=AddFormat(Fm^);
    Value.Value:=v;
    Value.IsFormula:=False;
    SetCellValueX(aRow, aCol, Value);
  end;
end;

procedure TXLSFile.InternalSetCellString(const aRow, aCol: integer; const Text: Widestring; const Fm: PFlxFormat; const DateFormat, TimeFormat: widestring);
var
  e:extended;
  s: string;
  dt: TDateTime;
  dFormat: widestring;
  Fmt: TFlxFormat;
  HasTime, HasDate: boolean;
begin
  //try to convert to number
  s:=Text; //for if value is a widestring
  if TextToFloat(PChar(s), e, fvExtended) then  //Dont use val because it doesnt handle locales
    SetCellValueAndFmt(ARow, ACol, e, Fm) else
  //try to convert to boolean
    if UpperCase(s)=TxtFalse then SetCellValueAndFmt(ARow, ACol, false, Fm)  else
    if UpperCase(s)=TxtTrue then SetCellValueAndFmt(ARow, ACol, true, Fm) else
  //try to convert to a date
    if FlxTryStrToDateTime(s, dt, dFormat, HasDate, HasTime, DateFormat, TimeFormat) then
    begin
      if Fm=nil then Fmt:=GetFormatList(CellFormat[ARow, ACol]) else Fmt:=Fm^;
      Fmt.Format:=dFormat;
      SetCellValueAndFmt(ARow, ACol, double(dt), @Fmt)
    end else

    SetCellValueAndFmt(ARow, ACol, Text, Fm);
end;

procedure TXLSFile.SetCellString(const aRow, aCol: integer; const Text: Widestring; const DateFormat: widestring; const TimeFormat: widestring);
begin
  InternalSetCellString(aRow, aCol, Text, nil, DateFormat, TimeFormat);
end;

procedure TXLSFile.SetCellString(const aRow, aCol: integer; const Text: Widestring; const Fm: TFlxFormat; const DateFormat: widestring; const TimeFormat: widestring);
begin
  InternalSetCellString(aRow, aCol, Text, @Fm, DateFormat, TimeFormat);
end;


procedure TXLSFile.AssignCellDataX(const aRow, aColOffset: integer; const Value: TXlsCellValue);
begin
  if not FWorkbook.IsWorkSheet(FActiveSheet-1) then exit;
  FWorkbook.WorkSheets[FActiveSheet-1].Cells.CellList.Value[aRow-1, FirstColumn + aColOffset]:=Value;
end;

procedure TXLSFile.AssignComment(const Row, aPos: integer;
  const Comment: widestring);
begin
  if FWorkbook.IsWorkSheet(ActiveSheet-1) then
  begin
    if Comment='' then FWorkbook.WorkSheets[ActiveSheet-1].Notes[Row-1].Delete(aPos) else
    FWorkbook.WorkSheets[ActiveSheet-1].Notes[Row-1][aPos].Text:= Comment;
  end;
end;

procedure TXLSFile.AssignPicture(const Row, aPos: integer; const Pic: string; const PicType: TXlsImgTypes);
var
  MyPos: integer;
begin
  if Row>0 then MyPos:=RowPictures[Row][aPos] else MyPos:=aPos;
  if FWorkbook.IsWorkSheet(ActiveSheet-1) then
    FWorkbook.WorkSheets[ActiveSheet-1].AssignDrawing(MyPos, Pic, PicType);
end;

procedure TXLSFile.GetPicture(const Row, aPos: integer; const Pic: TStream;
  var PicType: TXlsImgTypes; var Anchor: TClientAnchor);
var
  MyPos: integer;
begin
  if Row>0 then MyPos:=RowPictures[Row][aPos] else MyPos:=aPos;
  if FWorkbook.IsWorkSheet(ActiveSheet-1) then
  begin
    FWorkbook.WorkSheets[ActiveSheet-1].GetDrawingFromStream(MyPos, Pic, PicType);
    Anchor:=FWorkbook.WorkSheets[ActiveSheet-1].GetAnchor(MyPos);
    inc(Anchor.Col1);
    inc(Anchor.Col2);
    inc(Anchor.Row1);
    inc(Anchor.Row2);
  end;
end;

procedure TXLSFile.ParsePictures;
var
  i:integer;

begin
  FreeAndNil(RowPictures);
  RowPictures:= TRowComments.Create;
  if FWorkbook.IsWorkSheet(ActiveSheet-1) then
    for i:=0 to FWorkbook.WorkSheets[ActiveSheet-1].DrawingCount-1 do
      RowPictures.Add(FWorkbook.WorkSheets[ActiveSheet-1].DrawingRow[i]+1, i);
end;


procedure TXLSFile.BeginSheet;
begin