paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-25 01:59:16 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Introduced Rasterimage.Masked property to distinguish between Alpha transparency and Masked transparency (fixes #0011850)

Browse Source 
git-svn-id: trunk@16216 -
This commit is contained in:
marc 2008-08-24 22:56:56 +00:00
parent b2b848fff2
commit ce312d71a9
7 changed files with 90 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
lcl/graphics.pp
View File

@ -44,7 +44,6 @@ uses
LCLStrConsts, LCLType, LCLProc, LMessages, LCLIntf, LResources, LCLResCache,
GraphType, IcnsTypes, GraphMath, InterfaceBase, WSReferences;
type
PColor = ^TColor;
TColor = TGraphicsColor;
@ -673,7 +672,6 @@ type
TGraphic = class(TPersistent)
private
FModified: Boolean;
FTransparent: Boolean;
FOnChange: TNotifyEvent;
FOnProgress: TProgressEvent;
FPaletteModified: Boolean;
@ -686,7 +684,7 @@ type
function GetHeight: Integer; virtual; abstract;
function GetMimeType: string; virtual;
function GetPalette: HPALETTE; virtual;
function GetTransparent: Boolean; virtual;
function GetTransparent: Boolean; virtual; abstract;
function GetWidth: Integer; virtual; abstract;
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
@ -697,7 +695,7 @@ type
procedure ReadData(Stream: TStream); virtual; // used by Filer
procedure SetHeight(Value: Integer); virtual; abstract;
procedure SetPalette(Value: HPALETTE); virtual;
procedure SetTransparent(Value: Boolean); virtual;
procedure SetTransparent(Value: Boolean); virtual; abstract;
procedure SetWidth(Value: Integer); virtual; abstract;
procedure SetModified(Value: Boolean);
procedure WriteData(Stream: TStream); virtual; // used by filer
@ -1117,6 +1115,7 @@ type
FTransparentMode: TTransparentMode;
FUpdateCount: Integer;
FUpdateCanvasOnly: Boolean;
FMasked: Boolean;
procedure CanvasChanging(Sender: TObject);
procedure CreateCanvas;
@ -1124,7 +1123,7 @@ type
procedure FreeCanvasContext;
function GetCanvas: TCanvas;
function GetRawImage: TRawImage;
function GetTransparentColor: TColor;
function GetTransparentColor: TColor;
procedure SetTransparentColor(AValue: TColor);
protected
FSharedImage: TSharedRasterImage;
@ -1135,6 +1134,7 @@ type
function GetEmpty: Boolean; override;
function GetHandle: THandle;
function GetBitmapHandle: HBITMAP; virtual; abstract;
function GetMasked: Boolean; virtual;
function GetMaskHandle: HBITMAP; virtual; abstract;
function GetMimeType: string; override;
function GetPixelFormat: TPixelFormat; virtual; abstract;
@ -1152,7 +1152,9 @@ type
function InternalReleaseMaskHandle: HBITMAP; virtual; abstract;
function InternalReleasePalette: HPALETTE; virtual; abstract;
procedure SetBitmapHandle(AValue: HBITMAP);
procedure SetMasked(AValue: Boolean); virtual;
procedure SetMaskHandle(AValue: HBITMAP);
procedure SetTransparent(AValue: Boolean); override;
procedure UnshareImage(CopyContent: boolean); virtual; abstract;
function UpdateHandles(ABitmap, AMask: HBITMAP): Boolean; virtual; abstract; // called when handles are created from rawimage (true when handle changed)
procedure SaveStreamNeeded;
@ -1167,7 +1169,7 @@ type
procedure SetPixelFormat(AValue: TPixelFormat); virtual; abstract;
procedure WriteData(Stream: TStream); override;
procedure WriteStream(AStream: TMemoryStream); virtual; abstract;
function RequestTransparentColor: TColor;
function RequestTransparentColor: TColor;
public
constructor Create; override;
destructor Destroy; override;
@ -1199,6 +1201,7 @@ type
property Canvas: TCanvas read GetCanvas;
function HandleAllocated: boolean;
property BitmapHandle: HBITMAP read GetBitmapHandle write SetBitmapHandle;
property Masked: Boolean read GetMasked write SetMasked;
property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat default pfDevice;
property RawImage: TRawImage read GetRawImage; // be carefull with this, modify only within a begin/endupdate
@ -1260,7 +1263,6 @@ type
function GetPixelFormat: TPixelFormat; override;
function GetRawImagePtr: PRawImage; override;
function GetRawImageDescriptionPtr: PRawImageDescription; override;
function GetTransparent: Boolean; override;
procedure HandleNeeded; override;
function InternalReleaseBitmapHandle: HBITMAP; override;
function InternalReleaseMaskHandle: HBITMAP; override;
@ -1464,6 +1466,7 @@ type
procedure PaletteNeeded; override;
function GetIndex(AFormat: TPixelFormat; AHeight, AWidth: Word): Integer;
function GetBitmapHandle: HBITMAP; override;
function GetMasked: Boolean; override;
function GetMaskHandle: HBITMAP; override;
function GetPalette: HPALETTE; override;
function GetPixelFormat: TPixelFormat; override;
@ -1477,6 +1480,7 @@ type
function InternalReleasePalette: HPALETTE; override;
procedure ReadData(Stream: TStream); override;
procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override;
procedure SetMasked(AValue: Boolean); override;
procedure SetPixelFormat(AValue: TPixelFormat); override;
procedure SetTransparent(Value: Boolean); override;
procedure UnshareImage(CopyContent: boolean); override;

9
lcl/include/buttonglyph.inc
View File

@ -23,6 +23,7 @@ type
private
FOwner: TButtonGlyph;
protected
procedure SetMasked(AValue: Boolean); override;
procedure SetTransparent(AValue: Boolean); override;
public
procedure Assign(ASource: TPersistent); override;
@ -44,6 +45,14 @@ begin
inherited SetTransparent(True);
end;
procedure TGlyphBitmap.SetMasked(AValue: Boolean);
begin
if (FOwner = nil)
or (FOwner.FTransparentMode = gtmGlyph)
then inherited SetMasked(AValue)
else inherited SetMasked(FOwner.FTransparentMode = gtmTransparent);
end;
procedure TGlyphBitmap.SetTransparent(AValue: Boolean);
begin
if (FOwner = nil)

22
lcl/include/custombitmap.inc
View File

@ -107,10 +107,9 @@ end;
procedure TCustomBitmap.MaskHandleNeeded;
begin
if FMaskHandle <> 0 then exit;
// not now, breaks alpha images, since they report themselves as transparent
// while no mask is needed
// CreateMask;
if FMaskHandle <> 0 then Exit;
if Masked
then CreateMask;
end;
function TCustomBitmap.PaletteAllocated: boolean;
@ -229,7 +228,7 @@ procedure TCustomBitmap.SetMonochrome(AValue: Boolean);
begin
if Monochrome = AValue then exit;
if not AValue then Exit;
if AValue
then PixelFormat := pf1bit
else PixelFormat := pfDevice;
@ -301,19 +300,6 @@ begin
FPixelFormat := TSharedCustomBitmap(FSharedImage).GetPixelFormat;
end;
function TCustomBitmap.GetTransparent: Boolean;
begin
{$IFDEF VerboseLCLTodos}{$note add better check for transparency }{$ENDIF}
// MWE: now tharansparency is set when a maskhandle is assigned, the user can
// override this by setting it to false, so no mask is used,
// however this meganism ignores the possible alpha channel, so for now 32bit
// bitmaps are considered transparent
// todos:
// check for device transparency
// check for transparency through palette etc.
Result := (FPixelFormat = pf32bit) or inherited GetTransparent;
end;
function TCustomBitmap.GetMonochrome: Boolean;
begin
RawImageNeeded(False);

13
lcl/include/graphic.inc
View File

@ -261,11 +261,6 @@ begin
SaveToStream(Stream);
end;
function TGraphic.GetTransparent: Boolean;
begin
Result := FTransparent;
end;
function TGraphic.LazarusResourceTypeValid(const AResourceType: string): boolean;
begin
Result := False;
@ -279,12 +274,4 @@ begin
FModified := False;
end;
procedure TGraphic.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then begin
FTransparent := Value;
Changed(Self);
end;
end;
// included by graphics.pp

11
lcl/include/icon.inc
View File

@ -429,6 +429,12 @@ begin
Result := TSharedIcon(FSharedImage).GetIndex(AFormat, AHeight, AWidth);
end;
function TCustomIcon.GetMasked: Boolean;
begin
// per definition an icon is maked, but maybe we should make it settable for alpha images
Result := True;
end;
function TCustomIcon.GetMaskHandle: HBITMAP;
begin
if FCurrent = -1
@ -738,6 +744,11 @@ begin
{$IFDEF VerboseLCLTodos}{$note Implement me (or raise exception)}{$ENDIF}
end;
procedure TCustomIcon.SetMasked(AValue: Boolean);
begin
// nothing
end;
function TCustomIcon.GetBestApplicationIndex: Integer;
var
BestCX, BestCY, BestDepth, i, dx, dy, dd: Integer;

68
lcl/include/rasterimage.inc
View File

@ -60,9 +60,9 @@ begin
else UpdateHandles(0, 0);
end;
FTransparent := SrcImage.FTransparent;
FTransparentMode := SrcImage.FTransparentMode;
FTransparentColor := SrcImage.FTransparentColor;
FMasked := SrcImage.FMasked;
// -> check if already shared
if SrcImage.FSharedImage <> FSharedImage
@ -258,7 +258,7 @@ begin
BitmapHandleNeeded;
if not BitmapHandleAllocated then Exit;
if Transparent then
if Masked then
UseMaskHandle:=MaskHandle
else
UseMaskHandle:=0;
@ -501,16 +501,21 @@ begin
end;
function TRasterImage.GetTransparent: Boolean;
var
Desc: PRawImageDescription;
begin
{$IFDEF VerboseLCLTodos}{$note add better check for transparency}{$ENDIF}
// MWE: now tharansparency is set when a maskhandle is assigned, the user can
// override this by setting it to false, so no mask is used,
// however this meganism ignores the possible alpha channel, so for now 32bit
// bitmaps are considered transparent
// todos:
// check for device transparency
// check for transparency through palette etc.
Result := FTransparent;
if Masked
then begin
// postpone description generation since we know we are transparent here
Result := True
end
else begin
Desc := GetRawImageDescriptionPtr;
Result := (Desc <> nil)
and (Desc^.Format <> ricfNone)
and (Desc^.AlphaPrec > 0);
//TODO: check for transparency through palette etc.
end;
end;
function TRasterImage.GetWidth: Integer;
@ -625,6 +630,32 @@ begin
else SetHandles(0, AValue);
end;
procedure TRasterImage.SetMasked(AValue: Boolean);
begin
if AValue = Masked then Exit;
FMasked := AValue;
Changed(Self);
end;
procedure TRasterImage.SetTransparentMode(AValue: TTransparentMode);
begin
if AValue = TransparentMode then exit;
FTransparentMode := AValue;
if AValue = tmAuto
then TransparentColor := clDefault
else TransparentColor := RequestTransparentColor;
end;
procedure TRasterImage.SetTransparent(AValue: Boolean);
begin
if AValue = Transparent then Exit;
// some delphi compatibility, we can only change transparency through the mask.
Masked := AValue;
end;
// release handles without freeing them
// useful for creating a HBitmap
function TRasterImage.ReleaseBitmapHandle: HBITMAP;
@ -756,6 +787,11 @@ begin
else Result := Desc^.Height;
end;
function TRasterImage.GetMasked: Boolean;
begin
Result := FMasked;
end;
class function TRasterImage.GetSharedImageClass: TSharedRasterImageClass;
begin
Result := TSharedRasterImage;
@ -879,15 +915,5 @@ begin
SetSize(Width, AHeight);
end;
procedure TRasterImage.SetTransparentMode(AValue: TTransparentMode);
begin
if AValue = TransparentMode then exit;
FTransparentMode := AValue;
if AValue = tmAuto
then TransparentColor := clDefault
else TransparentColor := RequestTransparentColor;
end;
// included by graphics.pp

11
lcl/interfaces/gtk/gtkproc.inc
View File

@ -5805,6 +5805,7 @@ var
AImageList: TCustomImageList;
FreeImageList: Boolean;
AImageIndex: Integer;
ItemBmp: TBitmap;
begin
if (MenuItem=nil) then
exit;
@ -5845,9 +5846,13 @@ begin
if AImageList = nil then
begin
AImageList := TImageList.Create(nil);
AImageList.Width := LCLMenuItem.Bitmap.Width; // maybe height to prevent too wide bitmaps?
AImageList.Height := LCLMenuItem.Bitmap.Height;
AImageIndex := AImageList.Add(LCLMenuItem.Bitmap, nil);
// prevent multiple calls to GetBitmap;
ItemBmp := LCLMenuItem.Bitmap;
AImageList.Width := ItemBmp.Width; // maybe height to prevent too wide bitmaps?
AImageList.Height := ItemBmp.Height;
if ItemBmp.Masked
then AImageIndex := AImageList.AddMasked(ItemBmp, ItemBmp.TransparentColor)
else AImageIndex := AImageList.Add(ItemBmp, nil);
FreeImageList := True;
end
else