paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-07 17:20:55 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Removed DibSection from SharedCustomBitmap, its functionality is replaces by the RawImage

Browse Source 
* Fixed setting size of CustomBitmap (#09512)

git-svn-id: trunk@15510 -
This commit is contained in:
marc 2008-06-22 18:15:29 +00:00
parent 7b5d91c581
commit a99efdd11b
5 changed files with 91 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
lcl/graphics.pp
View File

@ -699,6 +699,7 @@ type
procedure SetModified(Value: Boolean);
procedure WriteData(Stream: TStream); virtual; // used by filer
public
procedure Assign(ASource: TPersistent); override;
constructor Create; virtual;
procedure Clear; virtual;
function LazarusResourceTypeValid(const AResourceType: string): boolean; virtual;
@ -1126,6 +1127,7 @@ type
function CanShareImage(AClass: TSharedRasterImageClass): Boolean; virtual;
procedure Changed(Sender: TObject); override;
procedure Changing(Sender: TObject); virtual;
function CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP; virtual; abstract;
procedure Draw(DestCanvas: TCanvas; const DestRect: TRect); override;
function GetEmpty: Boolean; override;
function GetHandle: THandle;
@ -1214,14 +1216,10 @@ type
procedure FreeHandle; override;
procedure FreePalette;
procedure FreeImage;
function ReleaseHandle: THandle; override;
function ReleasePalette: HPALETTE;
function GetPixelFormat: TPixelFormat;
procedure UpdateDIB;
public
FDIB: TDIBSection;
constructor Create; override;
procedure CreateDefaultHandle(AWidth, AHeight: Integer; ABPP: Byte); override;
destructor Destroy; override;
function HandleAllocated: boolean; override;
function ImageAllocated: boolean;
@ -1238,6 +1236,7 @@ type
FMaskHandle: HBITMAP; // mask is not part of the image, so not shared
function GetHandleType: TBitmapHandleType;
function GetMonochrome: Boolean;
procedure SetBitmapHandle(const AValue: HBITMAP);
procedure SetHandleType(AValue: TBitmapHandleType);
procedure SetMonochrome(AValue: Boolean);
procedure UpdatePixelFormat;
@ -1246,7 +1245,7 @@ type
procedure PaletteNeeded; override;
function CanShareImage(AClass: TSharedRasterImageClass): Boolean; override;
procedure Changed(Sender: TObject); override;
procedure Changing(Sender: TObject); override;
function CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP; override;
function GetBitmapHandle: HBITMAP; override;
function GetMaskHandle: HBITMAP; override;
function GetPalette: HPALETTE; override;

84
lcl/include/custombitmap.inc
View File

@ -45,6 +45,42 @@ begin
FPixelFormat := pfDevice;
end;
function TCustomBitmap.CreateDefaultBitmapHandle(const ADesc: TRawImageDescription): HBITMAP;
var
DC: HDC;
BI: TBitmapInfo;
P: Pointer;
begin
if ADesc.Depth = 1
then begin
Result := CreateBitmap(ADesc.Width, ADesc.Height, 1, ADesc.Depth, nil);
//AType := bmDDB;
end
else begin
// on windows we need a DIB section
FillChar(BI.bmiHeader, SizeOf(BI.bmiHeader), 0);
BI.bmiHeader.biSize := SizeOf(BI.bmiHeader);
BI.bmiHeader.biWidth := ADesc.Width;
BI.bmiHeader.biHeight := -ADesc.Height; // request top down
BI.bmiHeader.biPlanes := 1;
BI.bmiHeader.biBitCount := ADesc.Depth;
BI.bmiHeader.biCompression := BI_RGB;
DC := GetDC(0);
p := nil;
Result := CreateDIBSection(DC, BI, DIB_RGB_COLORS, p, 0, 0);
//AType := bmDIB;
ReleaseDC(0, DC);
// fallback for other widgetsets not implementing CreateDIBSection
// we need the DIB section anyway someday if we want a scanline
if Result = 0
then begin
Result := CreateBitmap(ADesc.Width, ADesc.Height, 1, ADesc.Depth, nil);
//AType := bmDDB;
end;
end;
end;
procedure TCustomBitmap.HandleNeeded;
begin
BitmapHandleNeeded;
@ -84,6 +120,8 @@ begin
// description valid
if ADescOnly then Exit;
if (ImagePtr^.Data <> nil) and (ImagePtr^.DataSize > 0) then Exit;
if ImagePtr^.Description.Width = 0 then Exit; // no data
if ImagePtr^.Description.Height = 0 then Exit; // no data
end;
@ -98,7 +136,8 @@ begin
Exit;
end;
ImagePtr^.Description := GetDescriptionFromDevice(0, 0, 0);
// keep size
ImagePtr^.Description := GetDescriptionFromDevice(0, ImagePtr^.Description.Width, ImagePtr^.Description.Height);
Exit;
end;
@ -118,6 +157,12 @@ begin
Result := FSharedImage.ReleaseHandle;
end;
procedure TCustomBitmap.SetBitmapHandle(const AValue: HBITMAP);
begin
{$IFDEF VerboseLCLTodos}{$note remove when classcompletion checks intherited methods }{$ENDIF}
inherited SetBitmapHandle(AValue);
end;
function TCustomBitmap.LazarusResourceTypeValid(const ResourceType: string): boolean;
var
ResType: String;
@ -159,28 +204,33 @@ begin
if Monochrome = AValue then exit;
if not AValue then Exit;
UnshareImage(False);
TSharedCustomBitmap(FSharedImage).FDIB.dsbm.bmPlanes := 1;
TSharedCustomBitmap(FSharedImage).FDIB.dsbm.bmBitsPixel := 1;
FPixelFormat := pf1bit;
if AValue
then PixelFormat := pf1bit
else PixelFormat := pfDevice;
end;
procedure TCustomBitmap.SetPixelFormat(AValue: TPixelFormat);
begin
if AValue = FPixelFormat then Exit;
{$IFDEF VerboseLCLTodos}{$note todo copy image into new format }{$ENDIF}
FreeImage;
FPixelFormat := AValue;
end;
procedure TCustomBitmap.SetSize(AWidth, AHeight: integer);
var
SCB: TSharedCustomBitmap absolute FSharedImage;
begin
if (TSharedCustomBitmap(FSharedImage).FDIB.dsbm.bmHeight = AHeight)
and (TSharedCustomBitmap(FSharedImage).FDIB.dsbm.bmWidth = AWidth)
RawImageNeeded(True);
if (SCB.FImage.Description.Height = AHeight)
and (SCB.FImage.Description.Width = AWidth)
then Exit;
UnshareImage(False);
TSharedCustomBitmap(FSharedImage).FDIB.dsbm.bmWidth := AWidth;
TSharedCustomBitmap(FSharedImage).FDIB.dsbm.bmHeight := AHeight;
SCB.FImage.FreeData;
SCB.FImage.Description.Width := AWidth;
SCB.FImage.Description.Height := AHeight;
Changed(Self);
end;
@ -189,16 +239,6 @@ begin
FPixelFormat := TSharedCustomBitmap(FSharedImage).GetPixelFormat;
end;
procedure TCustomBitmap.Changing(Sender: TObject);
// called before the bitmap is modified
// -> make sure the handle is unshared (otherwise the modifications will also
// modify all copies)
begin
inherited;
TSharedCustomBitmap(FSharedImage).FDIB.dsbmih.biClrUsed := 0;
TSharedCustomBitmap(FSharedImage).FDIB.dsbmih.biClrImportant := 0;
end;
function TCustomBitmap.GetTransparent: Boolean;
begin
{$IFDEF VerboseLCLTodos}{$note add better check for transparency }{$ENDIF}
@ -214,8 +254,8 @@ end;
function TCustomBitmap.GetMonochrome: Boolean;
begin
with TSharedCustomBitmap(FSharedImage).FDIB.dsbm do
Result := (bmPlanes = 1) and (bmBitsPixel = 1);
RawImageNeeded(False);
Result := TSharedCustomBitmap(FSharedImage).FImage.Description.Depth = 1;
end;
procedure TCustomBitmap.UnshareImage(CopyContent: boolean);
@ -255,7 +295,6 @@ begin
FSharedImage.FreeHandle;
// get the properties from new bitmap
FSharedImage.FHandle := ABitmap;
TSharedCustomBitmap(FSharedImage).UpdateDIB;
Result := True;
end;
@ -293,7 +332,6 @@ end;
procedure TCustomBitmap.SetHandle(AValue: THandle);
begin
// for TCustomBitmap BitmapHandle = Handle
BitmapHandle := AValue;
end;

8
lcl/include/graphic.inc
View File

@ -23,7 +23,6 @@ end;
procedure TGraphic.Clear;
begin
Assign(nil);
end;
procedure TGraphic.DefineProperties(Filer: TFiler);
@ -55,6 +54,13 @@ begin
Result := nil;
end;
procedure TGraphic.Assign(ASource: TPersistent);
begin
if ASource = nil
then Clear
else inherited Assign(ASource);
end;
procedure TGraphic.Changed(Sender: TObject);
begin
FModified := True;

48
lcl/include/rasterimage.inc
View File

@ -86,12 +86,6 @@ begin
Exit;
end;
if Source = nil
then begin
Clear;
Exit;
end;
// fall back to default
inherited Assign(Source);
end;
@ -107,15 +101,10 @@ begin
end;
procedure TRasterImage.BitmapHandleNeeded;
const
BITCOUNT_MAP: array[TPixelFormat] of Byte = (
// pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom
0, 1, 4, 8, 15, 16, 24, 32, 0
);
var
BitCount: Byte;
ImgHandle, ImgMaskHandle: HBitmap;
ImagePtr: PRawImage;
DevImage: TRawImage;
DevDesc: TRawImageDescription;
SrcImage, DstImage: TLazIntfImage;
QueryFlags: TRawImageQueryFlags;
@ -142,8 +131,7 @@ begin
if DevDesc.IsEqual(ImagePtr^.Description)
then begin
// image is compatible, so use it
if not RawImage_CreateBitmaps(ImagePtr^, ImgHandle, ImgMaskHandle, DevDesc.MaskBitsPerPixel <> 0)
then raise EGraphicException.Create('Unable to create handles');
DstImage := nil;
end
else begin
// create compatible copy
@ -152,27 +140,21 @@ begin
DstImage.DataDescription := DevDesc;
DstImage.CopyPixels(SrcImage);
SrcImage.Free;
try
DstImage.CreateBitmaps(ImgHandle, ImgMaskHandle, DevDesc.MaskBitsPerPixel <> 0);
finally
DstImage.Free;
DstImage.GetRawImage(DevImage);
ImagePtr := @DevImage;
end;
try
if not RawImage_CreateBitmaps(ImagePtr^, ImgHandle, ImgMaskHandle, DevDesc.MaskBitsPerPixel <> 0)
then begin
DebugLn('TRasterImage.BitmapHandleNeeded: Unable to create handles, using default');
// create a default handle
ImgHandle := CreateDefaultBitmapHandle(DevDesc);
end;
UpdateHandles(ImgHandle, ImgMaskHandle);
finally
DstImage.Free;
end;
UpdateHandles(ImgHandle, ImgMaskHandle);
if BitmapHandleAllocated then exit;
// otherwise create a default handle
BitCount := BITCOUNT_MAP[PixelFormat];
if BitCount = 0
then begin
if PixelFormat = pfDevice
then BitCount := Min(ScreenInfo.ColorDepth, 24) // prevent creation of default alpha channel
else raise EInvalidGraphicOperation.Create(rsUnsupportedBitmapFormat);
end;
FSharedImage.CreateDefaultHandle(W, H, BitCount);
end;
function TRasterImage.CanShareImage(AClass: TSharedRasterImageClass): Boolean;

73
lcl/include/sharedcustombitmap.inc
View File

@ -21,47 +21,6 @@ begin
inherited Create;
end;
procedure TSharedCustomBitmap.CreateDefaultHandle(AWidth, AHeight: Integer; ABPP: Byte);
var
DC: HDC;
BI: PBitmapInfo;
begin
if FHandle <> 0 then raise EInvalidOperation.Create('Handle already set');
FDIB.dsBm.bmBits := nil;
if ABPP = 1
then begin
FHandle := CreateBitmap(AWidth, AHeight, 1, ABPP, nil);
FHandleType := bmDDB;
end
else begin
// on windows we need a DIB section
BI := @FDIB.dsBmih;
FillChar(BI^.bmiHeader, SizeOf(BI^.bmiHeader), 0);
BI^.bmiHeader.biSize := SizeOf(BI^.bmiHeader);
BI^.bmiHeader.biWidth := AWidth;
BI^.bmiHeader.biHeight := -AHeight; // request top down
BI^.bmiHeader.biPlanes := 1;
BI^.bmiHeader.biBitCount := ABPP;
BI^.bmiHeader.biCompression := BI_RGB;
DC := GetDC(0);
FHandle := CreateDIBSection(DC, BI^, DIB_RGB_COLORS, FDIB.dsBm.bmBits, 0, 0);
FHandleType := bmDIB;
ReleaseDC(0, DC);
// fallback for other widgetsets not implementing CreateDIBSection
// we need the DIB section anyway someday if we want a scanline
if FHandle = 0
then begin
FHandle := CreateBitmap(AWidth, AHeight, 1, ABPP, nil);
FHandleType := bmDDB;
end;
end;
FDIB.dsbm.bmWidth := AWidth;
FDIB.dsbm.bmHeight := AHeight;
end;
destructor TSharedCustomBitmap.Destroy;
begin
FreeAndNil(FSaveStream);
@ -107,46 +66,22 @@ begin
Result := FImage.Description.Format <> ricfNone;
end;
function TSharedCustomBitmap.ReleaseHandle: THandle;
begin
Result := inherited ReleaseHandle;
FDIB.dsbm.bmBits := nil;
end;
function TSharedCustomBitmap.ReleasePalette: HPALETTE;
begin
Result := FPalette;
FPalette := 0;
end;
procedure TSharedCustomBitmap.UpdateDIB;
begin
FillChar(FDIB, SizeOf(FDIB), 0);
if FHandle <> 0
then GetObject(FHandle, SizeOf(FDIB), @FDIB);
end;
function TSharedCustomBitmap.GetPixelFormat: TPixelFormat;
begin
if HandleType = bmDDB
then begin
if FDIB.dsBmih.biBitCount = 1 then Exit(pf1Bit);
Exit(pfDevice);
end;
case FDIB.dsBmih.biBitCount of
case FImage.Description.Depth of
1: Exit(pf1Bit);
4: Exit(pf4Bit);
8: Exit(pf8Bit);
16: begin
if FDIB.dsBmih.biCompression = BI_RGB then Exit(pf15Bit);
if (FDIB.dsBmih.biCompression = BI_BITFIELDS)
and (FDIB.dsBitFields[1] = $7E0) then Exit(pf16Bit);
end;
15: Exit(pf15Bit);
16: Exit(pf16Bit);
24: Exit(pf24Bit);
32: begin
if FDIB.dsBmih.biCompression = BI_RGB then Exit(pf32Bit);
end;
32: Exit(pf32Bit);
end;
Result := pfCustom;
end;