drawingobj2.pas

一个经典的读写Excel的控件

unit DrawingObj2;

{
********************************************************************************
******* 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,     **
** expressedor 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.                                                     **
********************************************************************************
}

{$I XLSRWII2.inc}

{$B-}

interface

uses Classes, SysUtils, DrawingObjAnchor2, XLSUtils2, BIFFRecsII2, Escher2,
     XLSStream2, EscherTypes2, Graphics, FormulaHandler2;

// Don't works with D5
{
type TDrwTextStrings = class(TStrings)
private
    FText: string;

    function GetStrPos(Index: integer; var P,N: integer): boolean;
protected
    function GetCount: Integer; override;
    function Get(Index: Integer): string; override;
public
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    end;
}


type
//: Base class for drawing objects with text.
    TCustomDrwText = class(TDrwAnchor)
private
     FName: string;
     procedure SetName(const Value: string);
     function  GetText: WideString;
     procedure SetText(const Value: WideString);
     function  GetFormatting(Index: integer): TRecTXORUN;
protected
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     procedure SetShape(const Value: TShapeClientAnchor); override;
     procedure LoadFromStream(Stream: TStream);
     procedure LoadFromFile(Filename: WideString);

     property Formatting[Index: integer]: TRecTXORUN read GetFormatting;
published
     //: The name of the object.
     property Name: string read FName write SetName;
     //: The text. Texts can be max 32767 characters long.
     property Text: WideString read GetText write SetText;
     end;

type
//: Text box drawing object.
    TDrwText = class(TCustomDrwText)
private
protected
public
     constructor Create(Collection: TCollection); override;
published
     end;

type
//: List for text box drawing objects.
    TDrwTexts = class(TCollection)
private
     function  GetDrwText(Index: integer): TDrwText;
protected
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;
     FFileAdd: boolean;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing);
     //: Add a new TDrwText.
     function  Add: TDrwText;
     //: @exclude.
     procedure AddFromFile(Shape: TShapeClientAnchor);
     //: Remove all objects in the list.
     procedure Clear;

     //: Items in the list.
     property Items[Index: integer]: TDrwText read GetDrwText; default;
     end;

type
//: Cell note drawing object.
    TDrwNote = class(TCustomDrwText)
private
     procedure SetCellCol(const Value: integer);
     procedure SetCellRow(const Value: integer);
     function  GetCellCol: integer;
     function  GetCellRow: integer;
     function  GetAuthor: WideString;
     procedure SetAuthor(const Value: WideString);
protected
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     procedure Clear;
published
     //: The cell column that the note is attached to.
     property CellCol: integer read GetCellCol write SetCellCol;
     //: The cell row that the note is attached to.
     property CellRow: integer read GetCellRow write SetCellRow;
     //: Author text of the note.
     property Author: WideString read GetAuthor write SetAuthor;
     end;

type
//: List for notes drawing objects.
    TDrwNotes = class(TCollection)
private
     function  GetDrwNote(Index: integer): TDrwNote;
protected
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;
     FFileAdd: boolean;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing);
     //: Add a new TDrwNote.
     function  Add: TDrwNote;
     //: @exclude
     procedure AddFromFile(Shape: TShapeClientAnchor);
     //: Remove all objects in the list.
     procedure Clear;
     //: Find a note by the cell column and row it is attached to. If found,
     //: the index in the list is return. When not found, -1 is returned.
     function  FindByColRow(Col,Row: integer): integer;

     //: Items in the list.
     property Items[Index: integer]: TDrwNote read GetDrwNote; default;
     end;

type
//: Basic drawing objects. Default object type when creating a new object is
//: bstArrow.
    TDrwBasic = class(TDrwAnchor)
private
     function  GetLineColor: TColor;
     procedure SetLineColor(const Value: TColor);
     function  GetShapeType: TBasicShapeType;
     procedure SetShapeType(const Value: TBasicShapeType);
     function  GetFillColor: TColor;
     procedure SetFillColor(const Value: TColor);
protected
public
     constructor Create(Collection: TCollection); override;
published
     //: Type of drawing object. See @link(TBasicShapeType).
     property ShapeType: TBasicShapeType read GetShapeType write SetShapeType;
     //: Line color of the object.
     property LineColor: TColor read GetLineColor write SetLineColor;
     //: Fill color of the object. Only for objects that have a fill color,
     //: such as ellipses and rectangles.
     property FillColor: TColor read GetFillColor write SetFillColor;
     end;

type
//: List of basic drawing objects.
    TDrwBasics = class(TCollection)
private
     function  GetDrwBasic(Index: integer): TDrwBasic;
protected
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;
     FFileAdd: boolean;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing);
     // Add a new TDrwBasic.
     function  Add: TDrwBasic;
     //: @exclude
     procedure AddFromFile(Shape: TShapeClientAnchor);
     //: Remove all objects in the list.
     procedure Clear;

     //: Items in the list.
     property Items[Index: integer]: TDrwBasic read GetDrwBasic; default;
     end;

type
//: Autoshape drawing objects. Default object type when creating a new object is
//: astSun.
    TDrwAutoShape = class(TDrwAnchor)
private
     function  GetAutoShapeType: TAutoShapeType;
     function  GetFillColor: TColor;
     function  GetLineColor: TColor;
     procedure SetAutoShapeType(const Value: TAutoShapeType);
     procedure SetFillColor(const Value: TColor);
     procedure SetLineColor(const Value: TColor);
protected
public
     constructor Create(Collection: TCollection); override;
published
     //: Type of autoshape object. See @link(TAutoShapeType)
     property ShapeType: TAutoShapeType read GetAutoShapeType write SetAutoShapeType;
     //: Line color of the object.
     property LineColor: TColor read GetLineColor write SetLineColor;
     //: Fill color of the object.
     property FillColor: TColor read GetFillColor write SetFillColor;
     end;

type
//: List of TAutoShape objects.
    TDrwAutoShapes = class(TCollection)
private
     function  GetDrwAutoShape(Index: integer): TDrwAutoShape;
protected
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;
     FFileAdd: boolean;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing);
     //: Add a new TDrwAutoShape.
     function  Add: TDrwAutoShape;
     //: @exclude
     procedure AddFromFile(Shape: TShapeClientAnchor);
     //: Remove all objects in the list.
     procedure Clear;

     //: Items in the list.
     property Items[Index: integer]: TDrwAutoShape read GetDrwAutoShape; default;
     end;

type
//: Picture drawing object. In order to save space, the picture itself is
//: in @link(TXLSReadWriteII2.MSOPictures). The TDrwPicture object is only a
//: link to a TMSOPicture object. Before a picture can be inserted into a
//: worksheet, it must first have been loaded into a TMSOPicture object.
    TDrwPicture = class(TDrwAnchor)
private
     function  GetPictureId: integer;
     function  GetPictureName: WideString;
     procedure SetPictureId(const Value: integer);
     procedure SetPictureName(const Value: WideString);
protected
public
     constructor Create(Collection: TCollection); override;
published
     //: @exclude
     property PictureId: integer read GetPictureId write SetPictureId;
     //: The name of the picture. This shall be the same name as the
     //: filename in @link(TXLSReadWriteII2.MSOPictures).
     property PictureName: WideString read GetPictureName write SetPictureName;
     end;

type
//: List of TDrwPicture objects.
    TDrwPictures = class(TCollection)
private
     function  GetDrwPicture(Index: integer): TDrwPicture;
protected
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;
     FFileAdd: boolean;

     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing);
     //: Add a new TDrwPicture.
     function  Add: TDrwPicture;
     //: @exclude
     procedure AddFromFile(Shape: TShapeClientAnchor);
     //: Remove all objects in the list.
     procedure Clear;

     //: Items in the list.
     property Items[Index: integer]: TDrwPicture read GetDrwPicture; default;
     end;

type
// List of all lists with drawing objects in a worksheet.
   TDrawingObjects = class(TPersistent)
private
     FOwner: TPersistent;
     FDrawing: TEscherDrawing;

     FTexts: TDrwTexts;
     FNotes: TDrwNotes;
     FBasics: TDrwBasics;
     FAutoShapes: TDrwAutoShapes;
     FPictures: TDrwPictures;
protected
     function  GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; Drawing: TEscherDrawing; FormulaHandler: TFormulaHandler);
     destructor Destroy; override;
     procedure Clear;
published
     // Text box drawing objects.
     property Texts: TDrwTexts read FTexts write FTexts;
     // Cell notes drawing objects.
     property Notes: TDrwNotes read FNotes write FNotes;
     // Basic drawing objects.
     property Basics: TDrwBasics read FBasics write FBasics;
     // Autoshape drawing objects.
     property AutoShapes: TDrwAutoShapes read FAutoShapes write FAutoShapes;
     // Picture drawing objects.
     property Pictures: TDrwPictures read FPictures write FPictures;
     end;

implementation

uses SheetData2, XLSReadWriteII2;

{ TDrwTextStrings }

{
procedure TDrwTextStrings.Clear;
begin
  inherited;
  FText := '';
end;

procedure TDrwTextStrings.Delete(Index: Integer);
var
  S: string;
  P,N: integer;
begin
  inherited;
  if GetStrPos(Index,P,N) then begin
    S := FText;
    System.Delete(S,P,N);
    FText := S;
  end;
end;

function TDrwTextStrings.Get(Index: Integer): string;
var
  P,N: integer;
begin
  if GetStrPos(Index,P,N) then
    Result := System.Copy(FText,P,N)
  else
    Result := '';
end;

function TDrwTextStrings.GetCount: Integer;
var
  i: integer;
begin
  Result := 0;
  if FText <> '' then
    Inc(Result);
  for i := 1 to Length(FText) do begin
    if FText[i] = #10 then
      Inc(Result);
  end;
end;

function TDrwTextStrings.GetStrPos(Index: integer; var P,N: integer): boolean;
var
  i: integer;
begin
  Result := True;
  if FText = '' then
    Exit;
  P := 0;
  if Index <= 0 then begin
    N := 0;
    while (N <= Length(FText)) and (FText[N] <> #10) do
      Inc(N);
    Exit;
  end;
  for i := 1 to Length(FText) do begin
    if FText[i] = #10 then begin
      Dec(Index);
      if Index <= 0 then begin
        P := i + 1;
        N := P;
        while (N <= Length(FText)) and (FText[N] <> #10) do
          Inc(N);
        N := N - P;
        Exit;
      end;
    end;
  end;
  Result := False;
end;

function TDrwTextStrings.IndexOf(const S: string): Integer;
var
  i,P: integer;
begin
  P := Pos(S,FText);
  if P > 0 then begin
    Result := 0;
    for i := 0 to P do begin
      if FText[i] = #10 then
        Inc(Result);
    end;
  end
  else
    Result := -1;
end;

procedure TDrwTextStrings.Insert(Index: Integer; const S: string);
var
  Str: string;
  P,N: integer;
begin
  inherited;
  if GetStrPos(Index,P,N) then begin
    Str := FText;
    System.Insert(S + #10,Str,P);
    FText := Str;
  end
  else
    FText := FText + #10 + S;
end;
}

{ TCustomDrwText }

constructor TCustomDrwText.Create(Collection: TCollection);
begin
  inherited;
end;

destructor TCustomDrwText.Destroy;
begin
  inherited;
end;

function TCustomDrwText.GetFormatting(Index: integer): TRecTXORUN;
begin
  if (Index < 0) or (Index > High(TShapeOutsideMsoBaseText(FShape.ExShape).Formatting)) then
    raise Exception.Create('Index out of range.');
  Result := TShapeOutsideMsoBaseText(FShape.ExShape).Formatting[Index];
end;

function TCustomDrwText.GetText: WideString;
begin
  Result := TShapeOutsideMsoBaseText(FShape.ExShape).Text;
end;

procedure TCustomDrwText.LoadFromFile(Filename: WideString);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(Filename,fmOpenRead);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TCustomDrwText.LoadFromStream(Stream: TStream);
var
  S: string;
begin
  SetLength(S,Stream.Size);
  Stream.Read(Pointer(S)^,Stream.Size);
  SetText(S);
end;

procedure TCustomDrwText.SetName(const Value: string);
begin
  FName := Value;
end;

procedure TCustomDrwText.SetShape(const Value: TShapeClientAnchor);
begin
  inherited SetShape(Value);
//   TDrwTextStrings(FStrings).FOBJ := TOBJNote(Value);
end;

procedure TCustomDrwText.SetText(const Value: WideString);
begin
  if Length(Value) > MAX_EXCEL_STRSZ then
    TShapeOutsideMsoBaseText(FShape.ExShape).Text := Copy(Value,1,MAX_EXCEL_STRSZ)
  else
    TShapeOutsideMsoBaseText(FShape.ExShape).Text := Value;
end;

{ TDrwText }

constructor TDrwText.Create(Collection: TCollection);
begin
  if not TDrwTexts(Collection).FFileAdd then
    FShape := TDrwTexts(Collection).FDrawing.AddTextBox;
  inherited Create(Collection);
  FName := 'Text ' + IntToStr(ID);
end;