drawingobj2.pas

一个经典的读写Excel的控件

{ TDrwTexts }

function TDrwTexts.Add: TDrwText;
begin
  Result := TDrwText(inherited Add);
end;

procedure TDrwTexts.AddFromFile(Shape: TShapeClientAnchor);
begin
  FFileAdd := True;
  try
    TDrwText(inherited Add).FShape := Shape;
  finally
    FFileAdd := False;
  end;
end;

procedure TDrwTexts.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FDrawing.DeleteShape(Items[i].FShape.SpId);
  inherited Clear;
end;

constructor TDrwTexts.Create(AOwner: TPersistent; Drawing: TEscherDrawing);
begin
  inherited Create(TDrwText);
  FOwner := AOwner;
  FDrawing := Drawing;
end;

function TDrwTexts.GetDrwText(Index: integer): TDrwText;
begin
  Result := TDrwText(inherited Items[Index]);
end;

function TDrwTexts.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TDrwNote }

procedure TDrwNote.SetCellCol(const Value: integer);
begin
  TShapeOutsideMsoNote(FShape.ExShape).CellCol := Value;
end;

procedure TDrwNote.SetCellRow(const Value: integer);
begin
  TShapeOutsideMsoNote(FShape.ExShape).CellRow := Value;
end;

function TDrwNote.GetCellCol: integer;
begin
  Result := TShapeOutsideMsoNote(FShape.ExShape).CellCol;
end;

function TDrwNote.GetCellRow: integer;
begin
  Result := TShapeOutsideMsoNote(FShape.ExShape).CellRow;
end;

constructor TDrwNote.Create(Collection: TCollection);
begin
  if not TDrwNotes(Collection).FFileAdd then
    FShape := TDrwNotes(Collection).FDrawing.AddNote;
  inherited Create(Collection);
  FName := 'Note ' + IntToStr(ID);
end;

destructor TDrwNote.Destroy;
begin
  inherited;
end;

procedure TDrwNote.Clear;
begin
  inherited;
end;

function TDrwNote.GetAuthor: WideString;
begin
  Result := TShapeOutsideMsoNote(FShape.ExShape).Author;
end;

procedure TDrwNote.SetAuthor(const Value: WideString);
begin
  TShapeOutsideMsoNote(FShape.ExShape).Author := Value;
end;

{ TDrwNotes }

function TDrwNotes.Add: TDrwNote;
begin
  Result := TDrwNote(inherited Add);
end;

procedure TDrwNotes.AddFromFile(Shape: TShapeClientAnchor);
begin
  FFileAdd := True;
  try
    TDrwNote(inherited Add).FShape := Shape;
  finally
    FFileAdd := False;
  end;
end;

procedure TDrwNotes.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FDrawing.DeleteShape(Items[i].FShape.SpId);
  inherited Clear;
end;

constructor TDrwNotes.Create(AOwner: TPersistent; Drawing: TEscherDrawing);
begin
  inherited Create(TDrwNote);
  FOwner := AOwner;
  FDrawing := Drawing;
end;

function TDrwNotes.FindByColRow(Col,Row: integer): integer;
{
var
  hi,lo: integer;
}  
begin

  for Result := 0 to Count - 1 do begin
    if (Items[Result].CellCol = Col) and (Items[Result].CellRow = Row) then
      Exit;
  end;


  // Notes are not sorted by RowCol...
{
  lo := 0;
  hi := Count - 1;
  while lo <= hi do begin
    Result := (lo + hi) shr 1;
    if RowCol > Items[Result].RowCol then
      lo := Result + 1
    else if RowCol < Items[Result].RowCol then
      hi := Result - 1
    else
      Exit;
  end;
}  
  Result := -1;
end;

function TDrwNotes.GetDrwNote(Index: integer): TDrwNote;
begin
  Result := TDrwNote(inherited Items[Index]);
end;

function TDrwNotes.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TDrawingObjects }

procedure TDrawingObjects.Clear;
begin
  FTexts.Clear;
  FNotes.Clear;
  FBasics.Clear;
  FAutoShapes.Clear;
  FPictures.Clear;
end;

constructor TDrawingObjects.Create(AOwner: TPersistent; Drawing: TEscherDrawing; FormulaHandler: TFormulaHandler);
begin
  FOwner := AOwner;
  FDrawing := Drawing;
  FTexts := TDrwTexts.Create(Self,FDrawing);
  FNotes := TDrwNotes.Create(Self,FDrawing);
  FBasics := TDrwBasics.Create(Self,FDrawing);
  FAutoShapes := TDrwAutoShapes.Create(Self,FDrawing);
  FPictures := TDrwPictures.Create(Self,FDrawing);
end;

destructor TDrawingObjects.Destroy;
begin
  FTexts.Free;
  FNotes.Free;
  FBasics.Free;
  FAutoShapes.Free;
  FPictures.Free;
  inherited;
end;

function TDrawingObjects.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TDrwBasic }

constructor TDrwBasic.Create(Collection: TCollection);
begin
  if not TDrwBasics(Collection).FFileAdd then
    FShape := TDrwBasics(Collection).FDrawing.AddBasic;
  inherited Create(Collection);
  FName := 'Basic ' + IntToStr(ID);
end;

function TDrwBasic.GetShapeType: TBasicShapeType;
begin
  case FShape.ShapeType of
    msosptLine:                   Result := bstLine;
    msosptArrow:                  Result := bstArrow;
  else
    Result := bstLine;
  end;
end;

function TDrwBasic.GetLineColor: TColor;
begin
  Result := FShape.OPT.FindValue(msooptLineColor);
end;

procedure TDrwBasic.SetShapeType(const Value: TBasicShapeType);
begin
  case Value of
    bstLine:                   FShape.ShapeType := msosptLine;
    bstArrow:                  FShape.ShapeType := msosptArrow;
    bstEllipse:                FShape.ShapeType := msosptEllipse;
    bstRectangle:              FShape.ShapeType := msosptRectangle;
  else
    FShape.ShapeType := msosptLine;
  end;
end;

procedure TDrwBasic.SetLineColor(const Value: TColor);
begin
  FShape.OPT.UpdateValue(msooptLineColor,Value)
end;

function TDrwBasic.GetFillColor: TColor;
begin
  Result := FShape.OPT.FindValue(msooptFillColor);
end;

procedure TDrwBasic.SetFillColor(const Value: TColor);
begin
  FShape.OPT.UpdateValue(msooptFillColor,Value)
end;

{ TDrwBasics }

function TDrwBasics.Add: TDrwBasic;
begin
  Result := TDrwBasic(inherited Add);
end;

procedure TDrwBasics.AddFromFile(Shape: TShapeClientAnchor);
begin
  FFileAdd := True;
  try
    TDrwBasic(inherited Add).FShape := Shape;
  finally
    FFileAdd := False;
  end;
end;

procedure TDrwBasics.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FDrawing.DeleteShape(Items[i].FShape.SpId);
  inherited Clear;
end;

constructor TDrwBasics.Create(AOwner: TPersistent; Drawing: TEscherDrawing);
begin
  inherited Create(TDrwBasic);
  FOwner := AOwner;
  FDrawing := Drawing;
end;

function TDrwBasics.GetDrwBasic(Index: integer): TDrwBasic;
begin
  Result := TDrwBasic(inherited Items[Index]);
end;

function TDrwBasics.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TDrwAutoShape }

constructor TDrwAutoShape.Create(Collection: TCollection);
begin
  if not TDrwAutoShapes(Collection).FFileAdd then
    FShape := TDrwAutoShapes(Collection).FDrawing.AddAutoShape;
  inherited Create(Collection);
  FName := 'AutoShape ' + IntToStr(ID);
end;

function TDrwAutoShape.GetAutoShapeType: TAutoShapeType;
begin
  case FShape.ShapeType of
    msosptSun:                   Result := astSun;
    msosptMoon:                  Result := astMoon;
    msosptLeftArrow:             Result := astLeftArrow;
    msosptDownArrow:             Result := astDownArrow;
    msosptUpArrow:               Result := astUpArrow;
    msosptLeftRightArrow:        Result := astLeftRightArrow;
    msosptUpDownArrow:           Result := astUpDownArrow;
    msosptQuadArrow:             Result := astQuadArrow;
    msosptLeftArrowCallout:      Result := astLeftArrowCallout;
    msosptRightArrowCallout:     Result := astRightArrowCallout;
    msosptUpArrowCallout:        Result := astUpArrowCallout;
    msosptDownArrowCallout:      Result := astDownArrowCallout;
    msosptLeftRightArrowCallout: Result := astLeftRightArrowCallout;
    msosptUpDownArrowCallout:    Result := astUpDownArrowCallout;
    msosptQuadArrowCallout:      Result := astQuadArrowCallout;
    else
      Result := astSun;
  end;
end;

function TDrwAutoShape.GetFillColor: TColor;
begin
  Result := FShape.OPT.FindValue(msooptFillColor);
end;

function TDrwAutoShape.GetLineColor: TColor;
begin
  Result := FShape.OPT.FindValue(msooptLineColor);
end;

procedure TDrwAutoShape.SetAutoShapeType(const Value: TAutoShapeType);
begin
  case Value of
    astSun:                      FShape.ShapeType := msosptSun;
    astMoon:                     FShape.ShapeType := msosptMoon;
    astLeftArrow:                FShape.ShapeType := msosptLeftArrow;
    astDownArrow:                FShape.ShapeType := msosptDownArrow;
    astUpArrow:                  FShape.ShapeType := msosptUpArrow;
    astLeftRightArrow:           FShape.ShapeType := msosptLeftRightArrow;
    astUpDownArrow:              FShape.ShapeType := msosptUpDownArrow;
    astQuadArrow:                FShape.ShapeType := msosptQuadArrow;
    astLeftArrowCallout:         FShape.ShapeType := msosptLeftArrowCallout;
    astRightArrowCallout:        FShape.ShapeType := msosptRightArrowCallout;
    astUpArrowCallout:           FShape.ShapeType := msosptUpArrowCallout;
    astDownArrowCallout:         FShape.ShapeType := msosptDownArrowCallout;
    astLeftRightArrowCallout:    FShape.ShapeType := msosptLeftRightArrowCallout;
    astUpDownArrowCallout:       FShape.ShapeType := msosptUpDownArrowCallout;
    astQuadArrowCallout:         FShape.ShapeType := msosptQuadArrowCallout;
    else
      FShape.ShapeType := msosptSun;
  end;
end;

procedure TDrwAutoShape.SetFillColor(const Value: TColor);
begin
  FShape.OPT.UpdateValue(msooptFillColor,Value)
end;

procedure TDrwAutoShape.SetLineColor(const Value: TColor);
begin
  FShape.OPT.UpdateValue(msooptLineColor,Value)
end;

{ TDrwAutoShapes }

function TDrwAutoShapes.Add: TDrwAutoShape;
begin
  Result := TDrwAutoShape(inherited Add);
end;

procedure TDrwAutoShapes.AddFromFile(Shape: TShapeClientAnchor);
begin
  FFileAdd := True;
  try
    TDrwAutoShape(inherited Add).FShape := Shape;
  finally
    FFileAdd := False;
  end;
end;

procedure TDrwAutoShapes.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FDrawing.DeleteShape(Items[i].FShape.SpId);
  inherited Clear;
end;

constructor TDrwAutoShapes.Create(AOwner: TPersistent; Drawing: TEscherDrawing);
begin
  inherited Create(TDrwAutoShape);
  FOwner := AOwner;
  FDrawing := Drawing;
end;

function TDrwAutoShapes.GetDrwAutoShape(Index: integer): TDrwAutoShape;
begin
  Result := TDrwAutoShape(inherited Items[Index]);
end;

function TDrwAutoShapes.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TDrwPicture }

constructor TDrwPicture.Create(Collection: TCollection);
begin
  if not TDrwPictures(Collection).FFileAdd then
    FShape := TDrwPictures(Collection).FDrawing.AddPicture;
  inherited Create(Collection);
  FName := 'Picture ' + IntToStr(ID);
end;

function TDrwPicture.GetPictureId: integer;
begin
  Result := FShape.OPT.FindValue(msooptPib);
end;

function TDrwPicture.GetPictureName: WideString;
begin
  Result := FShape.OPT.FindString(msooptPibName);
end;

procedure TDrwPicture.SetPictureId(const Value: integer);
begin
  if TDrwPictures(Collection).FDrawing.EscherGroup.Count >  0 then begin
    if (Value < 0) or (Value > TDrwPictures(Collection).FDrawing.EscherGroup.Count) then
      raise Exception.Create('Picture Id out of range.');

    if Value = 0 then
      FShape.OPT.UpdateString(msooptPibName,'')
    else
      FShape.OPT.UpdateString(msooptPibName,ExtractFilename(TDrwPictures(Collection).FDrawing.EscherGroup[Value - 1].Filename));
  end;
  FShape.OPT.UpdateValue(msooptPib,Value)
end;

procedure TDrwPicture.SetPictureName(const Value: WideString);
var
  i: integer;
  XLS: TXLSReadWriteII2;
  Sheet: TSheet;
  Sheets: TSheets;
  DrawingObjects: TDrawingObjects;
begin
  DrawingObjects := TDrawingObjects(TDrwPictures(Collection).FOwner);
  Sheet := TSheet(DrawingObjects.FOwner);
  Sheets := TSheets(Sheet.Collection);
  XLS := TXLSReadWriteII2(Sheets.Owner);
  for i := 0 to XLS.MSOPictures.Count - 1 do begin
    if MyWideUppercase(Value) = MyWideUppercase(XLS.MSOPictures[i].Filename) then begin
      SetPictureId(XLS.MSOPictures[i].FileBlipId);
      Exit;
    end;
  end;
  raise Exception.Create('Can not find picture: ' + Value);
end;

{ TDrwPictures }

function TDrwPictures.Add: TDrwPicture;
begin
  Result := TDrwPicture(inherited Add);
end;

procedure TDrwPictures.AddFromFile(Shape: TShapeClientAnchor);
begin
  FFileAdd := True;
  try
    TDrwPicture(inherited Add).FShape := Shape;
  finally
    FFileAdd := False;
  end;
end;

procedure TDrwPictures.Clear;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    FDrawing.DeleteShape(Items[i].FShape.SpId);
  inherited Clear;
end;

constructor TDrwPictures.Create(AOwner: TPersistent; Drawing: TEscherDrawing);
begin
  inherited Create(TDrwPicture);
  FOwner := AOwner;
  FDrawing := Drawing;
end;

function TDrwPictures.GetDrwPicture(Index: integer): TDrwPicture;
begin
  Result := TDrwPicture(inherited Items[Index]);
end;

function TDrwPictures.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

end.