vpdfimage.pas

生成PDF文档的控件

{*******************************************************}
{                                                       }
{       This unit is part of the VISPDF VCL library.    }
{       Written by R.Husske - ALL RIGHTS RESERVED.      }
{                                                       }
{       Copyright (C) 2000-2009, www.vispdf.com         }
{                                                       }
{       e-mail: [e-mail]                      }
{       http://www.vispdf.com                           }
{                                                       }
{*******************************************************}

unit VPDFImage;

{$I VisPDFLib.inc }

interface

uses
  SysUtils, Windows, Graphics, Classes, JPEG, VPDFTypes, VPDFDoc, VPDFObjects, VPDFZLib;

type
  TVPDFImage = class(TVPDFStreamObject)
  private
    FIsMask: boolean;
    procedure SetupImageDictionary(Width, Height, Filter: Integer; Name: AnsiString; MaskLink: TVPDFLink; ABitmap: TBitmap = nil; IsEightBit: boolean = false);
    function CreateIndexedColorArray(ABitmap: TBitmap): TVPDFArrayObject;
  public
    constructor Create(AImage: TGraphic; Compression: Integer; IsMask: Boolean; MaskLink: TVPDFLink; Name: AnsiString; FJpegQuality: Integer = 100);
    destructor Destroy; override;
  end;

implementation

uses VPDFCCITT;

{ TVPDFImage }

constructor TVPDFImage.Create(AImage: TGraphic; Compression: Integer;
  IsMask: Boolean; MaskLink: TVPDFLink; Name: AnsiString; FJpegQuality: Integer = 100);
var
  b: Byte;
  BMI: TBitmap;
  JPF: TJPEGImage;
  x, y: integer;
  pb: PByteArray;
  ScanLength: Integer;
  TmpStream: TStream;
  AStream: TMemoryStream;
  CCITTCompression: TVCCITTCompression;
const
  PixelSize = 3;

begin
  ObjectType := otStream;
  Dictionary := TVPDFDictionaryObject.Create(nil);
  if (IsMask) then
  begin
    FIsMask := true;
    Compression := 4;
  end;
  case Compression of
    0: begin
        JPF := TJPEGImage.Create;
        try
          JPF.Assign(AImage);
          JPF.CompressionQuality := FJpegQuality;
          SetupImageDictionary(JPF.Width, JPF.Height, 0, Name, MaskLink);
          Stream := TMemoryStream.Create;
          try
            JPF.SaveToStream(Stream);
            Stream.Position := 0;
          except
            Stream.Free;
          end;
        finally
          JPF.Free;
        end;
      end;
    1: begin
        BMI := TBitmap.Create;
        try
          AStream := TMemoryStream.Create;
          try
            BMI.Assign(AImage);
            if (BMI.PixelFormat = pf1bit) or (BMI.PixelFormat = pf4bit) or
              (BMI.PixelFormat = pf8bit) then BMI.PixelFormat := pf8bit
            else BMI.PixelFormat := pf24Bit;
            if BMI.PixelFormat = pf8bit then
            begin
              for y := 0 to BMI.Height - 1 do
              begin
                pb := BMI.ScanLine[y];
                AStream.Write(pb^, BMI.Width);
              end;
            end
            else
            begin
              y := 0;
              ScanLength := BMI.Width * PixelSize;
              while y < BMI.Height do
              begin
                pb := BMI.ScanLine[y];
                x := 0;
                while x < ScanLength - 1 do
                begin
                  b := pb[x];
                  pb[x] := pb[x + 2];
                  pb[x + 2] := b;
                  Inc(x, PixelSize);
                end;
                AStream.Write(pb^, ScanLength);
                Inc(y);
              end;
            end;
            if (AStream.Size > 0) then
            begin
              TmpStream := TMemoryStream.Create;
              try
                with TCompressionStream.Create(clMax, TmpStream) do
                begin
                  CopyFrom(AStream, 0);
                  Free;
                end;
                TmpStream.Position := 0;
                Stream := TMemoryStream.Create;
                try
                  Stream.CopyFrom(TmpStream, TmpStream.Size);
                  Stream.Position := 0;
                except
                  Stream.Free;
                end;
              finally
                TmpStream.Free;
              end;
            end;
          finally
            AStream.Free;
          end;
          SetupImageDictionary(BMI.Width, BMI.Height, 1, Name, MaskLink, BMI, (BMI.PixelFormat = pf8bit));
        finally
          BMI.Free;
        end;
      end;
    2: begin
        BMI := TBitmap.Create;
        try
          BMI.Assign(AImage);
          Stream := TMemoryStream.Create;
          try
            CCITTCompression := TVCCITTCompression.Create;
            try
              CCITTCompression.CompressImage(AImage, 31, Stream);
            finally
              CCITTCompression.Free;
            end;
          except
            Stream.Free;
          end;
          SetupImageDictionary(BMI.Width, BMI.Height, 2, Name, MaskLink);
        finally
          BMI.Free;
        end;
      end;
    3: begin
        BMI := TBitmap.Create;
        try
          BMI.Assign(AImage);
          Stream := TMemoryStream.Create;
          try
            CCITTCompression := TVCCITTCompression.Create;
            try
              CCITTCompression.CompressImage(AImage, 32, Stream);
            finally
              CCITTCompression.Free;
            end;
          except
            Stream.Free;
          end;
          SetupImageDictionary(BMI.Width, BMI.Height, 3, Name, MaskLink);
        finally
          BMI.Free;
        end;
      end;
    4: begin
        BMI := TBitmap.Create;
        try
          BMI.Assign(AImage);
          Stream := TMemoryStream.Create;
          try
            CCITTCompression := TVCCITTCompression.Create;
            try
              CCITTCompression.CompressImage(AImage, 42, Stream);
            finally
              CCITTCompression.Free;
            end;
          except
            Stream.Free;
          end;
          SetupImageDictionary(BMI.Width, BMI.Height, 4, Name, MaskLink);
        finally
          BMI.Free;
        end;
      end;
  end;
end;

destructor TVPDFImage.Destroy;
begin
  inherited;
end;

procedure TVPDFImage.SetupImageDictionary(Width, Height, Filter: Integer; Name: AnsiString; MaskLink: TVPDFLink; ABitmap: TBitmap; IsEightBit: boolean);
var
  KObj, ColObj, RowObj: TVPDFNumericObject;
  IsMaskVal: TVPDFBooleanObject;
  DecodeParmsDict: TVPDFDictionaryObject;
  DecodeParms: TVPDFArrayObject;

  function AddNameValue(KeyVal, NameVal: AnsiString): TVPDFNameObject;
  begin
    result := TVPDFNameObject.Create(nil);
    result.Value := NameVal;
    Dictionary.AddValue(KeyVal, result);
  end;

  function AddNumericValue(KeyVal: AnsiString; NumVal: Integer): TVPDFNumericObject;
  begin
    result := TVPDFNumericObject.Create(nil);
    result.Value := NumVal;
    Dictionary.AddValue(KeyVal, result);
  end;

  procedure AddFiltValue(NameVal: AnsiString);
  var
    FiltArr: TVPDFArrayObject;
    FiltName: TVPDFNameObject;
  begin
    FiltName := TVPDFNameObject.Create(nil);
    FiltName.Value := NameVal;
    FiltArr := TVPDFArrayObject.Create(nil);
    FiltArr.AddObject(FiltName);
    Dictionary.AddValue('Filter', FiltArr);
  end;

begin
  AddNameValue('Type', 'XObject');
  AddNameValue('Subtype', 'Image');
  if (Filter = 0) then
  begin
    AddNameValue('ColorSpace', 'DeviceRGB');
    AddFiltValue('DCTDecode');
  end
  else
  begin
    if (Filter = 1) then
    begin
      AddFiltValue('FlateDecode');
      if (IsEightBit) then
      begin
        Dictionary.AddValue('ColorSpace', CreateIndexedColorArray(ABitmap));
      end
      else
      begin
        AddNameValue('ColorSpace', 'DeviceRGB');
      end;
    end
    else
    begin
      if (Filter > 1) then
      begin
        AddNameValue('ColorSpace', 'DeviceGray');
        AddFiltValue('CCITTFaxDecode');
      end;
    end;
  end;
  AddNumericValue('Width', Width);
  AddNumericValue('Height', Height);
  if (Filter > 1) then
  begin
    AddNumericValue('BitsPerComponent', 1);
    DecodeParmsDict := TVPDFDictionaryObject.Create(nil);
    KObj := TVPDFNumericObject.Create(nil);
    case Filter of
      2: KObj.Value := 0;
      3: KObj.Value := 1;
      4: KObj.Value := -1;
    end;
    DecodeParmsDict.AddValue('K', KObj);
    ColObj := TVPDFNumericObject.Create(nil);
    ColObj.Value := Width;
    DecodeParmsDict.AddValue('Columns', ColObj);
    RowObj := TVPDFNumericObject.Create(nil);
    RowObj.Value := Height;
    DecodeParmsDict.AddValue('Rows', RowObj);
    DecodeParms := TVPDFArrayObject.Create(nil);
    DecodeParms.AddObject(DecodeParmsDict);
    Dictionary.AddValue('DecodeParms', DecodeParms);
  end
  else
    AddNumericValue('BitsPerComponent', 8);
  if (FIsMask) then
  begin
    IsMaskVal := TVPDFBooleanObject.Create(nil);
    IsMaskVal.Value := true;
    Dictionary.AddValue('ImageMask', IsMaskVal);
  end;
  if (MaskLink <> nil) then
  begin
    Dictionary.AddValue('Mask', MaskLink);
  end;
  AddNameValue('Name', Name);
end;

function TVPDFImage.CreateIndexedColorArray(ABitmap: TBitmap): TVPDFArrayObject;
var
  i: integer;
  S: AnsiString;
  IndexedN: TVPDFNameObject;
  DRGBN: TVPDFNameObject;
  ColNum: TVPDFNumericObject;
  NumOfColors: integer;
  PaletStr: TVPDFStringObject;
  PalEntries: array[0..255] of TPaletteEntry;
begin
  if ABitmap.PixelFormat <> pf8bit then raise Exception.Create('Not supported pixel format.');
  NumOfColors := 256;
  if GetPaletteEntries(ABitmap.Palette, 0, NumOfColors + 1, PalEntries) = 0 then
    raise Exception.Create('Palette error');
  for i := 0 to NumOfColors - 1 do
  begin
    with PalEntries[i] do
      S := S + AnsiString(IntToHex(peRed, 2)) +
        AnsiString(IntToHex(peGreen, 2)) +
        AnsiString(IntToHex(peBlue, 2)) + ' ';
  end;
  PaletStr := TVPDFStringObject.Create(nil);
  PaletStr.IsHexadecimal := true;
  PaletStr.Value := S;
  IndexedN := TVPDFNameObject.Create(nil);
  IndexedN.Value := 'Indexed';
  DRGBN := TVPDFNameObject.Create(nil);
  DRGBN.Value := 'DeviceRGB';
  ColNum := TVPDFNumericObject.Create(nil);
  ColNum.Value := 255;
  Result := TVPDFArrayObject.Create(nil);
  Result.AddObject(IndexedN);
  Result.AddObject(DRGBN);
  Result.AddObject(ColNum);
  Result.AddObject(PaletStr);
end;

end.