escher2.pas

一个经典的读写Excel的控件

     FNewDrawing: boolean;

     procedure SetDrawing(const Value: TEscherDrawing);
public
     procedure LoadFromStream(Stream: TXLSStream);
     procedure WriteToStream(Stream: TXLSStream);

     property FIDCL: TDGGRecFIDCL read FFIDCL;
     property Drawing: TEscherDrawing read FDrawing write SetDrawing;
     property NewDrawing: boolean read FNewDrawing write FNewDrawing;
     end;

     TDGG = class(TList)
private
     FMaxSpId: longword;
     FSavedShapes: longword;
     FSavedDrawings: longword;

     function GetItems(Index: integer): TDGGData;
public
     destructor Destroy; override;
     procedure Clear; override;
     procedure LoadFromStream(Stream: TXLSStream; var Length: integer; PBuf: PByteArray);
     procedure WriteToStream(Stream: TXLSStream; PBuf: PByteArray);

     property Items[Index: integer]: TDGGData read GetItems;
     end;

//: TMSOPicture is a storage for pictures in worksheets. All pictures are
//: loaded into common TMSOPicture objects, and when inserted into a worksheet,
//: a link to the TMSOPicture object is created. This in order to save space.
//: Bitmap (BMP) pictures in size over 32kb are not accepted by Excel. Use
//: JPEG or PNG formats for pictures over 32kb. If TPNGImage support is enabled
//: (defined in XLSRWII2.inc), bitmap (BMP) files larger than 256 bytes are
//: automatically converted to PNG images.
     TMSOPicture = class(TCollectionItem)
private
     FPicture: Pointer;
     FPictSize: integer;
     FPictType: TMSOBlipType;
     FRefCount: integer;
     FBlipName: WideString;
     FCompressed: boolean;
     FCompressedSize: integer;
     FHash: array[0..15] of byte;
     FFileBlipId: integer;

     FName: string;
     procedure SetFilename(const Value: WideString);
protected
     function  GetDisplayName: string; override;
     function  LoadFromStream(Stream: TXLSStream; var Length: integer; PBuf: PByteArray): boolean; overload;
     procedure WriteToStream(Stream: TXLSStream; PBuf: PByteArray);
     procedure MakeHash;

     property Picture: Pointer read FPicture;
     property PictSize: integer read FPictSize;
     property RefCount: integer read FRefCount write FRefCount;
     property BlipName: WideString read FBlipName write FBlipName;
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     //: Read a picture from a TStream.
     //: Stream is the TStream to read from. Name is the name of the picture.
     //: This name is later used to identify the picture, when it is inserted
     //: into a worksheet.
     //: PictType is the type of the picture.
     procedure LoadFromStream(Stream: TStream; Name: WideString; PictType: TMSOBlipType); overload;
     //: Read a picture from a file.
     procedure LoadFromFile(Filename: WideString);
     //: Save a picture to a TStream.
     procedure SaveToStream(Stream: TStream);
     //: Save a picture To a file.
     procedure SaveToFile(Filename: WideString);

     //: The type of the picture.
     property PictType: TMSOBlipType read FPictType;
     //: True if the picture is compressed. Metafile are stored compressed
     //: with zlib by Excel. If zlib not is used (defined in XLSRWII2.inc),
     //: these pictures can not be saved to files/streams. But they will of
     //: course reamin unchanged in the file.
     property Compressed: boolean read FCompressed;
     //: The comressed size of the picture.
     property CompressedSize: integer read FCompressedSize;
     //: The size of the picture.
     property PictureSize: integer read FPictSize;
     //: @exclude
     property PictureBuf: Pointer read FPicture;
     //: @exclude
     property FileBlipId: integer read FFileBlipId write FFileBlipId;
published
     //: The (file)name of the picture. This name is used to identify pictures
     //: when inserted into worksheets.
     property Filename: WideString read FBlipName write SetFilename;
     end;

     TEscherGroup = class(TCollection)
private
     function GetMSOPicture(Index: integer): TMSOPicture;
protected
     FOwner: TPersistent;
     FDGG: TDGG;
     FOPT: TOPT;
     FSplitMenuColors: array of RGBQUAD;
     FColorMRU: array of RGBQUAD;
     FUnknown: TMSORecords;
     FCurrSpIdBlock: integer;

     function  GetOwner: TPersistent; override;
     procedure ReadPictures(Stream: TXLSStream; Length: integer; PBuf: PByteArray);
     function  GetSpIdBlock: integer;
     procedure AssignDrawing(Drawing: TEscherDrawing);
     procedure UpdateDrawing(DgId: integer);
     procedure DeleteDrawing(DgId: integer);
public
     constructor Create(AOwner: TPersistent);
     destructor Destroy; override;
     procedure Clear;
     procedure AddDrawing(Drawing: TEscherDrawing; var DgId: word; var SpIdBlock: longword);
     procedure LoadFromStream(Stream: TXLSStream; PBuf: PByteArray);
     procedure WriteToStream(Stream: TXLSStream; PBuf: PByteArray);
     function  HasData: boolean;

     property Items[Index: integer]: TMSOPicture read GetMSOPicture; default;
     end;

     TMSOPictures = class(TEscherGroup)
private
protected
public
     function  Add: TMSOPicture;
     procedure GetBlipIds(List: TList);
     procedure ResetBlipRefCount;
     end;

function BlipFromExt(Filename: WideString): TMSOBlipType;

implementation

const SP_ID_BLOCK_SIZE = $0400;

function GetTxId: integer;
begin
  // Don't know the correct value for TxId...
  Result := Integer(GetTickCount) + Random($FFFF);
end;

procedure WriteMSOHeader(Stream: TXLSStream; Version: byte; Instance: word; FBT: word; Length: longword);
var
  Header: TMSOHeader;
begin
  Header.VerInst := Version + (Instance shl 4);
  Header.FBT := FBT;
  Header.Length := Length;
  Stream.Write(Header,SizeOf(TMSOHeader));
end;

function BlipFromExt(Filename: WideString): TMSOBlipType;
var
  Ext: WideString;
begin
  Ext := MyWideUpperCase(Copy(ExtractFileExt(Filename),2,MAXINT));
       if Ext = 'WMF'  then Result := msoblipWMF
  else if Ext = 'EMF'  then Result := msoblipEMF
  else if Ext = 'PICT' then Result := msoblipPICT
  else if Ext = 'JPG'  then Result := msoblipJPEG
  else if Ext = 'JPEG' then Result := msoblipJPEG
  else if Ext = 'PNG'  then Result := msoblipPNG
  else if Ext = 'BMP'  then Result := msoblipDIB
  else raise Exception.Create('Unknown picture type ' + Ext);
end;


{ TShape }

procedure TShape.Assign(Shape: TShape);
begin
  Shape.FSpId := 0;
  Shape.FShapeType := FShapeType;
  Shape.FOptions := FOptions;
  FOPT.Assign(Shape.FOPT);
  if FUnknown <> Nil then begin
    Shape.FUnknown := TMSORecords.Create;
    FUnknown.Assign(Shape.FUnknown);
  end;
  FOBJ.Assign(Shape.FOBJ);
  if FInterface <> Nil then begin
    if FInterface is TShapeOutsideMsoNote then
      Shape.FInterface := TShapeOutsideMsoNote.Create(0)
    else if FInterface is TShapeOutsideMsoBaseText then
      Shape.FInterface := TShapeOutsideMsoBaseText.Create(0)
    else
      raise Exception.Create('Can not assign this interface');
    FInterface.Assign(Shape.FInterface);
    Shape.FOPT.UpdateValue(msooptLTxid,GetTxId);
  end;
end;

constructor TShape.Create;
begin
  FOPT := TOPT.Create;
  FOBJ := TBaseRecordStorage.Create;
end;

destructor TShape.Destroy;
begin
  FOPT.Free;
  FOBJ.Free;
  FUnknown.Free;
  FInterface.Free;
  inherited;
end;

procedure TShape.SetShapeType(const Value: integer);
begin
  FShapeType := Value;
  case FShapeType of
    msosptLine,msosptArrow:
      PObjCMO(@FOBJ[0].Data).ObjType := OBJTYPE_LINE;
    msosptEllipse:
      PObjCMO(@FOBJ[0].Data).ObjType := OBJTYPE_OVAL;
    msosptRectangle:
      PObjCMO(@FOBJ[0].Data).ObjType := OBJTYPE_RECTANGLE;
  end;
end;

function TShape.Size: integer;
begin
            // SPCONTAINER
  Result := SizeOf(TMSOHeader) +
            // SP
            SizeOf(TMSOHeader) + SizeOf(TMSORecSP) +
            // OPT
            SizeOf(TMSOHeader) + FOPT.Size +
            // CLIENTDATA
            SizeOf(TMSOHeader);
  if FInterface is TShapeOutsideMsoBaseText then
    Inc(Result,SizeOf(TMSOHeader));
  if FUnknown <> Nil then
    Inc(Result,FUnknown.Size);
end;

procedure TShape.WriteToStream(Stream: TXLSStream; PBuf: PByteArray; WriteMSODRAWING: boolean);
var
  Sz: integer;
begin
  Sz := Size;
  if WriteMSODRAWING then begin
    if FInterface is TShapeOutsideMsoBaseText then
      Stream.WriteHeader(BIFFRECID_MSODRAWING,Sz - SizeOf(TMSOHeader))
    else
      Stream.WriteHeader(BIFFRECID_MSODRAWING,Sz);
  end;
  Dec(Sz,SizeOf(TMSOHeader));
  WriteMSOHeader(Stream,$0F,$0000,MSO_SPCONTAINER,Sz);
  WriteMSOHeader(Stream,$02,FShapeType,MSO_SP,SizeOf(TMSORecSP));
  Stream.Write(FSpId,SizeOf(FSpId));
  Stream.Write(FOptions,SizeOf(FOptions));
  FOPT.WriteToStream(Stream,PBuf);
  if FUnknown <> Nil then
    FUnknown.Write(Stream);
  if Self is TShapeClientAnchor then begin
    WriteMSOHeader(Stream,$00,$0000,MSO_CLIENTANCHOR,SizeOf(TMSORecCLIENTANCHOR));
    Stream.Write(TShapeClientAnchor(Self).FCLIENTANCHOR,SizeOf(TMSORecCLIENTANCHOR));
  end
  else if Self is TShapeChildAnchor then begin
    WriteMSOHeader(Stream,$00,$0000,MSO_CHILDANCHOR,SizeOf(TMSORecCHILDANCHOR));
    Stream.Write(TShapeChildAnchor(Self).FCHILDANCHOR,SizeOf(TMSORecCHILDANCHOR));
  end;
  WriteMSOHeader(Stream,$00,$0000,MSO_CLIENTDATA,0);

{
    Stream.WriteHeader(BIFFRECID_OBJ,FOBJ.Size);
    FOBJ.WriteAllRecs(Stream);
}

  if (FInterface <> Nil) and FInterface.FOwnsObjData then
    FInterface.Write(Stream)
  else begin
    Stream.WriteHeader(BIFFRECID_OBJ,FOBJ.Size);
    FOBJ.WriteAllRecs(Stream);
    if FInterface <> Nil then
      FInterface.Write(Stream);
  end;
end;

{ TShapeGroup }

procedure TShapeGroup.Add(Shape: TShape);
begin
  FList.Add(Shape);
end;

procedure TShapeGroup.Assign(Shape: TShape);
var
  i: integer;
  Shp: TShape;
begin
  inherited Assign(Shape);
  TShapeGroup(Shape).FSPGR := FSPGR;
  for i := 0 to Count - 1 do begin
    if Items[i] is TShapeGroup then
      Shp := TShapeGroup.Create(FDrawing)
    else if Items[i] is TShapeClientAnchor then
      raise Exception.Create('ClientAnchor in ShapeGroup')
    else if Items[i] is TShapeChildAnchor then
      Shp := TShapeChildAnchor.Create
    else
      raise Exception.Create('Dont know how to Copy this shape');
    Items[i].Assign(Shp);
    Shp.FSpId := FDrawing.GetSpId;
    TShapeGroup(Shape).Add(Shp);
  end;
end;

procedure TShapeGroup.Clear;

procedure ClearGroup(Group: TShapeGroup);
var
  i: integer;
begin
  for i := 0 to Group.Count - 1 do begin
    if Group[i] is TShapeGroup then
      ClearGroup(TShapeGroup(Group[i]));
    Group[i].Free;
  end;
  Group.FList.Clear;
end;

begin
  ClearGroup(Self);
end;

function TShapeGroup.Count: integer;
begin
  Result := FList.Count;
end;

constructor TShapeGroup.Create(Drawing: TEscherDrawing);
begin
  inherited Create;
  FDrawing := Drawing;
  FList := TList.Create;
end;

procedure TShapeGroup.Delete(Index: integer);
begin
  TShape(FList.Items[Index]).Free;
  FList.Delete(Index);
end;

procedure TShapeGroup.DeleteBySpId(SpId: integer);
var
  i: integer;
begin
  for i := 0 to FList.Count - 1 do begin
    if Integer(TShape(FList.Items[i]).FSpId) = SpId then begin
      Delete(i);
      Exit;
    end;
  end;
end;

destructor TShapeGroup.Destroy;
begin
  Clear;
  FList.Free;
  inherited;
end;

function TShapeGroup.GetItems(Index: integer): TShape;
begin
  Result := TShape(FList.Items[Index]);
end;

function TShapeGroup.PrivateSize: integer;
begin
  Result := inherited Size +
            // SPGRCONTAINER
            SizeOf(TMSOHeader) +
            // SPGR
            SizeOf(TMSOHeader) + SizeOf(TMSORecSPGR);
end;

function TShapeGroup.Size: integer;
var
  i: integer;
begin
  Result := PrivateSize;
  for i := 0 to FList.Count - 1 do
    Inc(Result,Items[i].Size);
end;

procedure TShapeGroup.WriteToStream(Stream: TXLSStream; PBuf: PByteArray; WriteMSODRAWING: boolean);
var
  Sz: integer;