paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-14 19:39:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed alpha images on 16 bpp

Browse Source 
* fixed adding alpha to images

git-svn-id: trunk@11897 -
This commit is contained in:
marc 2007-09-01 02:46:24 +00:00
parent 8526e44d33
commit 6767396907
10 changed files with 302 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lcl/controls.pp
View File

@ -1854,10 +1854,14 @@ type
TImageList = class(TDragImageList)
published
property AllocBy;
property BlendColor;
property BkColor;
Property Height;
property DrawingStyle;
property Height;
property ImageType;
property Masked;
property Width;
property ShareImages;
property OnChange;
end;

16
lcl/graphtype.pp
View File

@ -127,7 +127,7 @@ type
procedure Init_BPP24_B8G8R8_M1_BIO_TTB(AWidth, AHeight: integer);
procedure Init_BPP32_B8G8R8_BIO_TTB(AWidth, AHeight: integer);
procedure Init_BPP32_B8G8R8_M1_BIO_TTB(AWidth, AHeight: integer);
procedure Init_BPP32_A8B8G8R8_BIO_TTB(AWidth, AHeight: integer);
procedure Init_BPP32_B8G8R8A8_BIO_TTB(AWidth, AHeight: integer);
function GetDescriptionFromMask: TRawImageDescription;
function GetDescriptionFromAlpha: TRawImageDescription;
@ -623,7 +623,7 @@ begin
Width := AWidth;
Height := AHeight;
BitOrder := riboBitsInOrder;
ByteOrder := DefaultByteOrder;
ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom;
BitsPerPixel := 24; // bits per pixel. can be greater than Depth.
LineEnd := rileDWordBoundary;
@ -656,7 +656,7 @@ begin
Width := AWidth;
Height := AHeight;
BitOrder := riboBitsInOrder;
ByteOrder := DefaultByteOrder;
ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom;
BitsPerPixel := 24; // bits per pixel. can be greater than Depth.
LineEnd := rileDWordBoundary;
@ -693,7 +693,7 @@ begin
Width := AWidth;
Height := AHeight;
BitOrder := riboBitsInOrder;
ByteOrder := DefaultByteOrder;
ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom;
BitsPerPixel := 32; // bits per pixel. can be greater than Depth.
LineEnd := rileDWordBoundary;
@ -727,7 +727,7 @@ begin
Width := AWidth;
Height := AHeight;
BitOrder := riboBitsInOrder;
ByteOrder := DefaultByteOrder;
ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom;
BitsPerPixel := 32; // bits per pixel. can be greater than Depth.
LineEnd := rileDWordBoundary;
@ -754,10 +754,10 @@ begin
Result := (GetBitsPerLine(Width, MaskBitsPerPixel, MaskLineEnd) + 7) shr 3;
end;
procedure TRawImageDescription.Init_BPP32_A8B8G8R8_BIO_TTB(AWidth, AHeight: integer);
procedure TRawImageDescription.Init_BPP32_B8G8R8A8_BIO_TTB(AWidth, AHeight: integer);
{ pf32bit:
Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
BitOrder=riboBitsInOrder ByteOrder=DefaultByteOrder
LineOrder=riloTopToBottom
BitsPerPixel=32 LineEnd=rileDWordBoundary
@ -774,7 +774,7 @@ begin
Width := AWidth;
Height := AHeight;
BitOrder := riboBitsInOrder;
ByteOrder := DefaultByteOrder;
ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom;
BitsPerPixel := 32; // bits per pixel. can be greater than Depth.
LineEnd := rileDWordBoundary;

4
lcl/imglist.pp
View File

@ -145,7 +145,7 @@ type
{$ifndef IMGLIST_OLDSTYLE}
procedure InternalMove(ACurIndex, ANewIndex: Cardinal; AIgnoreCurrent: Boolean);
function InternalSetImage(AIndex: Integer; AImage: TRawImage; AFreeImage: Boolean): PRGBAQuad;
function InternalSetImage(AIndex: Integer; AImage: TRawImage): PRGBAQuad;
{$endif}
procedure NotifyChangeLink;
@ -177,7 +177,7 @@ type
procedure BeginUpdate;
procedure EndUpdate;
function Add(Image, Mask: TBitmap): Integer; // using AddCopy for Delphi compatibility
function Add(Image, Mask: TBitmap): Integer;
{$ifdef IMGLIST_OLDSTYLE}
function AddDirect(Image, Mask: TBitmap): Integer;
function AddCopy(SrcImage, SrcMask: TBitmap): Integer;

1
lcl/include/bitmap.inc
View File

@ -843,6 +843,7 @@ begin
// read image
IntfImg := TLazIntfImage.Create(0,0);
{$note set pixelformat based on image, not device}
// add an extention to the reader, so that we h get called after the header is read
// the next will cause that all images are loaded in pfDevice format.
// This is incompatible with delphi
IntfImg.DataDescription := GetDescriptionFromDevice(0, 0, 0);

66
lcl/include/imglist.inc
View File

@ -552,8 +552,8 @@ begin
ACanvas.Draw(AX,AY,aBitmap);
{$else}
HandleNeeded;
TWSCustomImageListClass(WidgetSetClass).Draw(Self, AIndex, ACanvas,
Rect(AX, AY, FWidth, FHeight), AEnabled, DrawingStyle);
TWSCustomImageListClass(WidgetSetClass).Draw(Self, AIndex, ACanvas, Rect(AX, AY, FWidth, FHeight),
BkColor, BlendColor, AEnabled, DrawingStyle, ImageType);
{$endif}
end;
@ -828,7 +828,7 @@ begin
else msk := AMask.Handle;
R := Rect(0, 0, FWidth, FHeight);
RawImage_FromBitmap(RawImg, AImage.Handle, msk, R);
ImgData := InternalSetImage(AIndex, RawImg, True);
ImgData := InternalSetImage(AIndex, RawImg);
if HandleAllocated
then TWSCustomImageListClass(WidgetSetClass).Insert(Self, AIndex, ImgData);
@ -930,28 +930,76 @@ end;
Method: TCustomImageList.InternalSetImage
Params: AIndex: the index of the location where the image should be set
AImage: the new image
AFreeImage: if set, the rawimagedata is freed
Returns: Pointer to the updated image data
Copies the imagedata into the FData array
Copies the imagedata into the FData array and then frees the image.
------------------------------------------------------------------------------}
{$ifndef IMGLIST_OLDSTYLE}
function TCustomImageList.InternalSetImage(AIndex: Integer; AImage: TRawImage; AFreeImage: Boolean): PRGBAQuad;
function TCustomImageList.InternalSetImage(AIndex: Integer; AImage: TRawImage): PRGBAQuad;
var
Desc: TRawImageDescription absolute AImage.Description;
RawImg: TRawImage;
SrcImg, DstImg: TLazIntfImage;
SrcHasAlpha, KeepAlpha: Boolean;
begin
SrcImg := TLazIntfImage.Create(AImage, AFreeImage);
SrcImg.AlphaFromMask;
SrcHasAlpha := AImage.Description.AlphaPrec > 0;
KeepAlpha := SrcHasAlpha;
if not SrcHasAlpha and (Desc.BitsPerPixel = 32) and (Desc.Depth = 24)
then begin
// Try to squeeze Aplha channel in some unused bits
if (Desc.RedShift >= 8)
and (Desc.GreenShift >= 8)
and (Desc.BlueShift >= 8)
then begin
// there is room at the lsb side
Desc.AlphaPrec := 8;
Desc.AlphaShift := 0;
Desc.Depth := 32;
SrcHasAlpha := True;
end
else if (Desc.RedShift < 24)
and (Desc.GreenShift < 24)
and (Desc.BlueShift < 24)
then begin
// there is room at the msb side
Desc.AlphaPrec := 8;
Desc.AlphaShift := 24;
Desc.Depth := 32;
SrcHasAlpha := True;
end;
end;
SrcImg := TLazIntfImage.Create(AImage, True);
if SrcHasAlpha
then SrcImg.AlphaFromMask(KeepAlpha);
RawImg.Init;
FillDescription(RawImg.Description);
Result := @FData[AIndex * FWidth * FHeight];
RawImg.DataSize := FWidth * FHeight * SizeOF(FData[0]);
RawImg.Data := PByte(Result);
if not SrcHasAlpha
then begin
// Add maskdata to store copied mask, so an alpha can be created
RawImg.Description.MaskBitsPerPixel := 1;
RawImg.Description.MaskBitOrder := riboReversedBits;
RawImg.Description.MaskLineEnd := rileByteBoundary;
RawImg.Description.MaskShift := 0;
RawImg.MaskSize := RawImg.Description.MaskBytesPerLine * FHeight;
RawImg.Mask := GetMem(RawImg.MaskSize);
end;
DstImg := TLazIntfImage.Create(RawImg, False);
DstImg.CopyPixels(SrcImg);
if not SrcHasAlpha
then begin
DstImg.AlphaFromMask;
FreeMem(RawImg.Mask);
RawImg.Mask := nil;
RawImg.MaskSize := 0;
end;
DstImg.Free;
SrcImg.Free;
@ -1345,7 +1393,7 @@ begin
else msk := AMask.Handle;
R := Rect(0, 0, FWidth, FHeight);
RawImage_FromBitmap(RawImage, AImage.Handle, AMask.Handle, R);
ImgData := InternalSetImage(AIndex, RawImage, True);
ImgData := InternalSetImage(AIndex, RawImage);
if HandleAllocated
then TWSCustomImageListClass(WidgetSetClass).Replace(Self, AIndex, ImgData);
{$endif}

21
lcl/interfaces/gtk/gtklclintf.inc
View File

@ -262,6 +262,7 @@ begin
end;
Pixbuf := gdk_pixbuf_new_from_data(Data, GDK_COLORSPACE_RGB, True, 8, ImgWidth, ImgHeight, RowStride, nil, nil);
// DbgDumpPixbuf(Pixbuf, 'CreateBitmaps (32)');
gdk_pixbuf_render_pixmap_and_mask(Pixbuf, Drawable, Bitmap, $80);
gdk_pixbuf_unref(Pixbuf);
if Data <> ImgData
@ -404,13 +405,29 @@ end;
------------------------------------------------------------------------------}
function TGtkWidgetSet.RawImage_DescriptionFromDevice(ADC: HDC; out ADesc: TRawImageDescription): boolean;
var
DevCon: TDeviceContext absolute ADC;
Drawable: PGdkDrawable;
UseAlpha: Boolean;
begin
UseAlpha := False;
if IsValidDC(ADC)
then Drawable := TDeviceContext(ADC).Drawable
then begin
Drawable := DevCon.Drawable;
if DevCon.CurrentBitmap <> nil
then begin
case DevCon.CurrentBitmap^.GDIBitmapType of
gbBitmap: Drawable := DevCon.CurrentBitmap^.GDIBitmapObject;
gbPixmap: begin
Drawable := DevCon.CurrentBitmap^.GDIPixmapObject.Image;
UseAlpha := DevCon.CurrentBitmap^.GDIPixmapObject.Mask <> nil;
end;
end;
end;
end
else Drawable := nil;
Result := RawImage_DescriptionFromDrawable(ADesc, Drawable, True);
Result := RawImage_DescriptionFromDrawable(ADesc, Drawable, UseAlpha);
end;
{------------------------------------------------------------------------------

183
lcl/interfaces/gtk/gtkobject.inc
View File

@ -2110,8 +2110,6 @@ var
Width, Height, Depth: integer;
IsBitmap: Boolean;
begin
Result := False;
Visual := nil;
Width := 0;
Height := 0;
@ -2138,10 +2136,38 @@ begin
if (Visual = nil) and not IsBitmap // bitmaps don't have a visual
then begin
DebugLn('TGtkWidgetSet.RawImage_DescriptionFromDrawable: visual failed');
Exit;
Exit(False);
end;
ADesc.Init;
ADesc.Width := cardinal(Width);
ADesc.Height := cardinal(Height);
ADesc.BitOrder := riboBitsInOrder;
if ACustomAlpha
then begin
// always give pixbuf description for alpha images
ADesc.Depth := 32;
ADesc.BitsPerPixel := 32;
ADesc.LineEnd := rileDWordBoundary;
ADesc.ByteOrder := riboLSBFirst;
ADesc.RedPrec := 8;
ADesc.RedShift := 0;
ADesc.GreenPrec := 8;
ADesc.GreenShift := 8;
ADesc.BluePrec := 8;
ADesc.BlueShift := 16;
ADesc.AlphaPrec := 8;
ADesc.AlphaShift := 24;
ADesc.MaskBitsPerPixel := 1;
ADesc.MaskShift := 0;
ADesc.MaskLineEnd := rileByteBoundary;
ADesc.MaskBitOrder := riboBitsInOrder;
Exit(True);
end;
// Format
if IsBitmap
@ -2159,7 +2185,7 @@ begin
else
DebugLn('TGtkWidgetSet.GetWindowRawImageDescription unknown Visual type ',
dbgs(Integer(Visual^.thetype)));
Exit;
Exit(False);
end;
end;
@ -2178,10 +2204,6 @@ begin
then ADesc.Depth := 1
else ADesc.Depth := Visual^.Depth;
ADesc.Width := cardinal(Width);
ADesc.Height := cardinal(Height);
ADesc.BitOrder := riboBitsInOrder;
if IsBitmap or (Visual^.byte_order = GDK_MSB_FIRST)
then ADesc.ByteOrder := riboMSBFirst
else ADesc.ByteOrder := riboLSBFirst;
@ -2208,7 +2230,7 @@ begin
if Image = nil
then begin
DebugLn('TGtkWidgetSet.GetWindowRawImageDescription testimage creation failed ');
Exit;
Exit(False);
end;
try
// the minimum alignment we can detect is bpp
@ -2220,7 +2242,7 @@ begin
8: ADesc.LineEnd := rileQWordBoundary;
else
DebugLn('TGtkWidgetSet.GetWindowRawImageDescription Unknown line end: %d', [Image^.bpl]);
Exit;
Exit(False);
end;
finally
gdk_image_destroy(Image);
@ -2238,10 +2260,11 @@ begin
ADesc.MaskShift := 0;
ADesc.MaskLineEnd := rileByteBoundary;
ADesc.MaskBitOrder := riboBitsInOrder;
(*
if ACustomAlpha and (ADesc.Format = ricfRGBA) and (ADesc.Depth = 24)
then begin
// return the desciption for a pixbuf
// add alpha channel
ADesc.Depth := 32;
@ -2263,6 +2286,7 @@ begin
ADesc.AlphaShift := 24;
end;
end;
*)
end;
{$IFDEF VerboseRawImage}
@ -2275,8 +2299,83 @@ end;
function TGtkWidgetSet.RawImage_FromDrawable(out ARawImage: TRawImage; ADrawable, AAlpha: PGdkDrawable; const ARect: TRect): boolean;
var
ADesc: TRawImageDescription absolute ARawImage.Description;
function GetFromPixbuf(const ARect: TRect): Boolean;
var
Pixbuf: PGdkPixbuf;
pixels: pguchar;
begin
// create pixbuf with alpha channel first
Pixbuf := gdk_pixbuf_new(GDK_COLORSPACE_RGB, True, 8, ADesc.Width, ADesc.Height);
try
Pixbuf := gdk_pixbuf_get_from_drawable(Pixbuf, ADrawable, gdk_colormap_get_system, ARect.Left, ARect.Top, 0, 0, ADesc.Width, ADesc.Height);
pixels := gdk_pixbuf_get_pixels(Pixbuf);
ARawImage.DataSize := gdk_pixbuf_get_rowstride(Pixbuf) * ADesc.Height;
ReAllocMem(ARawImage.Data, ARawImage.DataSize);
if ARawImage.DataSize > 0 then
System.Move(pixels^, ARawImage.Data^, ARawImage.DataSize);
//DbgDumpPixmap(ADrawable, 'RawImage_FromDrawable - image');
//DbgDumpBitmap(AAlpha, 'RawImage_FromDrawable - alpha');
//DbgDumpPixbuf(Pixbuf, 'RawImage_FromDrawable - pixbuf');
finally
gdk_pixbuf_unref(Pixbuf);
end;
Result := RawImage_SetAlpha(ARawImage, AAlpha, ARect);;
end;
function GetFromImage(const ARect: TRect): Boolean;
var
Image: PGdkImage;
begin
Image := gdk_image_get(ADrawable, ARect.Left, ARect.Top, ADesc.Width, ADesc.Height);
if Image = nil
then begin
DebugLn('WARNING: TGtkWidgetSet.RawImage_FromDrawable: gdk_image_get failed');
exit(False);
end;
try
{$ifdef RawimageConsistencyCheks}
// consistency checks
if Description.Depth <> Image^.Depth then
RaiseGDBException('ARawImage.Description.Depth<>Image^.Depth '+IntToStr(ADesc.Depth)+'<>'+IntToStr(Image^.Depth));
if Description.BitsPerPixel <> GetPGdkImageBitsPerPixel(Image) then
RaiseGDBException('NewRawImage.Description.BitsPerPixel<>AnImage^.bpp');
{$endif}
ARawImage.DataSize := PtrUInt(Image^.bpl) * Image^.Height;
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.RawImage_FromDrawable: G Width=',dbgs(Image^.Width),' Height=',dbgs(Image^.Height),
' BitsPerPixel=',dbgs(ADesc.BitsPerPixel),' bpl=',dbgs(Image^.bpl));
{$ENDIF}
// copy data
ADesc.Width := Image^.Width;
ADesc.Height := Image^.Height;
ReAllocMem(ARawImage.Data, ARawImage.DataSize);
if ARawImage.DataSize > 0 then
System.Move(Image^.Mem^, ARawImage.Data^, ARawImage.DataSize);
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.RawImage_FromDrawable: H ',
' Width=',dbgs(ADesc.Width),
' Height=',dbgs(ADesc.Height),
' Depth=',dbgs(ADesc.Depth),
' DataSize=',dbgs(ARawImage.DataSize));
{$ENDIF}
finally
gdk_image_destroy(Image);
end;
Result := True;
end;
var
R: TRect;
Image: PGdkImage;
UseAlpha: Boolean;
begin
Result := False;
if ADrawable = nil then
@ -2284,11 +2383,10 @@ begin
ARawImage.Init;
UseAlpha := AAlpha <> nil;
// get raw image description
{$IFDEF VerboseRawImage}
//DebugLn('TGtkWidgetSet.RawImage_FromDrawable: Get Desc GdkWindow=',DbgS(GdkWindow));
{$ENDIF}
if not RawImage_DescriptionFromDrawable(ADesc, ADrawable, AAlpha <> nil)
if not RawImage_DescriptionFromDrawable(ADesc, ADrawable, UseAlpha)
then begin
DebugLn('WARNING: TGtkWidgetSet.RawImage_FromDrawable: RawImage_DescriptionFromDrawable failed ');
Exit;
@ -2316,50 +2414,11 @@ begin
//DebugLn('WARNING: TGtkWidgetSet.GetRawImageFromGdkWindow Intersection empty');
exit;
end;
Image := gdk_image_get(ADrawable, R.Left, R.Top, ADesc.Width, ADesc.Height);
if Image = nil
then begin
DebugLn('WARNING: TGtkWidgetSet.RawImage_FromDrawable: gdk_image_get failed');
exit;
end;
try
{$ifdef RawimageConsistencyCheks}
// consistency checks
if Description.Depth <> Image^.Depth then
RaiseGDBException('ARawImage.Description.Depth<>Image^.Depth '+IntToStr(ADesc.Depth)+'<>'+IntToStr(Image^.Depth));
if Description.BitsPerPixel <> GetPGdkImageBitsPerPixel(Image) then
RaiseGDBException('NewRawImage.Description.BitsPerPixel<>AnImage^.bpp');
{$endif}
ARawImage.DataSize := PtrUInt(Image^.bpl) * Image^.Height;
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.RawImage_FromDrawable: G Width=',dbgs(Image^.Width),' Height=',dbgs(Image^.Height),
' BitsPerPixel=',dbgs(ADesc.BitsPerPixel),' bpl=',dbgs(Image^.bpl));
{$ENDIF}
// copy data
ADesc.Width := Image^.Width;
ADesc.Height := Image^.Height;
ReAllocMem(ARawImage.Data, ARawImage.DataSize);
if ARawImage.DataSize > 0 then
System.Move(Image^.Mem^, ARawImage.Data^, ARawImage.DataSize);
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.RawImage_FromDrawable: H ',
' Width=',dbgs(ADesc.Width),
' Height=',dbgs(ADesc.Height),
' Depth=',dbgs(ADesc.Depth),
' DataSize=',dbgs(ARawImage.DataSize));
{$ENDIF}
finally
gdk_image_destroy(Image);
end;
Result := true;
if AAlpha <> nil
then Result := RawImage_SetAlpha(ARawImage, AAlpha, R);
if UseAlpha
then Result := GetFromPixbuf(R)
else Result := GetFromImage(R);
end;
function TGTKWidgetSet.RawImage_SetAlpha(var ARawImage: TRawImage; AAlpha: PGdkPixmap; const ARect: TRect): boolean;
@ -2381,7 +2440,7 @@ var
SrcLinePtr := AImage^.mem;
SrcBytesPerLine := AImage^.bpl;
DstLinePtr := ARawImage.Data;
DstBytesPerLine := GetBytesPerLine(AWidth, ADesc.BitsPerPixel, ADesc.LineEnd);
DstBytesPerLine := ARawImage.Description.BytesPerLine;
DstMask := not (((1 shl ADesc.AlphaPrec) - 1) shl ADesc.AlphaShift);
DstSet := not DstMask;
@ -2422,7 +2481,7 @@ var
SrcLinePtr := AImage^.mem;
SrcBytesPerLine := AImage^.bpl;
DstLinePtr := ARawImage.Data;
DstBytesPerLine := GetBytesPerLine(AWidth, ADesc.BitsPerPixel, ADesc.LineEnd);
DstBytesPerLine := ARawImage.Description.BytesPerLine;
DstMask := not (((1 shl ADesc.AlphaPrec) - 1) shl ADesc.AlphaShift);
DstShift := ADesc.AlphaShift;

29
lcl/interfaces/win32/win32wsimglist.pp
View File

@ -55,7 +55,7 @@ type
class procedure Delete(AList: TCustomImageList; AIndex: Integer); override;
class procedure DestroyHandle(AComponent: TComponent); override;
class procedure Draw(AList: TCustomImageList; AIndex: Integer; ACanvas: TCanvas;
ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle); override;
ABounds: TRect; ABkColor, ABlendColor: TColor; AEnabled: Boolean; AStyle: TDrawingStyle; AImageType: TImageType); override;
class procedure Insert(AList: TCustomImageList; AIndex: Integer; AData: PRGBAQuad); override;
class procedure Move(AList: TCustomImageList; ACurIndex, ANewIndex: Integer); override;
class procedure Replace(AList: TCustomImageList; AIndex: Integer; AData: PRGBAQuad); override;
@ -68,13 +68,28 @@ uses
intfgraphics;
const
DrawingStyleMap: array[TDrawingStyle] of DWord =
(
DRAWINGSTYLEMAP: array[TDrawingStyle] of DWord = (
{ dsFocus } ILD_FOCUS,
{ dsSelected } ILD_SELECTED,
{ dsNormal } ILD_NORMAL,
{ dsTransparent } ILD_TRANSPARENT
);
IMAGETPYEMAP: array[TImageType] of DWord = (
{ itImage } 0,
{ itMask } ILD_MASK
);
function ColorToImagelistColor(AColor: TColor): DWord;
begin
case AColor of
clNone: Result := CLR_NONE;
clDefault: Result := CLR_DEFAULT;
else
Result := ColorToRGB(AColor);
end;
end;
class procedure TWin32WSCustomImageList.InternalCreateBitmapHandles(AList: TCustomImageList; AWidth, AHeight: Integer; AData: PRGBAQuad; var hbmImage, hbmMask: HBitmap);
var
@ -152,7 +167,7 @@ begin
InternalCreateBitmapHandles(AList, AWidth, AHeight, @AData[AWidth * AHeight * i],
hbmImage, hbmMask);
ImageList_Add(Result, hbmImage, hbmMask);
InternalDestroyBitmapHandles(hbmMask, hbmImage);
InternalDestroyBitmapHandles(hbmImage, hbmMask);
end;
end;
end;
@ -173,14 +188,14 @@ begin
end;
class procedure TWin32WSCustomImageList.Draw(AList: TCustomImageList; AIndex: Integer;
ACanvas: TCanvas; ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle);
ACanvas: TCanvas; ABounds: TRect; ABkColor, ABlendColor: TColor; AEnabled: Boolean; AStyle: TDrawingStyle; AImageType: TImageType);
begin
if not WSCheckHandleAllocated(AList, 'Draw')
then Exit;
ImageList_DrawEx(HImageList(AList.Handle), AIndex, ACanvas.Handle, ABounds.Left,
ABounds.Top, ABounds.Right, ABounds.Bottom, CLR_NONE, CLR_NONE,
DrawingStyleMap[AStyle]);
ABounds.Top, ABounds.Right, ABounds.Bottom, ColorToImagelistColor(ABkColor),
ColorToImagelistColor(ABlendColor), DRAWINGSTYLEMAP[AStyle] or IMAGETPYEMAP[AImageType]);
end;
class procedure TWin32WSCustomImageList.Insert(AList: TCustomImageList;

85
lcl/intfgraphics.pas
View File

@ -493,6 +493,8 @@ type
// extra Rawimage utility functions
function GetDescriptionFromDevice(ADC: HDC; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
function GetDescriptionFromBitmap(ABitmap: HBitmap; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
function AddAlphaToDescription(var ADesc: TRawImageDescription; APrec: Byte): Boolean;
function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
@ -604,6 +606,41 @@ begin
if AHeight <> -1 then Result.Height := AHeight;
end;
function AddAlphaToDescription(var ADesc: TRawImageDescription; APrec: Byte): Boolean;
function CreateBitMask(AShift, APrec: Byte): Cardinal; inline;
begin
Result := ($FFFFFFFF shr (32 - APrec)) shl AShift;
end;
var
Mask: Cardinal;
begin
if ADesc.AlphaPrec >= APrec then Exit(False);
if ADesc.BitsPerPixel <> 32 then Exit(False);
if ADesc.Depth <> 24 then Exit(False);
Mask := CreateBitMask(ADesc.RedShift, ADesc.RedPrec)
or CreateBitMask(ADesc.GreenShift, ADesc.GreenPrec)
or CreateBitMask(ADesc.BlueShift, ADesc.BluePrec);
if (Mask and $FF = 0)
then begin
ADesc.AlphaShift := 0;
Result := True;
end
else
if (Mask and $FF000000 = 0)
then begin
ADesc.AlphaShift := 24;
Result := True;
end;
if Result
then begin
ADesc.AlphaPrec := APrec;
ADesc.Depth := 32;
end;
end;
procedure ReadRawImageBits_1_2_4_BIO(TheData: PByte;
const Position: TRawImagePosition;
Prec, Shift: cardinal;
@ -3088,6 +3125,7 @@ var
Src: String;
SrcLen: Integer;
CurLineNumber, LastLineStart: integer;
HasAlpha: Boolean;
procedure RaiseXPMReadError(const Msg: string; ReadPos: integer);
var
@ -3366,7 +3404,8 @@ var
until not (IsHexNumberChar[Src[ReadPos]]);
ColorEnd:=ReadPos;
NewColor:=HexToColor(ColorStart,ColorEnd);
end else begin
end
else begin
// read as text
repeat
inc(ReadPos);
@ -3375,6 +3414,8 @@ var
NewColor:=TextToColor(ColorStart,ColorEnd);
end;
AddColor(PixelStart,NewColor,IntArray);
HasAlpha := HasAlpha or (NewColor.alpha <> alphaOpaque);
end;
end;
@ -3448,6 +3489,21 @@ var
end;
end;
end;
procedure CheckAlphaDescription;
var
Desc: TRawImageDescription;
begin
if not (TheImage is TLazIntfImage) then Exit;
Desc := TLazIntfImage(TheImage).DataDescription;
if Desc.AlphaPrec >= 8 then Exit;
if not AddAlphaToDescription(Desc, 8)
then Desc.Init_BPP32_B8G8R8A8_BIO_TTB(Desc.Width, Desc.Height);
TLazIntfImage(TheImage).DataDescription := Desc;
end;
var
IntArray: PInteger;
@ -3461,7 +3517,10 @@ begin
ReadHeader;
GetMem(IntArray,SizeOf(Integer)*(FCharsPerPixel+1));
try
HasAlpha := False;
ReadPalette(IntArray);
if HasAlpha
then CheckAlphaDescription;
//FPixelToColorTree.ConsistencyCheck;
ReadPixels(IntArray);
finally
@ -4715,7 +4774,7 @@ var
begin
InternalReadHead;
{$note check if height is also doubled wiohout mask}
{$note check if height is also doubled without mask}
FBFI.biHeight := FBFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
InternalReadBody; { Now read standard bitmap }
@ -4891,32 +4950,16 @@ begin
end;
procedure TLazReaderPNG.SetAlphaDescription;
function CreateBitMask(AShift, APrec: Byte): Cardinal; inline;
begin
Result := ($FFFFFFFF shr (32 - APrec)) shl AShift;
end;
var
Desc: TRawImageDescription;
Mask: Cardinal;
begin
if FImage = nil then Exit;
Desc := FImage.DataDescription;
if Desc.AlphaPrec > 0 then Exit;
if Desc.BitsPerPixel <> 32 then Exit;
if Desc.Depth <> 24 then Exit;
Mask := CreateBitMask(Desc.RedShift, Desc.RedPrec)
or CreateBitMask(Desc.GreenShift, Desc.GreenPrec)
or CreateBitMask(Desc.BlueShift, Desc.BluePrec);
if (Mask and $FF = 0)
then Desc.AlphaShift := 0
else if (Mask and $FF000000 = 0)
then Desc.AlphaShift := 24
else Exit;
if Desc.AlphaPrec >= 8 then Exit;
Desc.AlphaPrec := 8;
if not AddAlphaToDescription(Desc, 8)
then Desc.Init_BPP32_B8G8R8A8_BIO_TTB(Desc.Width, Desc.Height);
FImage.DataDescription := Desc;
end;

4
lcl/widgetset/wsimglist.pp
View File

@ -54,7 +54,7 @@ type
class procedure Delete(AList: TCustomImageList; AIndex: Integer); virtual;
class procedure DestroyHandle(AComponent: TComponent); override;
class procedure Draw(AList: TCustomImageList; AIndex: Integer; ACanvas: TCanvas;
ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle); virtual;
ABounds: TRect; ABkColor, ABlendColor: TColor; AEnabled: Boolean; AStyle: TDrawingStyle; AImageType: TImageType); virtual;
class procedure Insert(AList: TCustomImageList; AIndex: Integer; AData: PRGBAQuad); virtual;
@ -158,7 +158,7 @@ begin
end;
class procedure TWSCustomImageList.Draw(AList: TCustomImageList; AIndex: Integer;
ACanvas: TCanvas; ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle);
ACanvas: TCanvas; ABounds: TRect; ABkColor, ABlendColor: TColor; AEnabled: Boolean; AStyle: TDrawingStyle; AImageType: TImageType);
begin
if not WSCheckHandleAllocated(AList, 'Draw')
then Exit;