rm_e_pdf.pas

report machine 2.3 功能强大

  TmZone: TTimeZoneInformation;
  I, StartXRef, Pg: Integer;
  PgHeight, PgWidth: Extended;
begin
  PgHeight := FPageHeight / Screen.PixelsPerInch * CInchToPoint;
  PgWidth := GetNativeXPos(FPageWidth);

  GetTimeZoneInformation(TmZone);
  ZoneBias := Format('%.2d', [TmZone.Bias div -60]);
  if ZoneBias[1] <> '-' then
  begin
    ZoneBias := '+' + ZoneBias;
    TmZone.Bias := TmZone.Bias * -1;
  end;
  ZoneBias := ZoneBias + '''' + Format('%.2d', [TmZone.Bias mod 60]) + '''';
  FPageObjs := Trim(FPageObjs);
 // Pages tree object

  Pg := CurReport.EMFPages.Count - 1;

  S := '/Type /Pages' + CRLF +
    '/Count ' + IntToStr(Pg + 1) + CRLF +
    '/MediaBox [0 0 ' + NumToStr(PgWidth) + ' ' +
    NumToStr(PgHeight) + ']' + CRLF +
    '/Kids [' + FPageObjs + ']' + CRLF +
    '/Resources ' + MakeObjRef(CResourcesObjNo);
  WriteObj(S, CPagesTreeObjNo, True);

  S := '';
  S := S + '/ProcSet ' + MakeObjRef(CProcSetObjNo);
  if FImageCtlList.Count > 0 then
  begin
    S := S + CRLF + '/XObject <<';
    with FImageCtlList do
    begin
      for I := 0 to Count - 1 do
        S := S + CRLF + '/Img' + IntToStr(I) + ' ' + MakeObjRef(StrToIntDef(Strings[I], 0));
    end;
    S := S + ' >>';
  end;
  WriteObj(S, cResourcesObjNo, True);

  S := '[/PDF /Text /ImageC]';
  WriteObj(S, cProcSetObjNo, True);

  S := '/Producer (ReportMachine))';
  WriteObj(S, cInfoObjNo, True);

  StartXRef := Stream.Size;
 // xref table
  S := 'xref' + CRLF + '0 ' + IntToStr(FObjRunNo + 1) + CRLF + MakeXRef(0, 65535, 'f') + CRLF;
  with FXRefTable do
  begin
    for I := 0 to Count - 1 do
      S := S + MakeXRef(StrToIntDef(Strings[IndexOfObject(TObject(I + 1))], 0), 0, 'n') + CRLF;
  end;
  WriteToStream(S);

 // trailer & footer objects
  S := 'trailer' + CRLF +
    '<<' + CRLF +
    '/Root ' + MakeObjRef(CRootObjNo) + CRLF +
    '/Info ' + MakeObjRef(CInfoObjNo) + CRLF +
    '/Size ' + IntToStr(FObjRunNo + 1) + CRLF +
    '>>' + CRLF +
    'startxref' + CRLF + IntToStr(StartXRef) + CRLF +
    '%%EOF';
  WriteToStream(S);

  FImageCtlList.Free;
  FImageXRefList.Free;
  FXRefTable.Free;
  FImageStream.Free;
  FStream.Free;

//  inherited OnEndDoc;
end;

const
  ImageFilter: array[TRMEFImageFormat] of string = ('/LZWDecode', '/DCTDecode', '/FlateDecode');

procedure TRMPDFExport.OnEndPage;
var
  I, K, ImgObjNo, ImgOffset, StreamSize: Integer;
  S, AImageInfo: string;
  ALeft, ATop, AHeight: Extended;
  Bmp: TBitmap;
{$IFDEF JPEG}
  JPEG: TJPEGImage;
{$ENDIF}
  AStream: TMemoryStream;

  function GetImageFilter: string;
  begin
    Result := '';
    if (ExportImageFormat = ifJPG){$IFDEF ZLib} or (FCompressionMethod <> rmcmNone){$ENDIF} then
      Result := '/Filter' + ImageFilter[ExportImageFormat];
  end;

  function EncodeImageObjectRef(ImgNo: Integer; ImgWidth, ImgHeight: Extended): string;
  begin
    Result := 'q' + CR +
      NumToStr(ImgWidth) + ' 0 0 ' +
      NumToStr(ImgHeight) + ' ' +
      NumToStr(ALeft) + ' ' +
      NumToStr(ATop - AHeight) + ' cm' + CR +
      '/Img' + IntToStr(ImgNo) + ' Do' + CR + 'Q' + CRLF;
  end;

  procedure _CompressBmp;
  var
    ABmpStream: TStream;
    x, y: Integer;
    P: PByteArray;
    AByte: Byte;
  begin
    ABmpStream := TMemoryStream.Create;
    try
      Bmp.PixelFormat := pf24Bit;
      for Y := 0 to Bmp.Height - 1 do
      begin
        P := Bmp.ScanLine[y];
        X := 0;
        while X < Bmp.Width * 3 - 1 do
        begin
          AByte := P[X];
          P[X] := P[X + 2];
          P[X + 2] := AByte;
          Inc(X, 3);
        end;
        ABmpStream.Write(P^, Bmp.Width * 3);
      end;
      CompressStream(ABmpStream, AStream);
    finally
      ABmpStream.Free;
    end;
  end;

begin
  Bmp := TBitmap.Create;
{$IFDEF JPEG}
  JPEG := TJPEGImage.Create;
{$ENDIF}
  try
{$IFDEF JPEG}
    if ExportImageFormat <> ifBMP then
    begin
//	    JPEG.Grayscale := FGrayscale;
//  	  JPEG.ProgressiveEncoding := FProgressiveEncoding;
      JPEG.CompressionQuality := JPEGQuality;
    end;
{$ENDIF}
    Bmp.Width := FPageWidth;
    Bmp.Height := FPageHeight;
    Bmp.PixelFormat := FPixelFormat;
    DrawbkPicture(Bmp.Canvas);
    CurReport.EMFPages.Draw(FPageNo, Bmp.Canvas, Rect(0, 0, FPageWidth, FPageHeight));

    AStream := TMemoryStream.Create;
{$IFDEF JPEG}
    if ExportImageFormat <> ifBMP then
    begin
      JPEG.Assign(BMP);
      JPEG.SaveToStream(AStream)
    end
    else
      _CompressBmp;
{$ELSE}
    _CompressBmp;
{$ENDIF}

    AImageInfo := '';
    S := '';
    try
      ImgObjNo := GetNewObjNo;
      K := FImageCtlList.Add(IntToStr(ImgObjNo));
      FImageXRefList.AddObject(IntToStr(FImageStream.Size), TObject(ImgObjNo));
      S := MakeObjHead(ImgObjNo) + CRLF + '<< ' +
        '/Type/XObject/Subtype/Image' +
        '/Name/Img' + IntToStr(K) +
        '/Width ' + IntToStr(bmp.Width) +
        '/Height ' + IntToStr(bmp.Height) +
        '/BitsPerComponent 8' +
        '/ColorSpace/DeviceRGB' +
        GetImageFilter +
        '/Length ' + IntToStr(AStream.Size) + CRLF + '>>' + CRLF +
        'stream' + CRLF;

      WriteToImageStream(S);
      FImageStream.CopyFrom(AStream, 0);
      S := CRLF + 'endstream' + CRLF + 'endobj' + CRLF;
      WriteToImageStream(S);
    finally
      AStream.Free;
    end;

    AImageInfo := EncodeImageObjectRef(K, GetNativeXPos(bmp.Width), GetNativeXPos(bmp.Height));
    FStream.Write(Pointer(AImageInfo)^, Length(AImageInfo));
  finally
    Bmp.Free;
  end;

  S := '/Type /Page' + CRLF +
    '/Parent ' + MakeObjRef(CPagesTreeObjNo) + CRLF +
    '/Contents ' + MakeObjRef(FContentsObjNo);
  WriteObj(S, FPageObjNo, True);

  S := '/Length ' + MakeObjRef(FLengthObjNo);
{$IFDEF ZLib}
  if FCompressionMethod <> rmcmNone then
    S := S + CRLF + '/Filter /FlateDecode'
  else
    S := '<< ' + S + ' >>';
{$ELSE}
  S := '<< ' + S + ' >>';
{$ENDIF}
  WriteObj(S, FContentsObjNo, False);

  S := 'stream' + CRLF;
  WriteToStream(S);
  StreamSize := CompressStream(FStream, Stream);
  S := CRLF + 'endstream' + CRLF + 'endobj' + CRLF;
  WriteToStream(S);
 // Write page stream length object
  S := IntToStr(StreamSize);
  if S = '' then
    S := '0';
  WriteObj(S, FLengthObjNo, True);

 // Offset all image xrefs by (page + page lenght obj sizes)
 // and add to xref list
  for I := 0 to FImageXRefList.Count - 1 do
  begin
    ImgOffset := StrToIntDef(FImageXRefList[I], 0);
    Inc(ImgOffset, Stream.Size);
    AppendXRef(ImgOffset, Integer(FImageXRefList.Objects[I]));
  end;
 // Write all saved images to file
  if FImageStream.Size > 0 then
    Stream.CopyFrom(FImageStream, 0);

  CurReport.EMFPages[FPageNo].Visible := FPageVisible;
  Inc(FPageNo);
//  inherited OnEndPage;
end;

procedure TRMPDFExport.SetExportImageFormat(const Value: TRMEFImageFormat);
begin
  if (Value in [ifJPG, ifBMP]) then
    FExportImageFormat := Value;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMBMPExportForm}

procedure TRMPDFExportForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  Caption := RMLoadStr(rmRes + 1817);
  lblExportImageFormat.Caption := RMLoadStr(rmRes + 1816);
  lblJPEGQuality.Caption := RMLoadStr(rmRes + 1814);
  Label4.Caption := RMLoadStr(rmRes + 1788);
  lblCompressionLevel.Caption := RMLoadStr(rmRes + 1785);

  cbCompressionLevel.Items.Clear;
  cbCompressionLevel.Items.Add(RMLoadStr(rmRes + 1784));
  cbCompressionLevel.Items.Add(RMLoadStr(rmRes + 1783));
  cbCompressionLevel.Items.Add(RMLoadStr(rmRes + 1782));
  cbCompressionLevel.Items.Add(RMLoadStr(rmRes + 1781));

  btnOK.Caption := RMLoadStr(SOk);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

procedure TRMPDFExportForm.FormCreate(Sender: TObject);
begin
  Localize;
  cbImageFormat.Items.Clear;
{$IFDEF JPEG}
  cbImageFormat.Items.AddObject(ImageFormats[ifJPG], TObject(ifJPG));
{$ENDIF}
  cbImageFormat.Items.AddObject(ImageFormats[ifBMP], TObject(ifBMP));
end;

procedure TRMPDFExportForm.cbImageFormatChange(Sender: TObject);
begin
  if cbImageFormat.Text = ImageFormats[ifJPG] then
  begin
    lblJPEGQuality.Enabled := True;
    edJPEGQuality.Enabled := True;
    edJPEGQuality.Color := clWindow;
  end
  else
  begin
    lblJPEGQuality.Enabled := False;
    edJPEGQuality.Enabled := False;
    edJPEGQuality.Color := clInactiveBorder;
  end;
end;

procedure TRMPDFExportForm.edJPEGQualityKeyPress(Sender: TObject;
  var Key: Char);
begin
  if not (Key in ['0'..'9', #8]) then
    Key := #0;
end;

procedure TRMPDFExportForm.FormShow(Sender: TObject);
begin
  cbImageFormatChange(nil);
end;

end.