View Issue Details

IDProjectCategoryView StatusLast Update
0035109FPCFCLpublic2019-03-02 15:53
ReporterOndrej PokornyAssigned ToMichael Van Canneyt 
PrioritynormalSeverityminorReproducibilityN/A
Status closedResolutionfixed 
Product Version3.3.1Product Build 
Target Version3.2.0Fixed in Version3.3.1 
Summary0035109: (patch) fpPDF: implement image transparency
DescriptionThe attached patch implements image transparency and also extends the demo project to show this new feature. The demo program needs the file "diamond.png" to be added to "packages\fcl-pdf\examples".
TagsNo tags attached.
Fixed in Revision41552
FPCOldBugId
FPCTarget
Attached Files
  • fpPDF-image-transparency-01.patch (14,273 bytes)
    Index: packages/fcl-pdf/examples/testfppdf.lpr
    ===================================================================
    --- packages/fcl-pdf/examples/testfppdf.lpr	(revision 41351)
    +++ packages/fcl-pdf/examples/testfppdf.lpr	(working copy)
    @@ -33,7 +33,8 @@
         FRawJPEG,
         FImageCompression,
         FTextCompression,
    -    FFontCompression: boolean;
    +    FFontCompression,
    +    FImageTransparency: boolean;
         FNoFontEmbedding: boolean;
         FAddMetadata : Boolean;
         FSubsetFontEmbedding: boolean;
    @@ -93,6 +94,8 @@
         Include(lOpts,poCompressText);
       if FImageCompression then
         Include(lOpts,poCompressImages);
    +  if FImageTransparency then
    +    Include(lOpts,poUseImageTransparency);
       if FRawJPEG then
         Include(lOpts,poUseRawJPEG);
       if FAddMetadata then
    @@ -302,7 +305,7 @@
     Var
       P: TPDFPage;
       FtTitle: integer;
    -  IDX: Integer;
    +  IDX, IDX_Diamond: Integer;
       W, H: Integer;
     begin
       P := D.Pages[APage];
    @@ -323,7 +326,11 @@
       { full size image }
       P.DrawImageRawSize(25, 130, W, H, IDX);  // left-bottom coordinate of image
       P.WriteText(145, 90, '[Full size (defined in pixels)]');
    +  P.WriteText(145, 95, '+alpha-transparent overlay (if enabled)');
     
    +  IDX_Diamond := D.Images.AddFromFile('diamond.png',False);
    +  P.DrawImageRawSize(30, 125, D.Images[IDX_Diamond].Width, D.Images[IDX_Diamond].Height, IDX_Diamond);
    +
       { quarter size image }
       P.DrawImageRawSize(25, 190, W shr 1, H shr 1, IDX); // could also have used: Integer(W div 2), Integer(H div 2)
       P.WriteText(85, 180, '[Quarter size (defined in pixels)]');
    @@ -817,6 +824,7 @@
       FFontCompression := BoolFlag('f',true);
       FTextCompression := BoolFlag('t',False);
       FImageCompression := BoolFlag('i',False);
    +  FImageTransparency := BoolFlag('t',False);
       FAddMetadata :=  BoolFlag('m',False);
       FRawJPEG:=BoolFlag('j',False);
     
    @@ -881,6 +889,8 @@
               '                disables compression. A value of 1 enables compression.');
       writeln('    -j <0|1>    Toggle use of JPEG. A value of 0' + LineEnding +
               '                disables use of JPEG images. A value of 1 writes jpeg file as-is');
    +  writeln('    -t <0|1>    Toggle image transparency support. A value of 0' + LineEnding +
    +          '                disables transparency. A value of 1 enables transparency.');
       writeln('');
     end;
     
    Index: packages/fcl-pdf/src/fppdf.pp
    ===================================================================
    --- packages/fcl-pdf/src/fppdf.pp	(revision 41351)
    +++ packages/fcl-pdf/src/fppdf.pp	(working copy)
    @@ -69,7 +69,8 @@
       TPDFPageLayout = (lSingle, lTwo, lContinuous);
       TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels);
     
    -  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID);
    +  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts,
    +    poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency);
       TPDFOptions = set of TPDFOption;
     
       EPDF = Class(Exception);
    @@ -889,22 +890,32 @@
         FOwnsImage: Boolean;
         FStreamed: TBytes;
         FCompression: TPDFImageCompression;
    +    FHasMask: Boolean;
    +    FStreamedMask: TBytes;
    +    FCompressionMask: TPDFImageCompression;
         FWidth,FHeight : Integer;
         function GetHeight: Integer;
         function GetStreamed: TBytes;
    +    function GetStreamedMask: TBytes;
         function GetWidth: Integer;
         procedure SetImage(AValue: TFPCustomImage);
         procedure SetStreamed(AValue: TBytes);
    +  Protected
    +    Function WriteStream(const AStreamedData: TBytes; AStream: TStream): int64; virtual;
       Public
         Destructor Destroy; override;
    -    Procedure CreateStreamedData(AUseCompression: Boolean);
    -    Function WriteImageStream(AStream: TStream): int64; virtual;
    +    Procedure CreateStreamedData(AUseCompression, AUseTransparency: Boolean);
    +    procedure SetStreamedMask(const AValue: TBytes; const ACompression: TPDFImageCompression);
    +    Function WriteImageStream(AStream: TStream): int64;
    +    Function WriteMaskStream(AStream: TStream): int64;
         function Equals(AImage: TFPCustomImage): boolean; reintroduce;
         Property Image : TFPCustomImage Read FImage Write SetImage;
         Property StreamedData : TBytes Read GetStreamed Write SetStreamed;
    +    Property StreamedMask : TBytes Read GetStreamedMask;
         Property OwnsImage : Boolean Read FOwnsImage Write FOwnsImage;
         Property Width : Integer Read GetWidth;
         Property Height : Integer Read GetHeight;
    +    Property HasMask : Boolean read FHasMask;
       end;
     
     
    @@ -1053,7 +1064,10 @@
         procedure CreateToUnicode(const AFontNum: integer);virtual;
         procedure CreateFontFileEntry(const AFontNum: integer);virtual;
         procedure CreateCIDSet(const AFontNum: integer); virtual;
    -    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual;
    +    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
    +      out ImageDict: TPDFDictionary);virtual;
    +    procedure CreateImageMaskEntry(ImgWidth, ImgHeight, NumImg: integer;
    +      ImageDict: TPDFDictionary);virtual;
         function CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; virtual;
         function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual;
         procedure CreatePageStream(APage : TPDFPage; PageNum: integer);
    @@ -2835,13 +2849,20 @@
       if Length(FStreamed)=0 then
       begin
         if Collection.Owner is TPDFDocument then
    -      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options)
    +      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options,
    +        poUseImageTransparency in TPDFDocument(Collection.Owner).Options)
         else
    -      CreateStreamedData(True);
    +      CreateStreamedData(True,True);
       end;
       Result:=FStreamed;
     end;
     
    +function TPDFImageItem.GetStreamedMask: TBytes;
    +begin
    +  GetStreamed; // calls CreateStreamedData
    +  Result:=FStreamedMask;
    +end;
    +
     function TPDFImageItem.GetHeight: Integer;
     begin
       If Assigned(FImage) then
    @@ -2865,6 +2886,26 @@
       FStreamed:=AValue;
     end;
     
    +procedure TPDFImageItem.SetStreamedMask(const AValue: TBytes;
    +  const ACompression: TPDFImageCompression);
    +begin
    +  If AValue=FStreamedMask then exit;
    +  SetLength(FStreamedMask,0);
    +  FStreamedMask:=AValue;
    +  FHasMask:=Length(FStreamedMask)>0;
    +  FCompressionMask:=ACompression;
    +end;
    +
    +function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
    +begin
    +  Result:=WriteStream(FStreamed, AStream);
    +end;
    +
    +function TPDFImageItem.WriteMaskStream(AStream: TStream): int64;
    +begin
    +  Result:=WriteStream(FStreamedMask, AStream);
    +end;
    +
     destructor TPDFImageItem.Destroy;
     begin
       if FOwnsImage then
    @@ -2872,35 +2913,76 @@
       inherited Destroy;
     end;
     
    -procedure TPDFImageItem.CreateStreamedData(AUseCompression: Boolean);
    +procedure TPDFImageItem.CreateStreamedData(AUseCompression,
    +  AUseTransparency: Boolean);
    +
    +  function NeedsTransparency: Boolean;
    +  var
    +    Y, X: Integer;
    +  begin
    +    for Y:=0 to FHeight-1 do
    +      for X:=0 to FWidth-1 do
    +        begin
    +        if Image.Colors[x,y].alpha < $FFFF then // has alpha channel
    +          Exit(True);
    +        end;
    +    Result:=False;
    +  end;
    +
    +  procedure CreateSream(out MS: TMemoryStream; out Str: TStream;
    +    out Compression: TPDFImageCompression);
    +  begin
    +    MS := TMemoryStream.Create;
    +    if AUseCompression then
    +      begin
    +      Compression := icDeflate;
    +      Str := Tcompressionstream.create(cldefault, MS);
    +      end
    +    else
    +      begin
    +      Compression := icNone;
    +      Str := MS;
    +      end;
    +  end;
    +
    +  procedure StreamToBuffer(const MS: TMemoryStream; var Str: TStream; out Buffer: TBytes);
    +  begin
    +    if Str<>MS then
    +      Str.Free;
    +    Str := nil;
    +    SetLength(Buffer, MS.Size);
    +    MS.Position := 0;
    +    if MS.Size>0 then
    +      MS.ReadBuffer(Buffer[0], MS.Size);
    +  end;
    +
     Var
       X,Y : Integer;
       C : TFPColor;
    -  MS : TMemoryStream;
    -  Str : TStream;
    +  MS,MSMask : TMemoryStream;
    +  Str,StrMask : TStream;
       CWhite : TFPColor; // white color
     begin
       FillMem(@CWhite, SizeOf(CWhite), $FF);
       FWidth:=Image.Width;
       FHeight:=Image.Height;
    +  FHasMask:=AUseTransparency and NeedsTransparency;
    +  MS := nil;
       Str := nil;
    -  MS := TMemoryStream.Create;
    +  MSMask := nil;
    +  StrMask := nil;
       try
    -    if AUseCompression then
    -      begin
    -      FCompression := icDeflate;
    -      Str := Tcompressionstream.create(cldefault, MS)
    -      end
    -    else
    -      begin
    -      FCompression := icNone;
    -      Str := MS;
    -      end;
    +    CreateSream(MS, Str, FCompression);
    +    if FHasMask then
    +      CreateSream(MSMask, StrMask, FCompressionMask);
         for Y:=0 to FHeight-1 do
           for X:=0 to FWidth-1 do
             begin
             C:=Image.Colors[x,y];
    -        if C.alpha < $FFFF then // remove alpha channel - assume white background
    +        if FHasMask then
    +          StrMask.WriteByte(C.Alpha shr 8)
    +        else
    +        if (C.alpha < $FFFF) then // remove alpha channel - assume white background
               C := AlphaBlend(CWhite, C);
     
             Str.WriteByte(C.Red shr 8);
    @@ -2907,25 +2989,24 @@
             Str.WriteByte(C.Green shr 8);
             Str.WriteByte(C.Blue shr 8);
             end;
    -    if Str<>MS then
    -      Str.Free;
    -    Str := nil;
    -    SetLength(FStreamed, MS.Size);
    -    MS.Position := 0;
    -    if MS.Size>0 then
    -      MS.ReadBuffer(FStreamed[0], MS.Size);
    +    StreamToBuffer(MS, Str, FStreamed);
    +    if FHasMask then
    +      StreamToBuffer(MSMask, StrMask, FStreamedMask);
       finally
         Str.Free;
    +    StrMask.Free;
         MS.Free;
    +    MSMask.Free;
       end;
     end;
     
    -function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
    +function TPDFImageItem.WriteStream(const AStreamedData: TBytes;
    +  AStream: TStream): int64;
     var
       Img : TBytes;
     begin
       TPDFObject.WriteString(CRLF+'stream'+CRLF,AStream);
    -  Img:=StreamedData;
    +  Img:=AStreamedData;
       Result:=Length(Img);
       AStream.WriteBuffer(Img[0],Result);
       TPDFObject.WriteString(CRLF, AStream);
    @@ -3092,7 +3173,7 @@
         IP.Image:=I;
         if Not KeepImage then
           begin
    -      IP.CreateStreamedData(poCompressImages in Owner.Options);
    +      IP.CreateStreamedData(poCompressImages in Owner.Options, poUseImageTransparency in Owner.Options);
           IP.FImage:=Nil; // not through property, that would clear the image
           i.Free;
           end;
    @@ -4055,6 +4136,22 @@
             begin
               if (E.FKey.Name='Name') then
               begin
    +            if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='M') then
    +            begin
    +              NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
    +              // write image stream length in xobject dictionary
    +              ISize:=Length(Document.Images[NumImg].StreamedMask);
    +              D:=Document.GlobalXRefs[AObject].Dict;
    +              D.AddInteger('Length',ISize);
    +              LastElement.Write(AStream);
    +              case Document.Images[NumImg].FCompressionMask of
    +                icJPEG: WriteString('/Filter /DCTDecode'+CRLF, AStream);
    +                icDeflate: WriteString('/Filter /FlateDecode'+CRLF, AStream);
    +              end;
    +              WriteString('>>', AStream);
    +              // write image stream in xobject dictionary
    +              Document.Images[NumImg].WriteMaskStream(AStream);
    +            end else
                 if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='I') then
                 begin
                   NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
    @@ -5087,24 +5184,25 @@
       lXRef.FStream.AddItem(TPDFCIDSet.Create(self, AFontNum));
     end;
     
    -procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
    +procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
    +  out ImageDict: TPDFDictionary);
     var
       N: TPDFName;
    -  IDict,ADict: TPDFDictionary;
    +  ADict: TPDFDictionary;
       i: integer;
       lXRef: integer;
     begin
       lXRef := GlobalXRefCount; // reference to be used later
     
    -  IDict:=CreateGlobalXRef.Dict;
    -  IDict.AddName('Type','XObject');
    -  IDict.AddName('Subtype','Image');
    -  IDict.AddInteger('Width',ImgWidth);
    -  IDict.AddInteger('Height',ImgHeight);
    -  IDict.AddName('ColorSpace','DeviceRGB');
    -  IDict.AddInteger('BitsPerComponent',8);
    +  ImageDict:=CreateGlobalXRef.Dict;
    +  ImageDict.AddName('Type','XObject');
    +  ImageDict.AddName('Subtype','Image');
    +  ImageDict.AddInteger('Width',ImgWidth);
    +  ImageDict.AddInteger('Height',ImgHeight);
    +  ImageDict.AddName('ColorSpace','DeviceRGB');
    +  ImageDict.AddInteger('BitsPerComponent',8);
       N:=CreateName('I'+IntToStr(NumImg)); // Needed later
    -  IDict.AddElement('Name',N);
    +  ImageDict.AddElement('Name',N);
     
       // now find where we must add the image xref - we are looking for "Resources"
       for i := 1 to GlobalXRefCount-1 do
    @@ -5125,6 +5223,27 @@
       end;
     end;
     
    +procedure TPDFDocument.CreateImageMaskEntry(ImgWidth, ImgHeight,
    +  NumImg: integer; ImageDict: TPDFDictionary);
    +var
    +  N: TPDFName;
    +  MDict: TPDFDictionary;
    +  lXRef: integer;
    +begin
    +  lXRef := GlobalXRefCount; // reference to be used later
    +
    +  MDict:=CreateGlobalXRef.Dict;
    +  MDict.AddName('Type','XObject');
    +  MDict.AddName('Subtype','Image');
    +  MDict.AddInteger('Width',ImgWidth);
    +  MDict.AddInteger('Height',ImgHeight);
    +  MDict.AddName('ColorSpace','DeviceGray');
    +  MDict.AddInteger('BitsPerComponent',8);
    +  N:=CreateName('M'+IntToStr(NumImg)); // Needed later
    +  MDict.AddElement('Name',N);
    +  ImageDict.AddReference('SMask', lXRef);
    +end;
    +
     function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer;
     var
       lDict, ADict: TPDFDictionary;
    @@ -5492,9 +5611,14 @@
     procedure TPDFDocument.CreateImageEntries;
     Var
       I : Integer;
    +  IDict : TPDFDictionary;
     begin
       for i:=0 to Images.Count-1 do
    -    CreateImageEntry(Images[i].Width,Images[i].Height,i);
    +    begin
    +    CreateImageEntry(Images[i].Width,Images[i].Height,i,IDict);
    +    if Images[i].HasMask then
    +      CreateImageMaskEntry(Images[i].Width,Images[i].Height,i,IDict);
    +    end;
     end;
     
     procedure TPDFDocument.CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary);
    
  • diamond.png (2,395 bytes)
    diamond.png (2,395 bytes)
  • fpPDF-image-transparency-02.patch (14,501 bytes)
    Index: packages/fcl-pdf/examples/testfppdf.lpr
    ===================================================================
    --- packages/fcl-pdf/examples/testfppdf.lpr	(revision 41351)
    +++ packages/fcl-pdf/examples/testfppdf.lpr	(working copy)
    @@ -33,7 +33,8 @@
         FRawJPEG,
         FImageCompression,
         FTextCompression,
    -    FFontCompression: boolean;
    +    FFontCompression,
    +    FImageTransparency: boolean;
         FNoFontEmbedding: boolean;
         FAddMetadata : Boolean;
         FSubsetFontEmbedding: boolean;
    @@ -93,6 +94,8 @@
         Include(lOpts,poCompressText);
       if FImageCompression then
         Include(lOpts,poCompressImages);
    +  if FImageTransparency then
    +    Include(lOpts,poUseImageTransparency);
       if FRawJPEG then
         Include(lOpts,poUseRawJPEG);
       if FAddMetadata then
    @@ -302,7 +305,7 @@
     Var
       P: TPDFPage;
       FtTitle: integer;
    -  IDX: Integer;
    +  IDX, IDX_Diamond: Integer;
       W, H: Integer;
     begin
       P := D.Pages[APage];
    @@ -323,7 +326,11 @@
       { full size image }
       P.DrawImageRawSize(25, 130, W, H, IDX);  // left-bottom coordinate of image
       P.WriteText(145, 90, '[Full size (defined in pixels)]');
    +  P.WriteText(145, 95, '+alpha-transparent overlay (if enabled)');
     
    +  IDX_Diamond := D.Images.AddFromFile('diamond.png',False);
    +  P.DrawImageRawSize(30, 125, D.Images[IDX_Diamond].Width, D.Images[IDX_Diamond].Height, IDX_Diamond);
    +
       { quarter size image }
       P.DrawImageRawSize(25, 190, W shr 1, H shr 1, IDX); // could also have used: Integer(W div 2), Integer(H div 2)
       P.WriteText(85, 180, '[Quarter size (defined in pixels)]');
    @@ -817,6 +824,7 @@
       FFontCompression := BoolFlag('f',true);
       FTextCompression := BoolFlag('t',False);
       FImageCompression := BoolFlag('i',False);
    +  FImageTransparency := BoolFlag('t',False);
       FAddMetadata :=  BoolFlag('m',False);
       FRawJPEG:=BoolFlag('j',False);
     
    @@ -881,6 +889,8 @@
               '                disables compression. A value of 1 enables compression.');
       writeln('    -j <0|1>    Toggle use of JPEG. A value of 0' + LineEnding +
               '                disables use of JPEG images. A value of 1 writes jpeg file as-is');
    +  writeln('    -t <0|1>    Toggle image transparency support. A value of 0' + LineEnding +
    +          '                disables transparency. A value of 1 enables transparency.');
       writeln('');
     end;
     
    Index: packages/fcl-pdf/src/fppdf.pp
    ===================================================================
    --- packages/fcl-pdf/src/fppdf.pp	(revision 41351)
    +++ packages/fcl-pdf/src/fppdf.pp	(working copy)
    @@ -69,7 +69,8 @@
       TPDFPageLayout = (lSingle, lTwo, lContinuous);
       TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels);
     
    -  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID);
    +  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts,
    +    poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency);
       TPDFOptions = set of TPDFOption;
     
       EPDF = Class(Exception);
    @@ -889,22 +890,32 @@
         FOwnsImage: Boolean;
         FStreamed: TBytes;
         FCompression: TPDFImageCompression;
    +    FStreamedMask: TBytes;
    +    FCompressionMask: TPDFImageCompression;
         FWidth,FHeight : Integer;
    +    function GetHasMask: Boolean;
         function GetHeight: Integer;
         function GetStreamed: TBytes;
    +    function GetStreamedMask: TBytes;
         function GetWidth: Integer;
         procedure SetImage(AValue: TFPCustomImage);
         procedure SetStreamed(AValue: TBytes);
    +  Protected
    +    Function WriteStream(const AStreamedData: TBytes; AStream: TStream): int64; virtual;
       Public
         Destructor Destroy; override;
    -    Procedure CreateStreamedData(AUseCompression: Boolean);
    -    Function WriteImageStream(AStream: TStream): int64; virtual;
    +    Procedure CreateStreamedData(AUseCompression, AUseTransparency: Boolean);
    +    procedure SetStreamedMask(const AValue: TBytes; const ACompression: TPDFImageCompression);
    +    Function WriteImageStream(AStream: TStream): int64;
    +    Function WriteMaskStream(AStream: TStream): int64;
         function Equals(AImage: TFPCustomImage): boolean; reintroduce;
         Property Image : TFPCustomImage Read FImage Write SetImage;
         Property StreamedData : TBytes Read GetStreamed Write SetStreamed;
    +    Property StreamedMask : TBytes Read GetStreamedMask;
         Property OwnsImage : Boolean Read FOwnsImage Write FOwnsImage;
         Property Width : Integer Read GetWidth;
         Property Height : Integer Read GetHeight;
    +    Property HasMask : Boolean read GetHasMask;
       end;
     
     
    @@ -1053,7 +1064,10 @@
         procedure CreateToUnicode(const AFontNum: integer);virtual;
         procedure CreateFontFileEntry(const AFontNum: integer);virtual;
         procedure CreateCIDSet(const AFontNum: integer); virtual;
    -    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual;
    +    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
    +      out ImageDict: TPDFDictionary);virtual;
    +    procedure CreateImageMaskEntry(ImgWidth, ImgHeight, NumImg: integer;
    +      ImageDict: TPDFDictionary);virtual;
         function CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; virtual;
         function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual;
         procedure CreatePageStream(APage : TPDFPage; PageNum: integer);
    @@ -2835,13 +2849,20 @@
       if Length(FStreamed)=0 then
       begin
         if Collection.Owner is TPDFDocument then
    -      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options)
    +      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options,
    +        poUseImageTransparency in TPDFDocument(Collection.Owner).Options)
         else
    -      CreateStreamedData(True);
    +      CreateStreamedData(True,True);
       end;
       Result:=FStreamed;
     end;
     
    +function TPDFImageItem.GetStreamedMask: TBytes;
    +begin
    +  GetStreamed; // calls CreateStreamedData
    +  Result:=FStreamedMask;
    +end;
    +
     function TPDFImageItem.GetHeight: Integer;
     begin
       If Assigned(FImage) then
    @@ -2865,6 +2886,25 @@
       FStreamed:=AValue;
     end;
     
    +procedure TPDFImageItem.SetStreamedMask(const AValue: TBytes;
    +  const ACompression: TPDFImageCompression);
    +begin
    +  If AValue=FStreamedMask then exit;
    +  SetLength(FStreamedMask,0);
    +  FStreamedMask:=AValue;
    +  FCompressionMask:=ACompression;
    +end;
    +
    +function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
    +begin
    +  Result:=WriteStream(FStreamed, AStream);
    +end;
    +
    +function TPDFImageItem.WriteMaskStream(AStream: TStream): int64;
    +begin
    +  Result:=WriteStream(FStreamedMask, AStream);
    +end;
    +
     destructor TPDFImageItem.Destroy;
     begin
       if FOwnsImage then
    @@ -2872,35 +2912,77 @@
       inherited Destroy;
     end;
     
    -procedure TPDFImageItem.CreateStreamedData(AUseCompression: Boolean);
    +procedure TPDFImageItem.CreateStreamedData(AUseCompression,
    +  AUseTransparency: Boolean);
    +
    +  function NeedsTransparency: Boolean;
    +  var
    +    Y, X: Integer;
    +  begin
    +    for Y:=0 to FHeight-1 do
    +      for X:=0 to FWidth-1 do
    +        begin
    +        if Image.Colors[x,y].alpha < $FFFF then // has alpha channel
    +          Exit(True);
    +        end;
    +    Result:=False;
    +  end;
    +
    +  procedure CreateSream(out MS: TMemoryStream; out Str: TStream;
    +    out Compression: TPDFImageCompression);
    +  begin
    +    MS := TMemoryStream.Create;
    +    if AUseCompression then
    +      begin
    +      Compression := icDeflate;
    +      Str := Tcompressionstream.create(cldefault, MS);
    +      end
    +    else
    +      begin
    +      Compression := icNone;
    +      Str := MS;
    +      end;
    +  end;
    +
    +  procedure StreamToBuffer(const MS: TMemoryStream; var Str: TStream; out Buffer: TBytes);
    +  begin
    +    if Str<>MS then
    +      Str.Free;
    +    Str := nil;
    +    SetLength(Buffer, MS.Size);
    +    MS.Position := 0;
    +    if MS.Size>0 then
    +      MS.ReadBuffer(Buffer[0], MS.Size);
    +  end;
    +
     Var
       X,Y : Integer;
       C : TFPColor;
    -  MS : TMemoryStream;
    -  Str : TStream;
    +  MS,MSMask : TMemoryStream;
    +  Str,StrMask : TStream;
       CWhite : TFPColor; // white color
    +  CreateMask : Boolean;
     begin
       FillMem(@CWhite, SizeOf(CWhite), $FF);
       FWidth:=Image.Width;
       FHeight:=Image.Height;
    +  CreateMask:=AUseTransparency and NeedsTransparency;
    +  MS := nil;
       Str := nil;
    -  MS := TMemoryStream.Create;
    +  MSMask := nil;
    +  StrMask := nil;
       try
    -    if AUseCompression then
    -      begin
    -      FCompression := icDeflate;
    -      Str := Tcompressionstream.create(cldefault, MS)
    -      end
    -    else
    -      begin
    -      FCompression := icNone;
    -      Str := MS;
    -      end;
    +    CreateSream(MS, Str, FCompression);
    +    if CreateMask then
    +      CreateSream(MSMask, StrMask, FCompressionMask);
         for Y:=0 to FHeight-1 do
           for X:=0 to FWidth-1 do
             begin
             C:=Image.Colors[x,y];
    -        if C.alpha < $FFFF then // remove alpha channel - assume white background
    +        if CreateMask then
    +          StrMask.WriteByte(C.Alpha shr 8)
    +        else
    +        if (C.alpha < $FFFF) then // remove alpha channel - assume white background
               C := AlphaBlend(CWhite, C);
     
             Str.WriteByte(C.Red shr 8);
    @@ -2907,25 +2989,24 @@
             Str.WriteByte(C.Green shr 8);
             Str.WriteByte(C.Blue shr 8);
             end;
    -    if Str<>MS then
    -      Str.Free;
    -    Str := nil;
    -    SetLength(FStreamed, MS.Size);
    -    MS.Position := 0;
    -    if MS.Size>0 then
    -      MS.ReadBuffer(FStreamed[0], MS.Size);
    +    StreamToBuffer(MS, Str, FStreamed);
    +    if CreateMask then
    +      StreamToBuffer(MSMask, StrMask, FStreamedMask);
       finally
         Str.Free;
    +    StrMask.Free;
         MS.Free;
    +    MSMask.Free;
       end;
     end;
     
    -function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
    +function TPDFImageItem.WriteStream(const AStreamedData: TBytes;
    +  AStream: TStream): int64;
     var
       Img : TBytes;
     begin
       TPDFObject.WriteString(CRLF+'stream'+CRLF,AStream);
    -  Img:=StreamedData;
    +  Img:=AStreamedData;
       Result:=Length(Img);
       AStream.WriteBuffer(Img[0],Result);
       TPDFObject.WriteString(CRLF, AStream);
    @@ -2956,6 +3037,11 @@
           end;
     end;
     
    +function TPDFImageItem.GetHasMask: Boolean;
    +begin
    +  Result := Length(FStreamedMask)>0;
    +end;
    +
     { TPDFImages }
     
     function TPDFImages.GetI(AIndex : Integer): TPDFImageItem;
    @@ -3092,7 +3178,7 @@
         IP.Image:=I;
         if Not KeepImage then
           begin
    -      IP.CreateStreamedData(poCompressImages in Owner.Options);
    +      IP.CreateStreamedData(poCompressImages in Owner.Options, poUseImageTransparency in Owner.Options);
           IP.FImage:=Nil; // not through property, that would clear the image
           i.Free;
           end;
    @@ -4055,6 +4141,22 @@
             begin
               if (E.FKey.Name='Name') then
               begin
    +            if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='M') then
    +            begin
    +              NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
    +              // write image stream length in xobject dictionary
    +              ISize:=Length(Document.Images[NumImg].StreamedMask);
    +              D:=Document.GlobalXRefs[AObject].Dict;
    +              D.AddInteger('Length',ISize);
    +              LastElement.Write(AStream);
    +              case Document.Images[NumImg].FCompressionMask of
    +                icJPEG: WriteString('/Filter /DCTDecode'+CRLF, AStream);
    +                icDeflate: WriteString('/Filter /FlateDecode'+CRLF, AStream);
    +              end;
    +              WriteString('>>', AStream);
    +              // write image stream in xobject dictionary
    +              Document.Images[NumImg].WriteMaskStream(AStream);
    +            end else
                 if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='I') then
                 begin
                   NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
    @@ -5087,24 +5189,25 @@
       lXRef.FStream.AddItem(TPDFCIDSet.Create(self, AFontNum));
     end;
     
    -procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
    +procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
    +  out ImageDict: TPDFDictionary);
     var
       N: TPDFName;
    -  IDict,ADict: TPDFDictionary;
    +  ADict: TPDFDictionary;
       i: integer;
       lXRef: integer;
     begin
       lXRef := GlobalXRefCount; // reference to be used later
     
    -  IDict:=CreateGlobalXRef.Dict;
    -  IDict.AddName('Type','XObject');
    -  IDict.AddName('Subtype','Image');
    -  IDict.AddInteger('Width',ImgWidth);
    -  IDict.AddInteger('Height',ImgHeight);
    -  IDict.AddName('ColorSpace','DeviceRGB');
    -  IDict.AddInteger('BitsPerComponent',8);
    +  ImageDict:=CreateGlobalXRef.Dict;
    +  ImageDict.AddName('Type','XObject');
    +  ImageDict.AddName('Subtype','Image');
    +  ImageDict.AddInteger('Width',ImgWidth);
    +  ImageDict.AddInteger('Height',ImgHeight);
    +  ImageDict.AddName('ColorSpace','DeviceRGB');
    +  ImageDict.AddInteger('BitsPerComponent',8);
       N:=CreateName('I'+IntToStr(NumImg)); // Needed later
    -  IDict.AddElement('Name',N);
    +  ImageDict.AddElement('Name',N);
     
       // now find where we must add the image xref - we are looking for "Resources"
       for i := 1 to GlobalXRefCount-1 do
    @@ -5125,6 +5228,27 @@
       end;
     end;
     
    +procedure TPDFDocument.CreateImageMaskEntry(ImgWidth, ImgHeight,
    +  NumImg: integer; ImageDict: TPDFDictionary);
    +var
    +  N: TPDFName;
    +  MDict: TPDFDictionary;
    +  lXRef: integer;
    +begin
    +  lXRef := GlobalXRefCount; // reference to be used later
    +
    +  MDict:=CreateGlobalXRef.Dict;
    +  MDict.AddName('Type','XObject');
    +  MDict.AddName('Subtype','Image');
    +  MDict.AddInteger('Width',ImgWidth);
    +  MDict.AddInteger('Height',ImgHeight);
    +  MDict.AddName('ColorSpace','DeviceGray');
    +  MDict.AddInteger('BitsPerComponent',8);
    +  N:=CreateName('M'+IntToStr(NumImg)); // Needed later
    +  MDict.AddElement('Name',N);
    +  ImageDict.AddReference('SMask', lXRef);
    +end;
    +
     function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer;
     var
       lDict, ADict: TPDFDictionary;
    @@ -5492,9 +5616,14 @@
     procedure TPDFDocument.CreateImageEntries;
     Var
       I : Integer;
    +  IDict : TPDFDictionary;
     begin
       for i:=0 to Images.Count-1 do
    -    CreateImageEntry(Images[i].Width,Images[i].Height,i);
    +    begin
    +    CreateImageEntry(Images[i].Width,Images[i].Height,i,IDict);
    +    if Images[i].HasMask then
    +      CreateImageMaskEntry(Images[i].Width,Images[i].Height,i,IDict);
    +    end;
     end;
     
     procedure TPDFDocument.CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary);
    

Activities

Ondrej Pokorny

2019-02-17 22:17

reporter  

fpPDF-image-transparency-01.patch (14,273 bytes)
Index: packages/fcl-pdf/examples/testfppdf.lpr
===================================================================
--- packages/fcl-pdf/examples/testfppdf.lpr	(revision 41351)
+++ packages/fcl-pdf/examples/testfppdf.lpr	(working copy)
@@ -33,7 +33,8 @@
     FRawJPEG,
     FImageCompression,
     FTextCompression,
-    FFontCompression: boolean;
+    FFontCompression,
+    FImageTransparency: boolean;
     FNoFontEmbedding: boolean;
     FAddMetadata : Boolean;
     FSubsetFontEmbedding: boolean;
@@ -93,6 +94,8 @@
     Include(lOpts,poCompressText);
   if FImageCompression then
     Include(lOpts,poCompressImages);
+  if FImageTransparency then
+    Include(lOpts,poUseImageTransparency);
   if FRawJPEG then
     Include(lOpts,poUseRawJPEG);
   if FAddMetadata then
@@ -302,7 +305,7 @@
 Var
   P: TPDFPage;
   FtTitle: integer;
-  IDX: Integer;
+  IDX, IDX_Diamond: Integer;
   W, H: Integer;
 begin
   P := D.Pages[APage];
@@ -323,7 +326,11 @@
   { full size image }
   P.DrawImageRawSize(25, 130, W, H, IDX);  // left-bottom coordinate of image
   P.WriteText(145, 90, '[Full size (defined in pixels)]');
+  P.WriteText(145, 95, '+alpha-transparent overlay (if enabled)');
 
+  IDX_Diamond := D.Images.AddFromFile('diamond.png',False);
+  P.DrawImageRawSize(30, 125, D.Images[IDX_Diamond].Width, D.Images[IDX_Diamond].Height, IDX_Diamond);
+
   { quarter size image }
   P.DrawImageRawSize(25, 190, W shr 1, H shr 1, IDX); // could also have used: Integer(W div 2), Integer(H div 2)
   P.WriteText(85, 180, '[Quarter size (defined in pixels)]');
@@ -817,6 +824,7 @@
   FFontCompression := BoolFlag('f',true);
   FTextCompression := BoolFlag('t',False);
   FImageCompression := BoolFlag('i',False);
+  FImageTransparency := BoolFlag('t',False);
   FAddMetadata :=  BoolFlag('m',False);
   FRawJPEG:=BoolFlag('j',False);
 
@@ -881,6 +889,8 @@
           '                disables compression. A value of 1 enables compression.');
   writeln('    -j <0|1>    Toggle use of JPEG. A value of 0' + LineEnding +
           '                disables use of JPEG images. A value of 1 writes jpeg file as-is');
+  writeln('    -t <0|1>    Toggle image transparency support. A value of 0' + LineEnding +
+          '                disables transparency. A value of 1 enables transparency.');
   writeln('');
 end;
 
Index: packages/fcl-pdf/src/fppdf.pp
===================================================================
--- packages/fcl-pdf/src/fppdf.pp	(revision 41351)
+++ packages/fcl-pdf/src/fppdf.pp	(working copy)
@@ -69,7 +69,8 @@
   TPDFPageLayout = (lSingle, lTwo, lContinuous);
   TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels);
 
-  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID);
+  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts,
+    poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency);
   TPDFOptions = set of TPDFOption;
 
   EPDF = Class(Exception);
@@ -889,22 +890,32 @@
     FOwnsImage: Boolean;
     FStreamed: TBytes;
     FCompression: TPDFImageCompression;
+    FHasMask: Boolean;
+    FStreamedMask: TBytes;
+    FCompressionMask: TPDFImageCompression;
     FWidth,FHeight : Integer;
     function GetHeight: Integer;
     function GetStreamed: TBytes;
+    function GetStreamedMask: TBytes;
     function GetWidth: Integer;
     procedure SetImage(AValue: TFPCustomImage);
     procedure SetStreamed(AValue: TBytes);
+  Protected
+    Function WriteStream(const AStreamedData: TBytes; AStream: TStream): int64; virtual;
   Public
     Destructor Destroy; override;
-    Procedure CreateStreamedData(AUseCompression: Boolean);
-    Function WriteImageStream(AStream: TStream): int64; virtual;
+    Procedure CreateStreamedData(AUseCompression, AUseTransparency: Boolean);
+    procedure SetStreamedMask(const AValue: TBytes; const ACompression: TPDFImageCompression);
+    Function WriteImageStream(AStream: TStream): int64;
+    Function WriteMaskStream(AStream: TStream): int64;
     function Equals(AImage: TFPCustomImage): boolean; reintroduce;
     Property Image : TFPCustomImage Read FImage Write SetImage;
     Property StreamedData : TBytes Read GetStreamed Write SetStreamed;
+    Property StreamedMask : TBytes Read GetStreamedMask;
     Property OwnsImage : Boolean Read FOwnsImage Write FOwnsImage;
     Property Width : Integer Read GetWidth;
     Property Height : Integer Read GetHeight;
+    Property HasMask : Boolean read FHasMask;
   end;
 
 
@@ -1053,7 +1064,10 @@
     procedure CreateToUnicode(const AFontNum: integer);virtual;
     procedure CreateFontFileEntry(const AFontNum: integer);virtual;
     procedure CreateCIDSet(const AFontNum: integer); virtual;
-    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual;
+    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
+      out ImageDict: TPDFDictionary);virtual;
+    procedure CreateImageMaskEntry(ImgWidth, ImgHeight, NumImg: integer;
+      ImageDict: TPDFDictionary);virtual;
     function CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; virtual;
     function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual;
     procedure CreatePageStream(APage : TPDFPage; PageNum: integer);
@@ -2835,13 +2849,20 @@
   if Length(FStreamed)=0 then
   begin
     if Collection.Owner is TPDFDocument then
-      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options)
+      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options,
+        poUseImageTransparency in TPDFDocument(Collection.Owner).Options)
     else
-      CreateStreamedData(True);
+      CreateStreamedData(True,True);
   end;
   Result:=FStreamed;
 end;
 
+function TPDFImageItem.GetStreamedMask: TBytes;
+begin
+  GetStreamed; // calls CreateStreamedData
+  Result:=FStreamedMask;
+end;
+
 function TPDFImageItem.GetHeight: Integer;
 begin
   If Assigned(FImage) then
@@ -2865,6 +2886,26 @@
   FStreamed:=AValue;
 end;
 
+procedure TPDFImageItem.SetStreamedMask(const AValue: TBytes;
+  const ACompression: TPDFImageCompression);
+begin
+  If AValue=FStreamedMask then exit;
+  SetLength(FStreamedMask,0);
+  FStreamedMask:=AValue;
+  FHasMask:=Length(FStreamedMask)>0;
+  FCompressionMask:=ACompression;
+end;
+
+function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
+begin
+  Result:=WriteStream(FStreamed, AStream);
+end;
+
+function TPDFImageItem.WriteMaskStream(AStream: TStream): int64;
+begin
+  Result:=WriteStream(FStreamedMask, AStream);
+end;
+
 destructor TPDFImageItem.Destroy;
 begin
   if FOwnsImage then
@@ -2872,35 +2913,76 @@
   inherited Destroy;
 end;
 
-procedure TPDFImageItem.CreateStreamedData(AUseCompression: Boolean);
+procedure TPDFImageItem.CreateStreamedData(AUseCompression,
+  AUseTransparency: Boolean);
+
+  function NeedsTransparency: Boolean;
+  var
+    Y, X: Integer;
+  begin
+    for Y:=0 to FHeight-1 do
+      for X:=0 to FWidth-1 do
+        begin
+        if Image.Colors[x,y].alpha < $FFFF then // has alpha channel
+          Exit(True);
+        end;
+    Result:=False;
+  end;
+
+  procedure CreateSream(out MS: TMemoryStream; out Str: TStream;
+    out Compression: TPDFImageCompression);
+  begin
+    MS := TMemoryStream.Create;
+    if AUseCompression then
+      begin
+      Compression := icDeflate;
+      Str := Tcompressionstream.create(cldefault, MS);
+      end
+    else
+      begin
+      Compression := icNone;
+      Str := MS;
+      end;
+  end;
+
+  procedure StreamToBuffer(const MS: TMemoryStream; var Str: TStream; out Buffer: TBytes);
+  begin
+    if Str<>MS then
+      Str.Free;
+    Str := nil;
+    SetLength(Buffer, MS.Size);
+    MS.Position := 0;
+    if MS.Size>0 then
+      MS.ReadBuffer(Buffer[0], MS.Size);
+  end;
+
 Var
   X,Y : Integer;
   C : TFPColor;
-  MS : TMemoryStream;
-  Str : TStream;
+  MS,MSMask : TMemoryStream;
+  Str,StrMask : TStream;
   CWhite : TFPColor; // white color
 begin
   FillMem(@CWhite, SizeOf(CWhite), $FF);
   FWidth:=Image.Width;
   FHeight:=Image.Height;
+  FHasMask:=AUseTransparency and NeedsTransparency;
+  MS := nil;
   Str := nil;
-  MS := TMemoryStream.Create;
+  MSMask := nil;
+  StrMask := nil;
   try
-    if AUseCompression then
-      begin
-      FCompression := icDeflate;
-      Str := Tcompressionstream.create(cldefault, MS)
-      end
-    else
-      begin
-      FCompression := icNone;
-      Str := MS;
-      end;
+    CreateSream(MS, Str, FCompression);
+    if FHasMask then
+      CreateSream(MSMask, StrMask, FCompressionMask);
     for Y:=0 to FHeight-1 do
       for X:=0 to FWidth-1 do
         begin
         C:=Image.Colors[x,y];
-        if C.alpha < $FFFF then // remove alpha channel - assume white background
+        if FHasMask then
+          StrMask.WriteByte(C.Alpha shr 8)
+        else
+        if (C.alpha < $FFFF) then // remove alpha channel - assume white background
           C := AlphaBlend(CWhite, C);
 
         Str.WriteByte(C.Red shr 8);
@@ -2907,25 +2989,24 @@
         Str.WriteByte(C.Green shr 8);
         Str.WriteByte(C.Blue shr 8);
         end;
-    if Str<>MS then
-      Str.Free;
-    Str := nil;
-    SetLength(FStreamed, MS.Size);
-    MS.Position := 0;
-    if MS.Size>0 then
-      MS.ReadBuffer(FStreamed[0], MS.Size);
+    StreamToBuffer(MS, Str, FStreamed);
+    if FHasMask then
+      StreamToBuffer(MSMask, StrMask, FStreamedMask);
   finally
     Str.Free;
+    StrMask.Free;
     MS.Free;
+    MSMask.Free;
   end;
 end;
 
-function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
+function TPDFImageItem.WriteStream(const AStreamedData: TBytes;
+  AStream: TStream): int64;
 var
   Img : TBytes;
 begin
   TPDFObject.WriteString(CRLF+'stream'+CRLF,AStream);
-  Img:=StreamedData;
+  Img:=AStreamedData;
   Result:=Length(Img);
   AStream.WriteBuffer(Img[0],Result);
   TPDFObject.WriteString(CRLF, AStream);
@@ -3092,7 +3173,7 @@
     IP.Image:=I;
     if Not KeepImage then
       begin
-      IP.CreateStreamedData(poCompressImages in Owner.Options);
+      IP.CreateStreamedData(poCompressImages in Owner.Options, poUseImageTransparency in Owner.Options);
       IP.FImage:=Nil; // not through property, that would clear the image
       i.Free;
       end;
@@ -4055,6 +4136,22 @@
         begin
           if (E.FKey.Name='Name') then
           begin
+            if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='M') then
+            begin
+              NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
+              // write image stream length in xobject dictionary
+              ISize:=Length(Document.Images[NumImg].StreamedMask);
+              D:=Document.GlobalXRefs[AObject].Dict;
+              D.AddInteger('Length',ISize);
+              LastElement.Write(AStream);
+              case Document.Images[NumImg].FCompressionMask of
+                icJPEG: WriteString('/Filter /DCTDecode'+CRLF, AStream);
+                icDeflate: WriteString('/Filter /FlateDecode'+CRLF, AStream);
+              end;
+              WriteString('>>', AStream);
+              // write image stream in xobject dictionary
+              Document.Images[NumImg].WriteMaskStream(AStream);
+            end else
             if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='I') then
             begin
               NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
@@ -5087,24 +5184,25 @@
   lXRef.FStream.AddItem(TPDFCIDSet.Create(self, AFontNum));
 end;
 
-procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
+procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
+  out ImageDict: TPDFDictionary);
 var
   N: TPDFName;
-  IDict,ADict: TPDFDictionary;
+  ADict: TPDFDictionary;
   i: integer;
   lXRef: integer;
 begin
   lXRef := GlobalXRefCount; // reference to be used later
 
-  IDict:=CreateGlobalXRef.Dict;
-  IDict.AddName('Type','XObject');
-  IDict.AddName('Subtype','Image');
-  IDict.AddInteger('Width',ImgWidth);
-  IDict.AddInteger('Height',ImgHeight);
-  IDict.AddName('ColorSpace','DeviceRGB');
-  IDict.AddInteger('BitsPerComponent',8);
+  ImageDict:=CreateGlobalXRef.Dict;
+  ImageDict.AddName('Type','XObject');
+  ImageDict.AddName('Subtype','Image');
+  ImageDict.AddInteger('Width',ImgWidth);
+  ImageDict.AddInteger('Height',ImgHeight);
+  ImageDict.AddName('ColorSpace','DeviceRGB');
+  ImageDict.AddInteger('BitsPerComponent',8);
   N:=CreateName('I'+IntToStr(NumImg)); // Needed later
-  IDict.AddElement('Name',N);
+  ImageDict.AddElement('Name',N);
 
   // now find where we must add the image xref - we are looking for "Resources"
   for i := 1 to GlobalXRefCount-1 do
@@ -5125,6 +5223,27 @@
   end;
 end;
 
+procedure TPDFDocument.CreateImageMaskEntry(ImgWidth, ImgHeight,
+  NumImg: integer; ImageDict: TPDFDictionary);
+var
+  N: TPDFName;
+  MDict: TPDFDictionary;
+  lXRef: integer;
+begin
+  lXRef := GlobalXRefCount; // reference to be used later
+
+  MDict:=CreateGlobalXRef.Dict;
+  MDict.AddName('Type','XObject');
+  MDict.AddName('Subtype','Image');
+  MDict.AddInteger('Width',ImgWidth);
+  MDict.AddInteger('Height',ImgHeight);
+  MDict.AddName('ColorSpace','DeviceGray');
+  MDict.AddInteger('BitsPerComponent',8);
+  N:=CreateName('M'+IntToStr(NumImg)); // Needed later
+  MDict.AddElement('Name',N);
+  ImageDict.AddReference('SMask', lXRef);
+end;
+
 function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer;
 var
   lDict, ADict: TPDFDictionary;
@@ -5492,9 +5611,14 @@
 procedure TPDFDocument.CreateImageEntries;
 Var
   I : Integer;
+  IDict : TPDFDictionary;
 begin
   for i:=0 to Images.Count-1 do
-    CreateImageEntry(Images[i].Width,Images[i].Height,i);
+    begin
+    CreateImageEntry(Images[i].Width,Images[i].Height,i,IDict);
+    if Images[i].HasMask then
+      CreateImageMaskEntry(Images[i].Width,Images[i].Height,i,IDict);
+    end;
 end;
 
 procedure TPDFDocument.CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary);

Ondrej Pokorny

2019-02-17 22:18

reporter  

diamond.png (2,395 bytes)
diamond.png (2,395 bytes)

Ondrej Pokorny

2019-02-21 05:24

reporter  

fpPDF-image-transparency-02.patch (14,501 bytes)
Index: packages/fcl-pdf/examples/testfppdf.lpr
===================================================================
--- packages/fcl-pdf/examples/testfppdf.lpr	(revision 41351)
+++ packages/fcl-pdf/examples/testfppdf.lpr	(working copy)
@@ -33,7 +33,8 @@
     FRawJPEG,
     FImageCompression,
     FTextCompression,
-    FFontCompression: boolean;
+    FFontCompression,
+    FImageTransparency: boolean;
     FNoFontEmbedding: boolean;
     FAddMetadata : Boolean;
     FSubsetFontEmbedding: boolean;
@@ -93,6 +94,8 @@
     Include(lOpts,poCompressText);
   if FImageCompression then
     Include(lOpts,poCompressImages);
+  if FImageTransparency then
+    Include(lOpts,poUseImageTransparency);
   if FRawJPEG then
     Include(lOpts,poUseRawJPEG);
   if FAddMetadata then
@@ -302,7 +305,7 @@
 Var
   P: TPDFPage;
   FtTitle: integer;
-  IDX: Integer;
+  IDX, IDX_Diamond: Integer;
   W, H: Integer;
 begin
   P := D.Pages[APage];
@@ -323,7 +326,11 @@
   { full size image }
   P.DrawImageRawSize(25, 130, W, H, IDX);  // left-bottom coordinate of image
   P.WriteText(145, 90, '[Full size (defined in pixels)]');
+  P.WriteText(145, 95, '+alpha-transparent overlay (if enabled)');
 
+  IDX_Diamond := D.Images.AddFromFile('diamond.png',False);
+  P.DrawImageRawSize(30, 125, D.Images[IDX_Diamond].Width, D.Images[IDX_Diamond].Height, IDX_Diamond);
+
   { quarter size image }
   P.DrawImageRawSize(25, 190, W shr 1, H shr 1, IDX); // could also have used: Integer(W div 2), Integer(H div 2)
   P.WriteText(85, 180, '[Quarter size (defined in pixels)]');
@@ -817,6 +824,7 @@
   FFontCompression := BoolFlag('f',true);
   FTextCompression := BoolFlag('t',False);
   FImageCompression := BoolFlag('i',False);
+  FImageTransparency := BoolFlag('t',False);
   FAddMetadata :=  BoolFlag('m',False);
   FRawJPEG:=BoolFlag('j',False);
 
@@ -881,6 +889,8 @@
           '                disables compression. A value of 1 enables compression.');
   writeln('    -j <0|1>    Toggle use of JPEG. A value of 0' + LineEnding +
           '                disables use of JPEG images. A value of 1 writes jpeg file as-is');
+  writeln('    -t <0|1>    Toggle image transparency support. A value of 0' + LineEnding +
+          '                disables transparency. A value of 1 enables transparency.');
   writeln('');
 end;
 
Index: packages/fcl-pdf/src/fppdf.pp
===================================================================
--- packages/fcl-pdf/src/fppdf.pp	(revision 41351)
+++ packages/fcl-pdf/src/fppdf.pp	(working copy)
@@ -69,7 +69,8 @@
   TPDFPageLayout = (lSingle, lTwo, lContinuous);
   TPDFUnitOfMeasure = (uomInches, uomMillimeters, uomCentimeters, uomPixels);
 
-  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts, poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID);
+  TPDFOption = (poOutLine, poCompressText, poCompressFonts, poCompressImages, poUseRawJPEG, poNoEmbeddedFonts,
+    poPageOriginAtTop, poSubsetFont, poMetadataEntry, poNoTrailerID, poUseImageTransparency);
   TPDFOptions = set of TPDFOption;
 
   EPDF = Class(Exception);
@@ -889,22 +890,32 @@
     FOwnsImage: Boolean;
     FStreamed: TBytes;
     FCompression: TPDFImageCompression;
+    FStreamedMask: TBytes;
+    FCompressionMask: TPDFImageCompression;
     FWidth,FHeight : Integer;
+    function GetHasMask: Boolean;
     function GetHeight: Integer;
     function GetStreamed: TBytes;
+    function GetStreamedMask: TBytes;
     function GetWidth: Integer;
     procedure SetImage(AValue: TFPCustomImage);
     procedure SetStreamed(AValue: TBytes);
+  Protected
+    Function WriteStream(const AStreamedData: TBytes; AStream: TStream): int64; virtual;
   Public
     Destructor Destroy; override;
-    Procedure CreateStreamedData(AUseCompression: Boolean);
-    Function WriteImageStream(AStream: TStream): int64; virtual;
+    Procedure CreateStreamedData(AUseCompression, AUseTransparency: Boolean);
+    procedure SetStreamedMask(const AValue: TBytes; const ACompression: TPDFImageCompression);
+    Function WriteImageStream(AStream: TStream): int64;
+    Function WriteMaskStream(AStream: TStream): int64;
     function Equals(AImage: TFPCustomImage): boolean; reintroduce;
     Property Image : TFPCustomImage Read FImage Write SetImage;
     Property StreamedData : TBytes Read GetStreamed Write SetStreamed;
+    Property StreamedMask : TBytes Read GetStreamedMask;
     Property OwnsImage : Boolean Read FOwnsImage Write FOwnsImage;
     Property Width : Integer Read GetWidth;
     Property Height : Integer Read GetHeight;
+    Property HasMask : Boolean read GetHasMask;
   end;
 
 
@@ -1053,7 +1064,10 @@
     procedure CreateToUnicode(const AFontNum: integer);virtual;
     procedure CreateFontFileEntry(const AFontNum: integer);virtual;
     procedure CreateCIDSet(const AFontNum: integer); virtual;
-    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);virtual;
+    procedure CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
+      out ImageDict: TPDFDictionary);virtual;
+    procedure CreateImageMaskEntry(ImgWidth, ImgHeight, NumImg: integer;
+      ImageDict: TPDFDictionary);virtual;
     function CreateAnnotEntry(const APageNum, AnnotNum: integer): integer; virtual;
     function CreateCIDToGIDMap(const AFontNum: integer): integer; virtual;
     procedure CreatePageStream(APage : TPDFPage; PageNum: integer);
@@ -2835,13 +2849,20 @@
   if Length(FStreamed)=0 then
   begin
     if Collection.Owner is TPDFDocument then
-      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options)
+      CreateStreamedData(poCompressImages in TPDFDocument(Collection.Owner).Options,
+        poUseImageTransparency in TPDFDocument(Collection.Owner).Options)
     else
-      CreateStreamedData(True);
+      CreateStreamedData(True,True);
   end;
   Result:=FStreamed;
 end;
 
+function TPDFImageItem.GetStreamedMask: TBytes;
+begin
+  GetStreamed; // calls CreateStreamedData
+  Result:=FStreamedMask;
+end;
+
 function TPDFImageItem.GetHeight: Integer;
 begin
   If Assigned(FImage) then
@@ -2865,6 +2886,25 @@
   FStreamed:=AValue;
 end;
 
+procedure TPDFImageItem.SetStreamedMask(const AValue: TBytes;
+  const ACompression: TPDFImageCompression);
+begin
+  If AValue=FStreamedMask then exit;
+  SetLength(FStreamedMask,0);
+  FStreamedMask:=AValue;
+  FCompressionMask:=ACompression;
+end;
+
+function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
+begin
+  Result:=WriteStream(FStreamed, AStream);
+end;
+
+function TPDFImageItem.WriteMaskStream(AStream: TStream): int64;
+begin
+  Result:=WriteStream(FStreamedMask, AStream);
+end;
+
 destructor TPDFImageItem.Destroy;
 begin
   if FOwnsImage then
@@ -2872,35 +2912,77 @@
   inherited Destroy;
 end;
 
-procedure TPDFImageItem.CreateStreamedData(AUseCompression: Boolean);
+procedure TPDFImageItem.CreateStreamedData(AUseCompression,
+  AUseTransparency: Boolean);
+
+  function NeedsTransparency: Boolean;
+  var
+    Y, X: Integer;
+  begin
+    for Y:=0 to FHeight-1 do
+      for X:=0 to FWidth-1 do
+        begin
+        if Image.Colors[x,y].alpha < $FFFF then // has alpha channel
+          Exit(True);
+        end;
+    Result:=False;
+  end;
+
+  procedure CreateSream(out MS: TMemoryStream; out Str: TStream;
+    out Compression: TPDFImageCompression);
+  begin
+    MS := TMemoryStream.Create;
+    if AUseCompression then
+      begin
+      Compression := icDeflate;
+      Str := Tcompressionstream.create(cldefault, MS);
+      end
+    else
+      begin
+      Compression := icNone;
+      Str := MS;
+      end;
+  end;
+
+  procedure StreamToBuffer(const MS: TMemoryStream; var Str: TStream; out Buffer: TBytes);
+  begin
+    if Str<>MS then
+      Str.Free;
+    Str := nil;
+    SetLength(Buffer, MS.Size);
+    MS.Position := 0;
+    if MS.Size>0 then
+      MS.ReadBuffer(Buffer[0], MS.Size);
+  end;
+
 Var
   X,Y : Integer;
   C : TFPColor;
-  MS : TMemoryStream;
-  Str : TStream;
+  MS,MSMask : TMemoryStream;
+  Str,StrMask : TStream;
   CWhite : TFPColor; // white color
+  CreateMask : Boolean;
 begin
   FillMem(@CWhite, SizeOf(CWhite), $FF);
   FWidth:=Image.Width;
   FHeight:=Image.Height;
+  CreateMask:=AUseTransparency and NeedsTransparency;
+  MS := nil;
   Str := nil;
-  MS := TMemoryStream.Create;
+  MSMask := nil;
+  StrMask := nil;
   try
-    if AUseCompression then
-      begin
-      FCompression := icDeflate;
-      Str := Tcompressionstream.create(cldefault, MS)
-      end
-    else
-      begin
-      FCompression := icNone;
-      Str := MS;
-      end;
+    CreateSream(MS, Str, FCompression);
+    if CreateMask then
+      CreateSream(MSMask, StrMask, FCompressionMask);
     for Y:=0 to FHeight-1 do
       for X:=0 to FWidth-1 do
         begin
         C:=Image.Colors[x,y];
-        if C.alpha < $FFFF then // remove alpha channel - assume white background
+        if CreateMask then
+          StrMask.WriteByte(C.Alpha shr 8)
+        else
+        if (C.alpha < $FFFF) then // remove alpha channel - assume white background
           C := AlphaBlend(CWhite, C);
 
         Str.WriteByte(C.Red shr 8);
@@ -2907,25 +2989,24 @@
         Str.WriteByte(C.Green shr 8);
         Str.WriteByte(C.Blue shr 8);
         end;
-    if Str<>MS then
-      Str.Free;
-    Str := nil;
-    SetLength(FStreamed, MS.Size);
-    MS.Position := 0;
-    if MS.Size>0 then
-      MS.ReadBuffer(FStreamed[0], MS.Size);
+    StreamToBuffer(MS, Str, FStreamed);
+    if CreateMask then
+      StreamToBuffer(MSMask, StrMask, FStreamedMask);
   finally
     Str.Free;
+    StrMask.Free;
     MS.Free;
+    MSMask.Free;
   end;
 end;
 
-function TPDFImageItem.WriteImageStream(AStream: TStream): int64;
+function TPDFImageItem.WriteStream(const AStreamedData: TBytes;
+  AStream: TStream): int64;
 var
   Img : TBytes;
 begin
   TPDFObject.WriteString(CRLF+'stream'+CRLF,AStream);
-  Img:=StreamedData;
+  Img:=AStreamedData;
   Result:=Length(Img);
   AStream.WriteBuffer(Img[0],Result);
   TPDFObject.WriteString(CRLF, AStream);
@@ -2956,6 +3037,11 @@
       end;
 end;
 
+function TPDFImageItem.GetHasMask: Boolean;
+begin
+  Result := Length(FStreamedMask)>0;
+end;
+
 { TPDFImages }
 
 function TPDFImages.GetI(AIndex : Integer): TPDFImageItem;
@@ -3092,7 +3178,7 @@
     IP.Image:=I;
     if Not KeepImage then
       begin
-      IP.CreateStreamedData(poCompressImages in Owner.Options);
+      IP.CreateStreamedData(poCompressImages in Owner.Options, poUseImageTransparency in Owner.Options);
       IP.FImage:=Nil; // not through property, that would clear the image
       i.Free;
       end;
@@ -4055,6 +4141,22 @@
         begin
           if (E.FKey.Name='Name') then
           begin
+            if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='M') then
+            begin
+              NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
+              // write image stream length in xobject dictionary
+              ISize:=Length(Document.Images[NumImg].StreamedMask);
+              D:=Document.GlobalXRefs[AObject].Dict;
+              D.AddInteger('Length',ISize);
+              LastElement.Write(AStream);
+              case Document.Images[NumImg].FCompressionMask of
+                icJPEG: WriteString('/Filter /DCTDecode'+CRLF, AStream);
+                icDeflate: WriteString('/Filter /FlateDecode'+CRLF, AStream);
+              end;
+              WriteString('>>', AStream);
+              // write image stream in xobject dictionary
+              Document.Images[NumImg].WriteMaskStream(AStream);
+            end else
             if (TPDFObject(E.Value) is TPDFName) and (TPDFName(E.Value).Name[1]='I') then
             begin
               NumImg:=StrToInt(Copy(TPDFName(E.Value).Name, 2, Length(TPDFName(E.Value).Name) - 1));
@@ -5087,24 +5189,25 @@
   lXRef.FStream.AddItem(TPDFCIDSet.Create(self, AFontNum));
 end;
 
-procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer);
+procedure TPDFDocument.CreateImageEntry(ImgWidth, ImgHeight, NumImg: integer;
+  out ImageDict: TPDFDictionary);
 var
   N: TPDFName;
-  IDict,ADict: TPDFDictionary;
+  ADict: TPDFDictionary;
   i: integer;
   lXRef: integer;
 begin
   lXRef := GlobalXRefCount; // reference to be used later
 
-  IDict:=CreateGlobalXRef.Dict;
-  IDict.AddName('Type','XObject');
-  IDict.AddName('Subtype','Image');
-  IDict.AddInteger('Width',ImgWidth);
-  IDict.AddInteger('Height',ImgHeight);
-  IDict.AddName('ColorSpace','DeviceRGB');
-  IDict.AddInteger('BitsPerComponent',8);
+  ImageDict:=CreateGlobalXRef.Dict;
+  ImageDict.AddName('Type','XObject');
+  ImageDict.AddName('Subtype','Image');
+  ImageDict.AddInteger('Width',ImgWidth);
+  ImageDict.AddInteger('Height',ImgHeight);
+  ImageDict.AddName('ColorSpace','DeviceRGB');
+  ImageDict.AddInteger('BitsPerComponent',8);
   N:=CreateName('I'+IntToStr(NumImg)); // Needed later
-  IDict.AddElement('Name',N);
+  ImageDict.AddElement('Name',N);
 
   // now find where we must add the image xref - we are looking for "Resources"
   for i := 1 to GlobalXRefCount-1 do
@@ -5125,6 +5228,27 @@
   end;
 end;
 
+procedure TPDFDocument.CreateImageMaskEntry(ImgWidth, ImgHeight,
+  NumImg: integer; ImageDict: TPDFDictionary);
+var
+  N: TPDFName;
+  MDict: TPDFDictionary;
+  lXRef: integer;
+begin
+  lXRef := GlobalXRefCount; // reference to be used later
+
+  MDict:=CreateGlobalXRef.Dict;
+  MDict.AddName('Type','XObject');
+  MDict.AddName('Subtype','Image');
+  MDict.AddInteger('Width',ImgWidth);
+  MDict.AddInteger('Height',ImgHeight);
+  MDict.AddName('ColorSpace','DeviceGray');
+  MDict.AddInteger('BitsPerComponent',8);
+  N:=CreateName('M'+IntToStr(NumImg)); // Needed later
+  MDict.AddElement('Name',N);
+  ImageDict.AddReference('SMask', lXRef);
+end;
+
 function TPDFDocument.CreateAnnotEntry(const APageNum, AnnotNum: integer): integer;
 var
   lDict, ADict: TPDFDictionary;
@@ -5492,9 +5616,14 @@
 procedure TPDFDocument.CreateImageEntries;
 Var
   I : Integer;
+  IDict : TPDFDictionary;
 begin
   for i:=0 to Images.Count-1 do
-    CreateImageEntry(Images[i].Width,Images[i].Height,i);
+    begin
+    CreateImageEntry(Images[i].Width,Images[i].Height,i,IDict);
+    if Images[i].HasMask then
+      CreateImageMaskEntry(Images[i].Width,Images[i].Height,i,IDict);
+    end;
 end;
 
 procedure TPDFDocument.CreateAnnotEntries(const APageNum: integer; const APageDict: TPDFDictionary);

Ondrej Pokorny

2019-02-21 05:25

reporter   ~0114319

02.patch: I removed FHasMask field and used a getter method instead.

Michael Van Canneyt

2019-03-02 13:31

administrator   ~0114560

Applied, tested, committed.

Very nice addition indeed !

I changed the 2 boolean options to a single set option. Maybe more options will be needed in the future.

Ondrej Pokorny

2019-03-02 15:53

reporter   ~0114571

Thank you!

Issue History

Date Modified Username Field Change
2019-02-17 22:17 Ondrej Pokorny New Issue
2019-02-17 22:17 Ondrej Pokorny File Added: fpPDF-image-transparency-01.patch
2019-02-17 22:18 Ondrej Pokorny File Added: diamond.png
2019-02-18 20:08 Michael Van Canneyt Assigned To => Michael Van Canneyt
2019-02-18 20:08 Michael Van Canneyt Status new => assigned
2019-02-21 05:24 Ondrej Pokorny File Added: fpPDF-image-transparency-02.patch
2019-02-21 05:25 Ondrej Pokorny Note Added: 0114319
2019-03-02 13:31 Michael Van Canneyt Fixed in Revision => 41552
2019-03-02 13:31 Michael Van Canneyt Note Added: 0114560
2019-03-02 13:31 Michael Van Canneyt Status assigned => resolved
2019-03-02 13:31 Michael Van Canneyt Fixed in Version => 3.3.1
2019-03-02 13:31 Michael Van Canneyt Resolution open => fixed
2019-03-02 13:31 Michael Van Canneyt Target Version => 3.2.0
2019-03-02 15:53 Ondrej Pokorny Note Added: 0114571
2019-03-02 15:53 Ondrej Pokorny Status resolved => closed