teepdfcanvas.pas

TeeChart7Source 控件

  FChartObject.Free;
  OffsetList.Clear;
  inherited;
end;

procedure TTeePDFPage.SaveToStream(AStream: TStream);
begin
  WriteHeader(AStream);
  WriteInfo(AStream);

  // write chart canvas code
  Inc(IObjCount);
  AddToOffset(AStream.Size);
  WriteStringToStream(AStream,IntToStr(IObjCount)+ ' 0 obj'+CRLF);
  FChartObject.SaveToStream(AStream);
  WriteStringToStream(AStream,'endobj'+CRLF);

  // TT fonts
  WriteTTFonts(AStream);
  // Additional images, if they exist
  WriteImages(AStream);
  // Resources
  WriteResources(AStream);
  // Pages and page
  WritePages(AStream);
  WritePage(AStream);
  WriteCatalog(AStream);
  WriteXRef(AStream);
  WriteStringToStream(AStream,'%%EOF'+CRLF);
end;

procedure TTeePDFPage.SetPageHeight(const Value: Integer);
begin
  FPageHeight := Value;
end;

procedure TTeePDFPage.SetPageWidth(const Value: Integer);
begin
  FPageWidth := Value;
end;

procedure TTeePDFPage.WriteCatalog(AStream: TStream);
begin
  Inc(IObjCount);
  CatalogNum := IObjCount;
  AddToOffset(AStream.Size);
  WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
  WriteStringToStream(AStream,'<< /Type /Catalog' + CRLF);
  WriteStringToStream(AStream,'/Pages ' + IntToStr(ParentNum) + ' 0 R'+ CRLF);
  WriteStringToStream(AStream,'>>'+CRLF);
  WriteStringToStream(AStream,'endobj'+CRLF);
end;

procedure TTeePDFPage.WriteHeader(AStream: TStream);
begin
  WriteStringToStream(AStream,'%PDF-1.4'+CRLF);
end;

procedure TTeePDFPage.WriteImages(AStream: TStream);
var i: Integer;
begin
  with FChartObject.ImageArray do
  begin
    for i := 0 to ItemsCount -1 do
    begin
      Inc(IObjCount);
      AddToOffset(AStream.Size);
      Items[i].ObjectNumber := IObjCount;
      WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
      WriteStringToStream(AStream,'<< /Type /XObject'+CRLF);
      WriteStringToStream(AStream,'/Subtype /Image'+CRLF);
      WriteStringToStream(AStream,'/Name /Im'+IntToStr(i)+CRLF);
      WriteStringToStream(AStream,'/Length '+IntToStr(Items[i].DataLength)+CRLF);
      WriteStringToStream(AStream,'/Width '+IntToStr(Items[i].Width)+CRLF);
      WriteStringToStream(AStream,'/Height '+IntToStr(Items[i].Height)+CRLF);
      WriteStringToStream(AStream,'/ColorSpace /DeviceRGB'+CRLF);
      WriteStringToStream(AStream,'/BitsPerComponent 8'+CRLF);
      if Items[i].ImageType = itJPEG then WriteStringToStream(AStream,'/Filter [/DCTDecode]'+CRLF);
      WriteStringToStream(AStream,'>>'+CRLF);
      WriteStringToStream(AStream,'stream'+CRLF);
      Items[i].WriteDataToStream(AStream);
      WriteStringToStream(AStream,'endstream'+CRLF);
      WriteStringToStream(AStream,'endobj'+CRLF);
    end;
  end;
end;

procedure TTeePDFPage.WriteInfo(AStream: TStream);
begin
  Inc(IObjCount);
  AddToOffset(AStream.Size);
  WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
  tmpSt := '<<'+CRLF+'/Creator (' + TeeMsg_Version +')'+CRLF+'/Producer (' + TeeMsg_Version+')'+CRLF+
    '/CreationDate (D:'+FormatDateTime('YYYYMMDDHHmmSS',Now)+')'+CRLF+'/ModDate ()' + CRLF +
    '/Keywords ()'+CRLF+'/Title (TChart Export)' + CRLF+'>>'+CRLF;
  WriteStringToStream(AStream, tmpSt);
  WriteStringToStream(AStream,'endobj'+CRLF);
end;

procedure TTeePDFPage.WritePage(AStream: TStream);
begin
  Inc(IObjCount);
  AddToOffset(AStream.Size);
  WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
  WriteStringToStream(AStream,'<< /Type /Page' + CRLF + '/Parent '+IntToStr(ParentNum)+ ' 0 R'+CRLF);
  WriteStringToStream(AStream,'/MediaBox [ 0 0 ' + IntToStr(FPageWidth) + ' ' + IntToStr(FPageHeight) + ' ]'+CRLF);
  WriteStringToStream(AStream,'/Contents 2 0 R'+CRLF);
  WriteStringToStream(AStream,'/Resources ' + IntToStr(ResourceNum)+' 0 R'+CRLF);
  WriteStringToStream(AStream,'>>'+CRLF);
  WriteStringToStream(AStream,'endobj'+CRLF);
end;

procedure TTeePDFPage.WritePages(AStream: TStream);
begin
  Inc(IObjCount);
  AddToOffset(AStream.Size);
  ParentNum := IObjCount;
  WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
  // Must be followed by WritePage call, otherwise object reference will not be correct
  tmpSt := '<< /Type /Pages' + CRLF + '/Kids [' + IntToStr(IObjCount+1)+' 0 R]'+CRLF+
    '/Count 1'+CRLF+'>>'+CRLF;
  WriteStringToStream(AStream,tmpSt);
  WriteStringToStream(AStream,'endobj'+CRLF);
end;

procedure TTeePDFPage.WriteResources(AStream: TStream);
var i: Integer;
begin
  Inc(IObjCount);
  ResourceNum := IObjCount;
  AddToOffset(AStream.Size);
  WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
  WriteStringToStream(AStream,'<< /ProcSet [/PDF /Text /ImageC]'+CRLF);
  With FChartObject do
  begin
    WriteStringToStream(AStream,'/Font << '+CRLF);
    for i := 0 to FontArray.ItemsCount -1 do
      WriteStringToStream(AStream,'/F'+IntToStr(i) + ' ' + IntToStr(FontArray.Items[i].ObjectNumber)+' 0 R'+CRLF);
    WriteStringToStream(AStream,'>>'+CRLF);
    WriteStringToStream(AStream,'/XObject << '+CRLF);
    for i := 0 to ImageArray.ItemsCount -1 do
      WriteStringToStream(AStream,'/Im'+IntToStr(i) + ' ' + IntToStr(ImageArray.Items[i].ObjectNumber)+' 0 R'+CRLF);
    WriteStringToStream(AStream,'>>'+CRLF);
  end;

  WriteStringToStream(AStream,'>>'+CRLF);
  WriteStringToStream(AStream,'endobj'+CRLF);
end;

procedure TTeePDFFontListEntry.SetObjectNumber(const Value: Integer);
begin
  FObjectNumber := Value;
end;

procedure TTeePDFPage.WriteTrailer(AStream: TStream);
begin
  WriteStringToStream(AStream,'trailer'+CRLF);
  WriteStringToStream(AStream,'<< /Size '+ IntToStr(IObjCount)+CRLF);
  WriteStringToStream(AStream,'/Root '+ IntToStr(CatalogNum)+ ' 0 R'+CRLF);
  WriteStringToStream(AStream,'/Info 1 0 R'+CRLF);
  WriteStringToStream(AStream,'>>'+CRLF);
  WriteStringToStream(AStream,'startxref'+CRLF);
  WriteStringToStream(AStream,IntToStr(XRefPos)+CRLF);
end;

procedure TTeePDFPage.WriteTTFonts(AStream: TStream);
var i,j: Integer;
begin
  With FChartObject.FontArray do
  begin
    for i := 0 to ItemsCount -1 do
    begin
      // font header
      Inc(IObjCount);
      AddToOffset(AStream.Size);
      Items[i].ObjectNumber := IObjCount;
      WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
      WriteStringToStream(AStream,'<< /Type /Font'+CRLF);
      WriteStringToStream(AStream,'/Subtype /TrueType'+CRLF);
      WriteStringToStream(AStream,'/BaseFont /'+ Items[i].PDFName+CRLF);
      WriteStringToStream(AStream,'/Name /F'+IntToStr(i)+CRLF);
      WriteStringToStream(AStream,'/FirstChar '+ IntToStr(Items[i].FontData.FirstChar)+CRLF);
      WriteStringToStream(AStream,'/LastChar '+ IntToStr(Items[i].FontData.LastChar)+CRLF);
      WriteStringToStream(AStream,'/Encoding /WinAnsiEncoding'+CRLF);
      WriteStringToStream(AStream,'/FontDescriptor '+ IntToStr(IObjCount+1)+ ' 0 R'+CRLF);
      WriteStringToStream(AStream,'/Widths '+ IntToStr(IObjCount+2)+' 0 R'+CRLF);
      WriteStringToStream(AStream,'>>'+CRLF);
      WriteStringToStream(AStream,'endobj'+CRLF);

      // Font descriptor
      Inc(IObjCount);
      AddToOffset(AStream.Size);
      WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
      WriteStringToStream(AStream,'<< /Type /FontDescriptor'+CRLF);
      WriteStringToStream(AStream,'/FontName /'+ Items[i].PDFName+CRLF);
      WriteStringToStream(AStream,'/Flags 32'+CRLF);
      With Items[i].FontData do
      begin
        WriteStringToStream(AStream,'/FontBBox ['+
          IntToStr(FontBBox.Left)+ ' ' +
          IntToStr(FontBBox.Bottom)+ ' ' +
          IntToStr(FontBBox.Right)+ ' ' +
          IntToStr(FontBBox.Top)+ ']' + CRLF);
        WriteStringToStream(AStream,'/CapHeight ' + IntToStr(CapHeight)+CRLF);
        WriteStringToStream(AStream,'/Ascent ' + IntToStr(Ascent)+CRLF);
        WriteStringToStream(AStream,'/Descent ' + IntToStr(Descent)+CRLF);
        WriteStringToStream(AStream,'/MaxWidth ' + IntToStr(MaxWidth)+CRLF);
        WriteStringToStream(AStream,'/AvgWidth ' + IntToStr(AvgWidth)+CRLF);
        WriteStringToStream(AStream,'/ItalicAngle ' + IntToStr(ItalicAngle)+CRLF);
        WriteStringToStream(AStream,'/StemV 0'+CRLF);
      end;
      WriteStringToStream(AStream,'>>'+CRLF);
      WriteStringToStream(AStream,'endobj'+CRLF);

      // Font widths
      Inc(IObjCount);
      AddToOffset(AStream.Size);
      WriteStringToStream(AStream,IntToStr(IObjCount)+' 0 obj'+CRLF);
      WriteStringToStream(AStream,'['+CRLF);
      tmpSt := '';
      for j := Items[i].FontData.FirstChar to Items[i].FontData.LastChar do
        if (j mod 15 = 14) then tmpSt := tmpSt + IntToStr(Items[i].FontData.CharWidths[j]) + ' '+CRLF
        else tmpSt := tmpSt + IntToStr(Items[i].FontData.CharWidths[j]) + ' ';
      WriteStringToStream(AStream,tmpSt+CRLF);
      WriteStringToStream(AStream,']'+CRLF);
      WriteStringToStream(AStream,'endobj'+CRLF);
    end;
  end;
end;

procedure TTeePDFPage.WriteXRef(AStream: TStream);
var i: Integer;
begin
  Inc(IObjCount);
  // no need to add xref to xref itself.
  XRefPos := AStream.Size;
  WriteStringToStream(AStream,'xref'+CRLF);
  WriteStringToStream(AStream,'0 '+IntToStr(IObjCount)+CRLF);
  WriteStringToStream(AStream,'0000000000 65535 f'+CRLF);
  for i := 0 to OffSetList.Count - 1  do
    WriteStringToStream(AStream,OffsetList.Strings[i]+' ' + FormatIntToString(0,5)+' n'+ CRLF);
  WriteTrailer(AStream);
end;


{ TTeePDFImageList }

function TTeePDFImageList.AddItem(AGraphic: TGraphic): Integer;
begin
  Result := IImageList.Add(TTeePDFImageListEntry.Create(AGraphic));
end;

constructor TTeePDFImageList.Create;
begin
  inherited;
  IImageList := TList.Create;
end;

destructor TTeePDFImageList.Destroy;
var i: Integer;
begin
  for i := 0 to IImageList.Count - 1 do TTeePDFImageListEntry(IImageList.Items[i]).Free;
  IImageList.Free;
  inherited Destroy;
end;

function TTeePDFImageList.EqualImages(i1, i2: TGraphic): Boolean;
var ms: TMemoryStream;
    s1,s2: String;
    b:Boolean;
begin
  {$IFNDEF CLR}
  ms := TMemoryStream.Create;
  try
    i1.SaveToStream(ms);
    ms.Position := 0;
    SetLength(s1,ms.Size);
    ms.Read(S1[1],Length(s1));
    ms.Clear;
    i2.SaveToStream(ms);
    ms.Position := 0;
    SetLength(s2,ms.Size);
    ms.Read(S2[1],Length(s2));
  finally
    ms.Free;
  end;

  b:=s1=s2;
  result:=b;
  {$ELSE}
  result:=False;
  {$ENDIF}
end;


function TTeePDFImageList.Find(AGraphic: TGraphic): Integer;
var i: Integer;
begin
  Result := -1;
  for i := 0 to ItemsCount-1 do
    if EqualImages(AGraphic,Items[i].FGraphic) then
    begin
      Result := i;
      Break;
    end;
end;

function TTeePDFImageList.GetCount: Integer;
begin
  Result := IImageList.Count;  
end;

function TTeePDFImageList.GetImageEntry(
  Index: Integer): TTeePDFImageListEntry;
begin
  Result := TTeePDFImageListEntry(IImageList.Items[Index]);
end;

{ TTeePDFImageListEntry }

constructor TTeePDFImageListEntry.Create(AGraphic: TGraphic);
begin
  inherited Create;
  FGraphic := AGraphic;
  DefineImageData;
end;

procedure TTeePDFImageListEntry.DefineImageData;
begin
  FWidth := FGraphic.Width;
  FHeight := FGraphic.Height;
end;

function TTeePDFImageListEntry.GetDataLength: Integer;
var ms : TMemoryStream;
begin
  ms := TMemoryStream.Create;
  try
    FGraphic.SaveToStream(ms);
    Result := ms.Size;
  finally
    ms.Free;
  end;
end;

function TTeePDFImageListEntry.GetImageType: TImageType;
begin
  {$IFNDEF CLR}
  {$IFNDEF CLX}
  if (FGraphic is TJPEGImage) then Result := itJPEG
  else
  {$ENDIF}
  {$ENDIF}
  if (FGraphic is TBitmap) then Result := itBitmap
  else Result := itUnknown; 
end;

procedure TTeePDFImageListEntry.SetObjectNumber(const Value: Integer);
begin
  FObjectNumber := Value;
end;

function TPDFCanvas.SelectImage(Graphic: TGraphic): integer;
begin
  Result := FContents.ImageArray.Find(Graphic);
  if Result = -1 then Result := FContents.ImageArray.AddItem(Graphic);
end;

procedure TTeePDFImageListEntry.WriteDataToStream(AStream: TStream);
const BytesPerPixel={$IFDEF CLX}4{$ELSE}3{$ENDIF};
var x,y: Integer;
  pb: {$IFDEF CLR}IntPtr{$ELSE}PByteArray{$ENDIF};
  b: Byte;
begin
  {$IFNDEF CLR}
  {$IFNDEF CLX}
  if FGraphic is TJpegImage then
     (FGraphic as TJpegImage).SaveToStream(AStream)
  else
  {$ENDIF}
  {$ENDIF}
  if FGraphic is TBitmap then
  with (FGraphic as TBitmap) do
  begin
    if PixelFormat<>TeePixelFormat then PixelFormat:=TeePixelFormat;

    {$IFNDEF CLR}
    for y := 0 to Height -1 do
    begin
      pb := ScanLine[y];
      x := 0;
      while x < Width*BytesPerPixel do
      begin
        b := pb[x];
        pb[x] := pb[x+2];
        pb[x+2] := b;
        AStream.Write(pb[x],3);
        Inc(x,BytesPerPixel);
      end;
    end;
    {$ENDIF}
  end;

  WriteStringToStream(AStream,CRLF);
end;

initialization
  RegisterTeeExportFormat(TPDFExportFormat);
finalization
  UnRegisterTeeExportFormat(TPDFExportFormat);
end.