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

* Start of new Icon - bitmap cleanup

Browse Source 
git-svn-id: trunk@13624 -
This commit is contained in:
marc 2008-01-05 00:30:10 +00:00
parent 3e34d8a699
commit 39aa9c05e7
5 changed files with 130 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
lcl/graphics.pp
View File

@ -695,19 +695,23 @@ type
procedure WriteData(Stream: TStream); virtual;
public
constructor Create; virtual;
function LazarusResourceTypeValid(const AResourceType: string): boolean; virtual;
procedure LoadFromFile(const Filename: string); virtual;
procedure SaveToFile(const Filename: string); virtual;
procedure LoadFromStream(Stream: TStream); virtual; abstract;
procedure SaveToStream(Stream: TStream); virtual; abstract;
procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); virtual;
procedure LoadFromLazarusResource(const ResName: String); virtual; abstract;
procedure LoadFromLazarusResource(const ResName: String); virtual;
procedure LoadFromResourceName(Instance: THandle; const ResName: String);
procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual;
procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat); virtual;
procedure SaveToFile(const Filename: string); virtual;
procedure SaveToStream(Stream: TStream); virtual; abstract;
procedure SaveToClipboardFormat(FormatID: TClipboardFormat); virtual;
procedure SaveToClipboardFormatID(ClipboardType: TClipboardType;
FormatID: TClipboardFormat); virtual;
procedure GetSupportedSourceMimeTypes(List: TStrings); virtual;
function GetResourceType: TResourceType; virtual;
function GetDefaultMimeType: string; virtual;
class function GetFileExtensions: string; virtual;
class function GetFPReaderForFileExt(
@ -1152,6 +1156,7 @@ type
function GetHandle: HBITMAP; virtual;
function GetMaskHandle: HBITMAP; virtual;
function GetTransparent: Boolean; override;
function GetBitmapNativeType: TBitmapNativeType; virtual;
procedure HandleNeeded;
procedure MaskHandleNeeded;
procedure PaletteNeeded;
@ -1180,22 +1185,19 @@ type
function MaskHandleAllocated: boolean;
function PaletteAllocated: boolean;
procedure CreateFromBitmapHandles(ABitmap, AMask: HBitmap; const ARect: TRect);
function LazarusResourceTypeValid(const ResourceType: string): boolean; virtual;
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
procedure LoadFromDevice(DC: HDC); virtual;
procedure LoadFromStream(Stream: TStream); override;
procedure LoadFromLazarusResource(const ResName: String); override;
procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual;
procedure LoadFromResourceID(Instance: THandle; ResID: Integer); virtual;
procedure LoadFromMimeStream(Stream: TStream; const MimeType: string); override;
procedure SaveToFile(const Filename: string); override;
procedure LoadFromIntfImage(IntfImage: TLazIntfImage);
procedure LoadFromXPMFile(const Filename: String); deprecated;
procedure SaveToStream(Stream: TStream); override;
procedure GetSupportedSourceMimeTypes(List: TStrings); override;
function GetDefaultMimeType: string; override;
function GetResourceType: TResourceType; override;
class function GetFileExtensions: string; override;
procedure LoadFromXPMFile(const Filename: String);
procedure LoadFromIntfImage(IntfImage: TLazIntfImage);
procedure Mask(ATransparentColor: TColor);
procedure SetHandles(ABitmap, AMask: HBITMAP);
procedure SaveToStream(Stream: TStream); override;
procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); virtual;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); virtual;
function ReleaseHandle: HBITMAP;
@ -1236,8 +1238,9 @@ type
{ TPixmap }
TPixmap = class(TBitmap)
protected
function GetBitmapNativeType: TBitmapNativeType; override;
public
procedure SaveToFile(const Filename: string); override;
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
@ -1250,6 +1253,8 @@ type
reader and writer }
TFPImageBitmap = class(TBitmap)
protected
function GetBitmapNativeType: TBitmapNativeType; override;
public
class function GetFileExtensions: string; override;
class function IsFileExtensionSupported(const FileExtension: string): boolean;
@ -1297,10 +1302,14 @@ type
Bitmaps property
Writing is not (yet) implemented.
}
{.$define ICON_OLDSTYLE} // Set to keep original functionality
TIcon = class(TBitmap)
private
FBitmaps: TObjectList;
protected
function GetBitmapNativeType: TBitmapNativeType; override;
procedure ReadData(Stream: TStream); override;
procedure InitFPImageReader(IntfImg: TLazIntfImage; ImgReader: TFPCustomImageReader); override;
public
@ -1310,6 +1319,7 @@ type
procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon }
end;
{ TCursorImage }
TCursorImage = class(TIcon)
private
@ -1317,6 +1327,7 @@ type
FCursorHandle: HCURSOR;
FOwnHandle: Boolean;
protected
function GetBitmapNativeType: TBitmapNativeType; override;
function GetCursorHandle: HCURSOR;
procedure CursorHandleNeeded;
public
@ -1938,6 +1949,11 @@ begin
Result:=nil;
end;
function TFPImageBitmap.GetBitmapNativeType: TBitmapNativeType;
begin
Result := bnNone;
end;
class function TFPImageBitmap.GetDefaultFPReader: TFPCustomImageReaderClass;
begin
Result:=nil;
@ -2044,6 +2060,11 @@ begin
FreeAndNil(FBitmaps);
end;
function TIcon.GetBitmapNativeType: TBitmapNativeType;
begin
Result := bnIcon;
end;
procedure TIcon.AddBitmap(Bitmap: TBitmap);
begin
if not Assigned(FBitmaps) then
@ -2051,6 +2072,8 @@ begin
FBitmaps.Add(Bitmap);
end;
{ TCursorImage }
class function TCursorImage.GetFileExtensions: string;
@ -2106,6 +2129,11 @@ begin
inherited Destroy;
end;
function TCursorImage.GetBitmapNativeType: TBitmapNativeType;
begin
Result := bnCursor;
end;
// ------------------------------------------------------------------
// Decrease the component RGBs of a color of the quantity' passed
//

74
lcl/include/bitmap.inc
View File

@ -270,9 +270,8 @@ end;
function TBitmap.LazarusResourceTypeValid(const ResourceType: string): boolean;
begin
Result:=((ClassType=TBitmap) or (ClassType=TPixmap) or (ClassType=TIcon))
and ((AnsiCompareText(ResourceType,'XPM')=0)
or (AnsiCompareText(ResourceType,'BMP')=0));
Result := AnsiSameText(ResourceType,'XPM')
or AnsiSameText(ResourceType,'BMP');
end;
procedure TBitMap.Mask(ATransparentColor: TColor);
@ -442,51 +441,11 @@ begin
// CreateMask;
end;
procedure TBitmap.LoadFromLazarusResource(const ResName: String);
var
Stream: TLazarusResourceStream;
begin
Stream := nil;
try
Stream := TLazarusResourceStream.Create(ResName, nil);
if LazarusResourceTypeValid(Stream.Res.ValueType) then
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TBitMap.LoadFromStream(Stream: TStream);
begin
ReadStream(Stream, true, Stream.Size - Stream.Position);
end;
procedure TBitMap.LoadFromResourceName(Instance: THandle; const ResName: String);
var
Stream: TResourceStream;
begin
Stream := nil;
try
Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TBitMap.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
Stream: TResourceStream;
begin
Stream := nil;
try
Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TBitmap.GetSupportedSourceMimeTypes(List: TStrings);
begin
if (ClassType=TBitmap) or (ClassType=TPixmap) or (ClassType=TIcon) then
@ -609,6 +568,11 @@ begin
FImage.SaveStreamClass:=nil;
end;
function TBitmap.GetBitmapNativeType: TBitmapNativeType;
begin
Result := bnWinBitmap;
end;
procedure TBitmap.ReadStream(Stream: TStream; UseSize: boolean; Size: Longint);
procedure RaiseInvalidBitmapHeader;
@ -703,18 +667,6 @@ begin
inherited LoadFromMimeStream(Stream, MimeType);
end;
procedure TBitmap.SaveToFile(const Filename: string);
begin
if (ClassType=TBitmap) and (FImage.SaveStreamType<>bnWinBitmap) then begin
// TBitmap should always save in .bmp format
// but the current SaveStream is not in .bmp format.
// -> Clear the SaveStream.
UnshareImage(true);
FreeSaveStream;
end;
inherited SaveToFile(Filename);
end;
procedure TBitmap.SetWidthHeight(NewWidth, NewHeight: integer);
begin
if (FImage.FDIB.dsbm.bmHeight <> NewHeight)
@ -937,9 +889,10 @@ var
RawImage: TRawImage;
begin
//DebugLn(['WriteStreamWithFPImage Self=',DbgS(Self),' ',Width,',',Height,' Using SaveStream=',(FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)]);
if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)
and ((FImage.SaveStreamType<>bnNone)
or CanReadGraphicStreams(FImage.SaveStreamClass))
if (FImage.SaveStream<>nil)
and (FImage.SaveStream.Size>0)
and (FImage.SaveStreamType = GetBitmapNativeType)
and ((FImage.SaveStreamType<>bnNone) or CanReadGraphicStreams(FImage.SaveStreamClass))
then begin
// it's a stream format, that this graphic class can read
// (important for restore)
@ -1266,6 +1219,11 @@ begin
Result := FImage.FPalette;
end;
function TBitmap.GetResourceType: TResourceType;
begin
Result := RT_BITMAP;
end;
function TBitmap.GetWidth: Integer;
begin
Result := FImage.FDIB.dsbm.bmWidth;

59
lcl/include/graphic.inc
View File

@ -45,6 +45,11 @@ begin
Result:=0;
end;
function TGraphic.GetResourceType: TResourceType;
begin
Result := nil;
end;
procedure TGraphic.Changed(Sender: TObject);
begin
FModified := True;
@ -126,7 +131,39 @@ begin
if (DefMimeType<>'') and (MimeType=GetDefaultMimeType) then
LoadFromStream(Stream)
else
raise Exception.Create(ClassName+': Unsupported MimeType: '+MimeType);
raise EInvalidGraphic.Create(ClassName+': Unsupported MimeType: '+MimeType);
end;
procedure TGraphic.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
Stream: TResourceStream;
ResType: TResourceType;
begin
ResType := GetResourceType;
if ResType = nil then Exit;
Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TGraphic.LoadFromResourceName(Instance: THandle; const ResName: String);
var
Stream: TResourceStream;
ResType: TResourceType;
begin
ResType := GetResourceType;
if ResType = nil then Exit;
Stream := TResourceStream.Create(Instance, ResName, ResType);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TGraphic.LoadFromClipboardFormat(FormatID: TClipboardFormat);
@ -193,6 +230,21 @@ begin
end;
end;
procedure TGraphic.LoadFromLazarusResource(const ResName: String);
var
Stream: TLazarusResourceStream;
begin
Stream := nil;
try
Stream := TLazarusResourceStream.Create(ResName, nil);
if LazarusResourceTypeValid(Stream.Res.ValueType)
then LoadFromStream(Stream)
else raise EInvalidGraphic.Create(ClassName+': Unsupported Resourcetype: '+Stream.Res.ValueType);
finally
Stream.Free;
end;
end;
procedure TGraphic.WriteData(Stream: TStream);
begin
SaveToStream(Stream);
@ -203,6 +255,11 @@ begin
Result := FTransparent;
end;
function TGraphic.LazarusResourceTypeValid(const AResourceType: string): boolean;
begin
Result := False;
end;
procedure TGraphic.SetModified(Value: Boolean);
begin
if Value then

17
lcl/include/pixmap.inc
View File

@ -277,18 +277,6 @@ end;
{ TPixmap }
procedure TPixmap.SaveToFile(const Filename: string);
begin
if (ClassType=TPixmap) and (FImage.SaveStreamType<>bnXPixmap) then begin
// TPixmap should always save in .xpm format
// but the current SaveStream is not in .xpm format.
// -> Clear the SaveStream.
UnshareImage(true);
FreeSaveStream;
end;
inherited SaveToFile(Filename);
end;
function TPixmap.LazarusResourceTypeValid(const ResourceType: string): boolean;
begin
Result:=(ResourceType='XPM');
@ -299,6 +287,11 @@ begin
WriteStreamWithFPImage(Stream,WriteSize,TLazWriterXPM);
end;
function TPixmap.GetBitmapNativeType: TBitmapNativeType;
begin
Result := bnXPixmap;
end;
class function TPixmap.GetDefaultFPReader: TFPCustomImageReaderClass;
begin
Result:=TLazReaderXPM;

21
lcl/lcltype.pp
View File

@ -1866,22 +1866,23 @@ const
{ constants for CreateDIBitmap }
CBM_INIT = 4; { initialize bitmap }
{ Predefined Resource Types }
type
{$ifdef UNICODE}
TResourceType = PWideChar;
{$else}
TResourceType = PChar;
{$endif}
const
{$ifdef windows}
RT_CURSOR = Windows.RT_CURSOR;
RT_BITMAP = Windows.RT_BITMAP;
RT_ICON = Windows.RT_ICON;
{$else}
{$ifdef UNICODE} // PI: taked this define from classesh.inc TResourceStream
RT_CURSOR = PWideChar(1);
RT_BITMAP = PWideChar(2);
RT_ICON = PWideChar(3);
{$else}
RT_CURSOR = PChar(1);
RT_BITMAP = PChar(2);
RT_ICON = PChar(3);
{$endif}
RT_CURSOR = TResourceType(1);
RT_BITMAP = TResourceType(2);
RT_ICON = TResourceType(3);
{$endif}