escher2.pas

一个经典的读写Excel的控件

  Result.FOPT.AddValue(msooptFillColor,$08000041);
  Result.FOPT.AddValue(msooptLineColor,$08000040);
  Result.FOPT.FItemCount := Result.FOPT.Count;

  FGroup.Add(Result);
  // 040523
  // Inc(FDG.ShapeCount);
  GetMem(PBuf,MAXRECSZ_97);
  try
    Header.RecID := OBJREC_CMO;
    Header.Length := SizeOf(TObjCMO);
    FillChar(PBuf^,SizeOf(TObjCMO),#0);
    PObjCMO(PBuf).ObjType := OBJTYPE_MICROSOFT_OFFICE_DRAWING;
    PObjCMO(PBuf).ObjId := GetObjId;
    PObjCMO(PBuf).Options := $6011;
    Result.FOBJ.AddRec(Header,PBuf);

    Header.RecID := OBJREC_END;
    Header.Length := 0;
    Result.FOBJ.AddRec(Header,PBuf);
  finally
    FreeMem(PBuf);
  end;
end;

function TEscherDrawing.AddPicture: TShapeClientAnchor;
var
  PBuf: PByteArray;
  Header: TBIFFHeader;
begin
  SetRootData;

  Result := TShapeClientAnchor.Create;
  Result.FShapeType := msosptPictureFrame;
  Result.FInterface := Nil;
  Result.FSpId := GetSpId;
  Result.FOptions := SpOptHaveAnchor + SpOptHaveSpt {+ SpOptFlipH + SpOptFlipV};

  Result.FCLIENTANCHOR.Col1 := 1;
  Result.FCLIENTANCHOR.Row1 := 1;
  Result.FCLIENTANCHOR.Col2 := 3;
  Result.FCLIENTANCHOR.Row2 := 7;

//  Result.FOPT.AddValue(msooptFLockAgainstGrouping,$00800080);
  Result.FOPT.AddValue(msooptPib,$00000000,True);
  Result.FOPT.AddString(msooptPibName,'[???]');
//  Result.FOPT.AddValue(msooptFBackground,$00100010);
  Result.FOPT.FItemCount := Result.FOPT.Count;

  FGroup.Add(Result);
  // 040523
  // Inc(FDG.ShapeCount);
  GetMem(PBuf,MAXRECSZ_97);
  try
    Header.RecID := OBJREC_CMO;
    Header.Length := SizeOf(TObjCMO);
    FillChar(PBuf^,SizeOf(TObjCMO),#0);
    PObjCMO(PBuf).ObjType := OBJTYPE_PICTURE;
    PObjCMO(PBuf).ObjId := GetObjId;
    PObjCMO(PBuf).Options := $6011;
    Result.FOBJ.AddRec(Header,PBuf);

    Header.RecID := OBJREC_CF;
    Header.Length := 2;
    PWordArray(PBuf)[0] := $FFFF;
    Result.FOBJ.AddRec(Header,PBuf);

    Header.RecID := OBJREC_PIOGRBIT;
    Header.Length := 2;
    PWordArray(PBuf)[0] := $0000;
    Result.FOBJ.AddRec(Header,PBuf);

    Header.RecID := OBJREC_END;
    Header.Length := 0;
    Result.FOBJ.AddRec(Header,PBuf);
  finally
    FreeMem(PBuf);
  end;
end;

function TEscherDrawing.AddChart: TShapeClientAnchor;
var
  PBuf: PByteArray;
  Header: TBIFFHeader;
begin
  SetRootData;

  Result := TShapeClientAnchor.Create;
  Result.FShapeType := msosptHostControl;
  Result.FInterface := TShapeOutsideMsoChart.Create(GetObjId,FParent,FFonts);
  Result.FSpId := GetSpId;
  Result.FOptions := SpOptHaveAnchor + SpOptHaveSpt;

  Result.FCLIENTANCHOR.Col1 := 2;
  Result.FCLIENTANCHOR.Row1 := 1;
  Result.FCLIENTANCHOR.Col2 := 8;
  Result.FCLIENTANCHOR.Row2 := 16;

  Result.FOPT.AddValue(msooptFLockAgainstGrouping,$01040104);
  Result.FOPT.AddValue(msooptFFitTextToShape,$00080008);
  Result.FOPT.AddValue(msooptFillColor,$0800004E);
  Result.FOPT.AddValue(msooptFillBackColor,$0800004D);
  Result.FOPT.AddValue(msooptFNoFillHitTest,$00100010);
  Result.FOPT.AddValue(msooptLineColor,$0800004D);
  Result.FOPT.AddValue(msooptFNoLineDrawDash,$00100010);
  Result.FOPT.AddValue(msooptShadowObscured,$00020000);
  Result.FOPT.FItemCount := Result.FOPT.Count;

  FGroup.Add(Result);
  // 040523
  // Inc(FDG.ShapeCount);

  GetMem(PBuf,MAXRECSZ_97);
  try
    Header.RecID := OBJREC_CMO;
    Header.Length := SizeOf(TObjCMO);
    FillChar(PBuf^,SizeOf(TObjCMO),#0);
    PObjCMO(PBuf).ObjType := OBJTYPE_CHART;
    PObjCMO(PBuf).ObjId := GetObjId;
    PObjCMO(PBuf).Options := $6011;
    Result.FOBJ.AddRec(Header,PBuf);

    Header.RecID := OBJREC_END;
    Header.Length := 0;
    Result.FOBJ.AddRec(Header,PBuf);
  finally
    FreeMem(PBuf);
  end;
end;

procedure TEscherDrawing.SetBlipRefCount;

procedure SetRefCount(Shape: TShape);
var
  i,Id: integer;
begin
  if Shape is TShapeGroup then begin
    for i := 0 to TShapeGroup(Shape).Count - 1 do
      SetRefCount(TShapeGroup(Shape)[i]);
  end
  else if Shape.FShapeType = msosptPictureFrame then begin
    Id := Shape.FOPT.FindValue(msooptPib);
    if Id > TMSOPictures(FParent).Count then
      raise Exception.Create('Unassigned picture in file.');
    // This is wrong, but will ensure that all added pictures are valid.
    if (Id > 0) and (TMSOPictures(FParent)[Id - 1].FRefCount = 0) then
//      TMSOPictures(FParent)[Id - 1].FRefCount := TMSOPictures(FParent)[Id - 1].FRefCount + 1;
      TMSOPictures(FParent)[Id - 1].FRefCount := 1;
  end;
end;

begin
  SetRefCount(FGroup);
end;

function TEscherDrawing.GetObjId: integer;
begin
  Inc(FMaxObjId);
  Result := FMaxObjId;
end;

procedure TEscherDrawing.AddEmpty;
begin
  SetRootData;
  // 040523                                                                     
  // Inc(FDG.ShapeCount);
end;

procedure TEscherDrawing.Move(Index: integer; DestCol, DestRow: word);
var
  dCol,dRow: integer;
  Shape: TShapeClientAnchor;
begin
  if FGroup[Index] is TShapeClientAnchor then
    Shape := TShapeClientAnchor(FGroup[Index])
  else if FGroup[Index] is TShapeChildAnchor then
    raise Exception.Create('Not implemented: Move shape child anchor')
  else
    raise Exception.Create('Dont know how to Move this shape');
  dCol := Shape.Col2 - Shape.Col1;
  dRow := Shape.Row2 - Shape.Row1;
  Shape.Col1 := DestCol;
  Shape.Col2 := dCol + DestCol;
  Shape.Row1 := DestRow;
  Shape.Row2 := dRow + DestRow;
  if (Shape.FInterface <> Nil) and (Shape.FInterface is TShapeOutsideMsoNote) then begin
    TShapeOutsideMsoNote(Shape.FInterface).FCellCol := DestCol;
    TShapeOutsideMsoNote(Shape.FInterface).FCellRow := DestRow;
  end;
end;

procedure TEscherDrawing.Copy(Index: integer; DestCol, DestRow: word);
var
  Shape: TShape;
begin
  if FGroup[Index] is TShapeGroup then
    Shape := TShapeGroup.Create(Self)
  else if FGroup[Index] is TShapeClientAnchor then
    Shape := TShapeClientAnchor.Create
  else if FGroup[Index] is TShapeChildAnchor then
    Shape := TShapeChildAnchor.Create
  else
    raise Exception.Create('Dont know how to Copy this shape');
  FGroup[Index].Assign(Shape);
  Shape.FSpId := GetSpId;
  if Shape.FInterface <> Nil then begin
    Shape.FInterface.FObjId := GetObjId;
    PObjCMO(@Shape.FOBJ[0].Data).ObjId := Shape.FInterface.FObjId;
  end
  else
    PObjCMO(@Shape.FOBJ[0].Data).ObjId := GetObjId;
  FGroup.Add(Shape);
  if not(FGroup[Index] is TShapeChildAnchor) then
    Move(FGroup.Count - 1,DestCol,DestRow);
end;

procedure TEscherDrawing.Copy(Col1, Row1, Col2, Row2, DestCol, DestRow: word);
var
  i: integer;
  Shp: TShapeClientAnchor;
  Note: TShapeOutsideMsoNote;
begin
  for i := 0 to FGroup.Count - 1 do begin
    if (FGroup[i] is TShapeClientAnchor) then begin
      Shp := TShapeClientAnchor(FGroup[i]);
      if (Shp.FInterface <> Nil) and (Shp.FInterface is TShapeOutsideMsoNote) then begin
        Note := TShapeOutsideMsoNote(Shp.FInterface);
        if (Note.CellCol >= Col1) and (Note.CellRow >= Row1) and (Note.CellCol <= Col2) and (Note.CellRow <= Row2) then
          Copy(i,(Note.CellCol - Col1) + DestCol,(Note.CellRow - Row1) + DestRow);
      end
      else if (Shp.Col1 >= Col1) and (Shp.Row1 >= Row1) and (Shp.Col1 <= Col2) and (Shp.Row1 <= Row2) then begin
        Copy(i,(Shp.Col1 - Col1) + DestCol,(Shp.Row1 - Row1) + DestRow);
      end
    end;
  end;
end;

procedure TEscherDrawing.CopyList(List: TList; Col1, Row1, Col2, Row2: integer);
var
  i: integer;
  Shp: TShapeClientAnchor;
  Note: TShapeOutsideMsoNote;
begin
  for i := 0 to FGroup.Count - 1 do begin
    if (FGroup[i] is TShapeClientAnchor) then begin
      Shp := TShapeClientAnchor(FGroup[i]);
      if (Shp.FInterface <> Nil) and (Shp.FInterface is TShapeOutsideMsoNote) then begin
        Note := TShapeOutsideMsoNote(Shp.FInterface);
        if (Note.CellCol >= Col1) and (Note.CellRow >= Row1) and (Note.CellCol <= Col2) and (Note.CellRow <= Row2) then
          List.Add(Shp);
      end
      else if (Shp.Col1 >= Col1) and (Shp.Row1 >= Row1) and (Shp.Col1 <= Col2) and (Shp.Row1 <= Row2) then begin
        List.Add(Shp);
      end
    end;
  end;
end;

procedure TEscherDrawing.InsertList(List: TList; DestCol,DestRow: integer);
var
  i: integer;
  Shape: TShape;
begin
  for i := 0 to List.Count - 1 do begin
    if TObject(List[i]) is TShapeGroup then
      Shape := TShapeGroup.Create(Self)
    else if TObject(List[i]) is TShapeClientAnchor then
      Shape := TShapeClientAnchor.Create
    else if TObject(List[i]) is TShapeChildAnchor then
      Shape := TShapeChildAnchor.Create
    else
      raise Exception.Create('Dont know how to Copy this shape');
    if FGroup.Count <= 0 then
      SetRootData;
    TShape(List[i]).Assign(Shape);
    Shape.FSpId := GetSpId;
    PObjCMO(@Shape.FOBJ[0].Data).ObjId := GetObjId;
    if Shape.FInterface <> Nil then
      Shape.FInterface.FObjId := PObjCMO(@Shape.FOBJ[0].Data).ObjId;
    FGroup.Add(Shape);
    if Assigned(FFileReadShapeEvent) then
      FFileReadShapeEvent(Self,Shape);
{
    if not(Shape is TShapeChildAnchor) then
      Move(FGroup.Count - 1,TShapeClientAnchor(Shape).Col1 + DestCol,TShapeClientAnchor(Shape).Row1 + DestRow);
}
  end;
end;

procedure TEscherDrawing.DeleteList(List: TList);
var
  i: integer;
begin
  for i := 0 to List.Count - 1 do
    FGroup.DeleteBySpId(TShape(List[i]).SpId);
end;

procedure TEscherDrawing.Move(Col1, Row1, Col2, Row2, DestCol, DestRow: word);
var
  i: integer;
  C,R: word;
  Shp: TShapeClientAnchor;
begin
  for i := 0 to FGroup.Count - 1 do begin
    if (FGroup[i] is TShapeClientAnchor) then begin
      Shp := TShapeClientAnchor(FGroup[i]);
      if (Shp.FInterface <> Nil) and (Shp.FInterface is TShapeOutsideMsoNote) then begin
        C := TShapeOutsideMsoNote(Shp.FInterface).FCellCol;
        R := TShapeOutsideMsoNote(Shp.FInterface).FCellRow;
      end
      else begin
        C := Col1;
        R := Row1;
      end;
      if (C >= Col1) and (R >= Row1) and (C <= Col2) and (R <= Row2) then begin
        Move(i,(C - Col1) + DestCol,(R - Row1) + DestRow);
        if (Shp.FInterface <> Nil) and (Shp.FInterface is TShapeOutsideMsoNote) then begin
          TShapeOutsideMsoNote(Shp.FInterface).FCellCol := (C - Col1) + DestCol;
          TShapeOutsideMsoNote(Shp.FInterface).FCellRow := (R - Row1) + DestRow;
        end
      end;
    end;
  end;
end;

{ TMSORecords }

procedure TMSORecords.Add(Header: TMSOHeader; Data: PByteArray);
var
  P,P2: PByteArray;
begin
  if (Header.VerInst and $0F) = $0F then begin
    GetMem(P,SizeOf(TMSOHeader));
    System.Move(Header,P^,SizeOf(TMSOHeader));
  end
  else begin
    GetMem(P,Header.Length + SizeOf(TMSOHeader));
    System.Move(Header,P^,SizeOf(TMSOHeader));
    P2 := PByteArray(Integer(P) + SizeOf(TMSOHeader));
    System.Move(Data^,P2^,Header.Length);
  end;
  inherited Add(P);
end;

procedure TMSORecords.AddSP(ShapeType: word; SpId, Options: longword);
var
  P: PMSORecord;
begin
  GetMem(P,SizeOf(TMSOHeader) + SizeOf(TMSORecSP));
  P.VerInst := (ShapeType shl 4) + $02;
  PMSORecSP(@P.Data).SpId := SpId;
  PMSORecSP(@P.Data).Options := Options;
  inherited Add(P);
end;

procedure TMSORecords.Assign(Records: TMSORecords);
var
  i: integer;
  Header: TMSOHeader;
begin
  for i := 0 to Count - 1 do begin
    Header.VerInst := Version[i] + (Instance[i] shl 4);
    Header.FBT := FBT[i];
    Header.Length := Length[i];
    if (Header.VerInst and $0F) = $0F then
      Records.Add(Header,Nil)
    else
      Records.Add(Header,Data[i]);
  end;
end;

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

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

function TMSORecords.GetData(Index: integer): PByteArray;
begin
  Result := @PMSORecord(inherited Items[Index]).Data;
end;

function TMSORec