xlsnames2.pas

一个经典的读写Excel的控件

unit XLSNames2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressed or implied, including, without limitation, the warranties of     **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}

interface

uses Classes, SysUtils, XLSRWIIResourceStrings2, BIFFRecsII2, XLSUtils2, XLSStream2,
     EncodeFormulaII2, DecodeFormula2, ExcelFuncII2, Dialogs, ExtSeek2;

const CRN_NUM =  $01;
const CRN_STR =  $02;
const CRN_BOOL = $04;
const CRN_ERR =  $10;

type TBuiltInName = (bnConsolidateArea,bnAutoOpen,bnAutoClose,bnExtract,bnDatabase,
                     bnCriteria,bnPrintArea,bnPrintTitles,bnRecorder,bnDataForm,
                     bnAutoActivate,bnAutoDeactivate,bnSheetTitle,bnNone);

type TExternalLookup = (elFail,elCached,elLookup,elCachedIfNoLookup);

{
type PCRNValue = ^TCRNValue;
     TCRNValue = record
     CRNType: byte;
     case integer of
       0: (vDouble: double);
       1: (vString: PChar);
       2: (vError: TCellError);
       3: (vBoolean: boolean);
     end;
}

type PCRNValue = ^TCRNValue;
     TCRNValue = record
     FirstCol,LastCol: byte;
     Row: word;
     Value: PByteArray;
     Size: word;
     end;

type TCRNList = class (TList)
private
     function GetItems(Index: integer): PCRNValue;
public
     destructor Destroy; override;
     procedure Add(Value: PRecCRN; Size: word);
     procedure WriteRecords(Stream: TXLSStream; Index: integer);

     property Items[Index: integer]: PCRNValue read GetItems; default;
     end;

type TSupBookSheet = class(TObject)
private
     FName: string;
     FCRN: TCRNList;

     function GetName: WideString;
     procedure SetName(const Value: WideString);
protected
     property RawName: string read FName;
public
     constructor Create(Name: PByteArray; NameLen: integer); overload;
     constructor Create(Sheetname: WideString); overload;
     destructor Destroy; override;
     procedure SetCRN(P: PRecCRN; Size: word);
     function GetCachedValue(Col,Row: integer): TFormulaValue;

     property Name: WideString read GetName write SetName;
     property CRN: TCRNList read FCRN;
     end;

type TExtNameType = (entName,entDDE,entOLE);

type TExtName = class(TObject)
private
     FOptions: word;
     FName: string;

     function GetName: string;
public
     constructor Create(var P: PRecEXTERNNAME8);
     procedure WriteRecords(Stream: TXLSStream); virtual; abstract;
     function NameType: TExtNameType; virtual; abstract;
     property Name: string read GetName;
     end;

type TExtNameName = class(TExtName)
private
     FNameDef: TDynByteArray;
public
     constructor Create(P: PRecEXTERNNAME8);
     destructor Destroy; override;
     procedure WriteRecords(Stream: TXLSStream); override;
     function NameType: TExtNameType; override;

     property NameDef: TDynByteArray read FNameDef;
     end;

type TExtNameDDE = class(TExtName)
private
     FOPER: PByteArray;
public
     constructor Create(P: PRecEXTERNNAME8);
     destructor Destroy; override;
     procedure WriteRecords(Stream: TXLSStream); override;
     function NameType: TExtNameType; override;
     end;

type TExtNameOLE = class(TExtName)
private
     FOLE2Id: longword;
public
     constructor Create(P: PRecEXTERNNAME8);
     function NameType: TExtNameType; override;
     procedure WriteRecords(Stream: TXLSStream); override;
     property OLE2Id: longword read FOLE2Id;
     end;

type TExtNameList = class(TList)
private
     function GetItems(Index: integer): TExtName;
public
     destructor Destroy; override;
     procedure Add(P: PRecEXTERNNAME8);

     property Items[Index: integer]: TExtName read GetItems; default;
     end;

type TSupBook = class(TObject)
private
     FTabCount: integer;
     FEncoded: word;
     // Do not change to WideString.
     FFilename: string;
     FSheets: array of TSupBookSheet;
     FExtNames: TExtNameList;

     function GetSheets(Index: integer): TSupBookSheet;
     function GetExtNames(Index: integer): TExtName;
     function GetFilename: string;
public
     constructor Create(P: PRecSUPBOOK);
     constructor CreateEncoded(Tabs: integer; Code: word);
     destructor Destroy; override;
     procedure WriteRecords(Stream: TXLSStream);
     function  Count: integer;
     procedure SetEXTERNNAME(P: PRecEXTERNNAME8);
     procedure AddSheet(Sheetname: WideString);

     property Filename: string read GetFilename;
     property Sheets[Index: integer]: TSupBookSheet read GetSheets; default;
     property ExtNames[Index: integer]: TExtName read GetExtNames;
     end;

type TSupBookList = class(TList)
private
     function GetItems(Index: integer): TSupBook;
public
     destructor Destroy; override;
     procedure Clear; override;
     procedure Add(P: PRecSUPBOOK); overload;
     procedure Add(Filename,SheetName: WideString); overload;
     function AddEncodec(Tabs: integer; Code: word): integer;

     property Items[Index: integer]: TSupBook read GetItems; default;
     end;

type PExtSheetData = ^TExtSheetData;
     TExtSheetData = record
     SupBookIndex: integer;
     FirstTab,LastTab: word;
     end;

type TExtSheetList = class(TList)
private
     function GetItems(Index: integer): PExtSheetData;
public
     destructor Destroy; override;
     procedure Clear; override;
     procedure Add(Index,First,Last: integer);
     procedure WriteRecords(Stream: TXLSStream);

     property Items[Index: integer]: PExtSheetData read GetItems; default;
     end;

type TExternalNames = class(TObject)
private
     FExtSheets: TExtSheetList;
     FSupBooks: TSupBookList;
     FExternalLookup: TExternalLookup;
     FExtSeek: TExternalSeek;
     FFilePath: WideString;

     function GetAsString(SheetIndex, NameIndex: integer): WideString;
public
     constructor Create;
     destructor Destroy; override;
     procedure Clear;
     procedure UpdateIntSupbooks(TabCount: integer);
     function  IsSelf(SheetIndex: integer): integer;
     function  AddSelf(SheetIndex,TabCount: integer): integer;
     function  AddRef(Path,Filename,SheetName: WideString; var Index: integer): boolean;
     function  IndexByName(Path,Filename,Name: WideString; var Index,NameIndex: integer): boolean;
     function  GetNameValue(SheetIndex, NameIndex: integer): TFormulaValue;
     function  GetValue(Index,Col,Row: integer): TFormulaValue;
     function  ExtSeekValue(Filename: WideString; SheetIndex,Col,Row: integer): TFormulaValue;

     procedure SetSUPBOOK     (P: PRecSUPBOOK);
     procedure SetEXTERNSHEET (P: PByteArray);
     procedure SetCRN         (SheetIndex: integer; P: PRecCRN; Size: word);
     procedure SetEXTERNNAME  (P: PRecEXTERNNAME8);

     procedure WriteRecords   (Stream: TXLSStream);

     property AsString[SheetIndex,NameIndex: integer]: WideString read GetAsString;
     property ExternalLookup: TExternalLookup read FExternalLookup write FExternalLookup;
     property FilePath: WideString read FFilePath write FFilePath;
     end;

type
//:# Names that referrers to areas on the worksheets.
//: Use TInternalName to create a name that can be used in formulas.
//: TInternalName is also used to define source areas for built in names,
//: such as print areas.
    TInternalName = class(TCollectionItem)
private
     FOptions: word;
     FKeyShortcut: byte;
     FTabIndex: word;
     FSheetIndex: word;
     // Do not change FName to WideString. Used to store coded names.
     FName: string;
     FNameDef: TDynByteArray;
     FCustomMenu: string;
     FDescription: string;
     FHelpTopic: string;
     FStatusBar: string;
     FLoadedFormFile: boolean;

     procedure SetDefinition(const Value: string);
     function  GetDefinition: string;
     function  GetName: WideString;
     procedure SetName(const Value: WideString);
     function  GetBuiltInName: TBuiltInName;
     procedure SetBuiltInName(const Value: TBuiltInName);
     procedure ReadPropNameName(Reader: TReader);
     procedure WritePropNameName(Writer: TWriter);
     procedure ReadPropNameDef(Reader: TReader);
     procedure WritePropNameDef(Writer: TWriter);
     function  GetCol1: integer;
     function  GetCol2: integer;
     function  GetRow1: integer;
     function  GetRow2: integer;
protected
     procedure DefineProperties(Filer: TFiler); override;

     property Options: word read FOptions write FOptions;
     property Unknown: word read FTabIndex write FTabIndex;
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     //: @exclude
     procedure Set_NAME(P: PRecNAME);
     //: @exclude
     procedure WriteRecords(Stream: TXLSStream);
     //:# Returns True if the area is a single cell.
     function  NameIsCell: boolean;
     //:# Returns True if the area is an area of more than one cell.
     function  NameIsArea: boolean;

     //: @exclude
     property NameDef: TDynByteArray read FNameDef write FNameDef;
     //: @exclude
     property KeyShortcut: byte read FKeyShortcut write FKeyShortcut;
     property NameName: string read FName write FName;
     property CustomMenu: string read FCustomMenu write FCustomMenu;
     property Description: string read FDescription write FDescription;
     property HelpTopic: string read FHelpTopic write FHelpTopic;
     property StatusBar: string read FStatusBar write FStatusBar;
//     property LoadedFormFile: boolean read FLoadedFormFile;
published
     //:# The name of the internal name.
     property Name: WideString read GetName write SetName stored False;
     //:# The definition of the name.
     //: The definition is in the format as a formula, such as Sheet1!$D$4:$G$10
     property Definition: string read GetDefinition write SetDefinition stored False;
     property SheetIndex: word read FSheetIndex write FSheetIndex;
     //:# If the name is a built in name.
     //: Use BuiltInName to set the type of built in name.
     property BuiltInName: TBuiltInName read GetBuiltInName write SetBuiltInName stored False;
     //: The left column of the name area.
     property Col1: integer read GetCol1;
     //: The right column of the name area.
     property Col2: integer read GetCol2;
     //: The top row of the name area.
     property Row1: integer read GetRow1;
     //: The bottom row of the name area.
     property Row2: integer read GetRow2;
     end;

type      
//:# List of internal names.
     TInternalNames = class(TCollection)
private
     FEncoder: TEncodeFormula;
     function GetItems(Index: integer): TInternalName;
protected
     FOwner: TPersistent;
     FGetNameMethod: TGetNameEvent;

     function  GetOwner: TPersistent; override;
     function  FindUniqueName: string;
     procedure DeleteBuiltIn(BuiltInName: TBuiltInName; SheetIndex,ExcludeIndex: integer);
public
     constructor Create(AOwner: TPersistent; GetNameMethod: TGetNameEvent; Encoder: TEncodeFormula);
     destructor Destroy; override;
     //:# Add a new TInternalName object.
     function  Add: TInternalName;
     //:# Find an internal name.
     //: Searches the list of names for the name given by AName. The search is
     //: case incensitive. If the name is found, FindName returnes the index of
     //: it. When not found, -1 is returned.
     function  FindName(AName: WideString): integer;
     //: @exclude.
     procedure SetNAME(P: PRecNAME);
     //: @exclude.
     procedure WriteRecords(Stream: TXLSStream);
     procedure AddBuiltInName(NameId: TBuiltInName; Sheet: integer; Definition: TDynByteArray);
     function  AddWorkbookArea(AName,Formula: WideString): boolean;

     //: The TInternalName items in the list.
     property Items[Index: integer]: TInternalName read GetItems; default;
     end;

implementation

{$I XLSRWII2.inc}

{$ifdef ver130}
type PDouble = ^Double;
type PWord = ^word;
{$endif}

{ TExtSheetList }

procedure TExtSheetList.Add(Index, First, Last: integer);
var
  P: PExtSheetData;
begin
  if Index > Count then
    raise Exception.Create('Invalid sheet index in EXTSHEET');
  New(P);
  P.SupBookIndex := Index;
  P.FirstTab := First;
  P.LastTab := Last;
  inherited Add(P);
end;

procedure TExtSheetList.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FreeMem(Items[i]);
  inherited Clear;
end;

destructor TExtSheetList.Destroy;
begin
  Clear;
  inherited;
end;

function TExtSheetList.GetItems(Index: integer): PExtSheetData;
begin
  Result := PExtSheetData(inherited Items[Index]);
end;

procedure TExtSheetList.WriteRecords(Stream: TXLSStream);
var
  i: integer;
begin
  if Count > 0 then begin
    Stream.WriteHeader(BIFFRECID_EXTERNSHEET,2 + Count * 6);
    Stream.WWord(Count);
    for i := 0 to Count - 1 do begin
      Stream.WWord(Items[i].SupBookIndex);
      Stream.WWord(Items[i].FirstTab);
      Stream.WWord(Items[i].LastTab);
    end;
  end;
end;

{ TExternalNames }

// Assumes that all parameters are uppercase.
function TExternalNames.IndexByName(Path, Filename,Name: WideString; var Index, NameIndex: integer): boolean;
var
  i,j,SupBook: integer;
begin
  for i := 0 to FExtSheets.Count - 1 do begin
    SupBook := FExtSheets[i].SupBookIndex;
    if MyWideUppercase(FSupBooks[SupBook].Filename) = (Path + Filename) then begin
      for j := 0 to FSupBooks[SupBook].FExtNames.Count - 1 do begin
        if MyWideUppercase(FSupBooks[SupBook].FExtNames[j].Name) = Name then begin
          Index := i;
          NameIndex := j;
          Result := True;
          Exit;
        end;
      end;
    end;
  end;
  Result := False;
end;

// Assumes that all parameters are uppercase.
function TExternalNames.AddRef(Path, Filename,SheetName: WideString; var Index: integer): boolean;
var
  i,j,SupBook: integer;
begin
  Result := False;
  for i := 0 to FExtSheets.Count - 1 do begin
    SupBook := FExtSheets[i].SupBookIndex;
    if MyWideUppercase(FSupBooks[SupBook].Filename) = (Path + Filename) then begin
      for j := 0 to FSupBooks[SupBook].Count - 1 do begin
        if MyWideUppercase(FSupBooks[SupBook].Sheets[j].Name) = SheetName then begin
          Index := i;
          Result := True;
          Exit;
        end;
      end;
    end;
  end;
  FSupBooks.Add(Path + Filename,Sheetname);
  Index := FSupBooks.Count - 1;
  FExtSheets.Add(Index,0,0);
end;

function TExternalNames.AddSelf(SheetIndex,TabCount: integer): integer;
var
  i,SelfIndex: integer;
begin
  SelfIndex := -1;
  for Result := 0 to FExtSheets.Count - 1 do begin
    i := FExtSheets[Result].SupBookIndex;
    if FSupBooks[i].FEncoded = $0401 then begin
      SelfIndex := i;
      if (SheetIndex <= FExtSheets[Result].FirstTab) and (SheetIndex >= FExtSheets[Result].LastTab) then
        Exit;
    end;
  end;
  if SelfIndex < 0 then
    SelfIndex := FSupBooks.AddEncodec(TabCount,$0401);
  FExtSheets.Add(SelfIndex,SheetIndex,SheetIndex);
  Result := FExtSheets.Count - 1;
end;

procedure TExternalNames.Clear;
begin
  FExtSheets.Clear;
  FSupBooks.Clear;
end;

constructor TExternalNames.Create;
begin
  FExternalLookup := elCached;
  FExtSheets := TExtSheetList.Create;
  FSupBooks := TSupBookList.Create;
  FExtSeek := TExternalSeek.Create;
end;

destructor TExternalNames.Destroy;
begin
  FExtSheets.Free;
  FSupBooks.Free;
  FExtSeek.Free;
  inherited;
end;