paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 13:19:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Ondrej Pokorny to add transparency

Browse Source 
git-svn-id: trunk@41551 -
This commit is contained in:
michael 2019-03-02 12:21:28 +00:00
parent 5ce75e42df
commit 805e2bb28d
4 changed files with 184 additions and 44 deletions

1
.gitattributes vendored
View File

@ -2652,6 +2652,7 @@ packages/fcl-passrc/tests/testpassrc.lpi svneol=native#text/plain
packages/fcl-passrc/tests/testpassrc.lpr svneol=native#text/plain
packages/fcl-pdf/Makefile svneol=native#text/plain
packages/fcl-pdf/Makefile.fpc svneol=native#text/plain
packages/fcl-pdf/examples/diamond.png -text svneol=unset#image/png
packages/fcl-pdf/examples/poppy.jpg -text
packages/fcl-pdf/examples/testfppdf.lpi svneol=native#text/plain
packages/fcl-pdf/examples/testfppdf.lpr svneol=native#text/plain

BIN
packages/fcl-pdf/examples/diamond.png Normal file
View File

Binary file not shown.
Side by Side

After

(image error) Size: 2.3 KiB

14
packages/fcl-pdf/examples/testfppdf.lpr
View File

@ -33,7 +33,8 @@ type
FRawJPEG,
FImageCompression,
FTextCompression,
FFontCompression: boolean;
FFontCompression,
FImageTransparency: boolean;
FNoFontEmbedding: boolean;
FAddMetadata : Boolean;
FSubsetFontEmbedding: boolean;
@ -93,6 +94,8 @@ begin
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 @@ procedure TPDFTestApp.SimpleImage(D: TPDFDocument; APage: integer);
Var
P: TPDFPage;
FtTitle: integer;
IDX: Integer;
IDX, IDX_Diamond: Integer;
W, H: Integer;
begin
P := D.Pages[APage];
@ -323,6 +326,10 @@ begin
{ 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)
@ -817,6 +824,7 @@ begin
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 @@ begin
' 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;

213
packages/fcl-pdf/src/fppdf.pp
View File

@ -69,7 +69,8 @@ type
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 @@ type
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 @@ type
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 @@ begin
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 @@ begin
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,60 +2912,101 @@ begin
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);
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 @@ begin
end;
end;
function TPDFImageItem.GetHasMask: Boolean;
begin
Result := Length(FStreamedMask)>0;
end;
{ TPDFImages }
function TPDFImages.GetI(AIndex : Integer): TPDFImageItem;
@ -3092,7 +3178,7 @@ begin
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
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 @@ begin
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 @@ begin
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 @@ end;
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);