1090 lines
36 KiB
ObjectPascal
1090 lines
36 KiB
ObjectPascal
(*======================================================================*
|
|
| unitResourceGraphics |
|
|
| |
|
|
| Encapsulates graphics in resources (icon, cursor, bitmap) |
|
|
| |
|
|
| Version Date By Description |
|
|
| ------- ---------- ---- ------------------------------------------|
|
|
| 1.0 05/01/2001 CPWW Original |
|
|
*======================================================================*)
|
|
|
|
unit unitResourceGraphics;
|
|
|
|
interface
|
|
|
|
uses Windows, Classes, SysUtils, unitResourceDetails, graphics, unitExIcon, gifimage;
|
|
|
|
type
|
|
|
|
//------------------------------------------------------------------------
|
|
// Base class
|
|
|
|
TGraphicsResourceDetails = class (TResourceDetails)
|
|
protected
|
|
function GetHeight: Integer; virtual; abstract;
|
|
function GetPixelFormat: TPixelFormat; virtual; abstract;
|
|
function GetWidth: Integer; virtual; abstract;
|
|
public
|
|
procedure GetImage (picture : TPicture); virtual; abstract;
|
|
procedure SetImage (image : TPicture); virtual;
|
|
|
|
property Width : Integer read GetWidth;
|
|
property Height : Integer read GetHeight;
|
|
property PixelFormat : TPixelFormat read GetPixelFormat;
|
|
end;
|
|
|
|
TGraphicsResourceDetailsClass = class of TGraphicsResourceDetails;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Bitmap resource details class
|
|
|
|
TBitmapResourceDetails = class (TGraphicsResourceDetails)
|
|
protected
|
|
function GetHeight: Integer; override;
|
|
function GetPixelFormat: TPixelFormat; override;
|
|
function GetWidth: Integer; override;
|
|
procedure InitNew; override;
|
|
procedure InternalGetImage (s : TStream; picture : TPicture);
|
|
procedure InternalSetImage (s : TStream; image : TPicture);
|
|
|
|
public
|
|
class function GetBaseType : string; override;
|
|
procedure GetImage (picture : TPicture); override;
|
|
procedure SetImage (image : TPicture); override;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------
|
|
// DIB resource details class
|
|
//
|
|
// Same as RT_BITMAP resources, but they have a TBitmapFileHeader at the start
|
|
// of the resource, before the TBitmapInfoHeader. See
|
|
// \program files\Microsoft Office\office\1033\outlibr.dll
|
|
|
|
TDIBResourceDetails = class (TBitmapResourceDetails)
|
|
protected
|
|
class function SupportsData (Size : Integer; data : Pointer) : Boolean; override;
|
|
procedure InitNew; override;
|
|
public
|
|
class function GetBaseType : string; override;
|
|
procedure GetImage (picture : TPicture); override;
|
|
procedure SetImage (image : TPicture); override;
|
|
end;
|
|
|
|
TIconCursorResourceDetails = class;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Icon / Cursor group resource details class
|
|
|
|
TIconCursorGroupResourceDetails = class (TResourceDetails)
|
|
private
|
|
fDeleting : Boolean;
|
|
function GetResourceCount: Integer;
|
|
function GetResourceDetails(idx: Integer): TIconCursorResourceDetails;
|
|
protected
|
|
procedure InitNew; override;
|
|
public
|
|
procedure GetImage (picture : TPicture);
|
|
property ResourceCount : Integer read GetResourceCount;
|
|
property ResourceDetails [idx : Integer] : TIconCursorResourceDetails read GetResourceDetails;
|
|
function Contains (details : TIconCursorResourceDetails) : Boolean;
|
|
procedure RemoveFromGroup (details : TIconCursorResourceDetails);
|
|
procedure AddToGroup (details : TIconCursorResourceDetails);
|
|
procedure LoadImage (const FileName : string);
|
|
procedure BeforeDelete; override;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Icon group resource details class
|
|
|
|
TIconGroupResourceDetails = class (TIconCursorGroupResourceDetails)
|
|
public
|
|
class function GetBaseType : string; override;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Cursor group resource details class
|
|
|
|
TCursorGroupResourceDetails = class (TIconCursorGroupResourceDetails)
|
|
public
|
|
class function GetBaseType : string; override;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Icon / Cursor resource details class
|
|
|
|
TIconCursorResourceDetails = class (TGraphicsResourceDetails)
|
|
protected
|
|
function GetHeight: Integer; override;
|
|
function GetPixelFormat: TPixelFormat; override;
|
|
function GetWidth: Integer; override;
|
|
protected
|
|
procedure InitNew; override;
|
|
public
|
|
procedure BeforeDelete; override;
|
|
procedure GetImage (picture : TPicture); override;
|
|
procedure SetImage (image : TPicture); override;
|
|
property Width : Integer read GetWidth;
|
|
property Height : Integer read GetHeight;
|
|
property PixelFormat : TPixelFormat read GetPixelFormat;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Icon resource details class
|
|
|
|
TIconResourceDetails = class (TIconCursorResourceDetails)
|
|
public
|
|
class function GetBaseType : string; override;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------
|
|
// Cursor resource details class
|
|
|
|
TCursorResourceDetails = class (TIconCursorResourceDetails)
|
|
protected
|
|
public
|
|
class function GetBaseType : string; override;
|
|
end;
|
|
|
|
const
|
|
DefaultIconCursorWidth : Integer = 32;
|
|
DefaultIconCursorHeight : Integer = 32;
|
|
DefaultIconCursorPixelFormat : TPixelFormat = pf4Bit;
|
|
DefaultCursorHotspot : DWord = $00100010;
|
|
|
|
DefaultBitmapWidth : Integer = 128;
|
|
DefaultBitmapHeight : Integer = 96;
|
|
DefaultBitmapPixelFormat : TPixelFormat = pf24Bit;
|
|
|
|
implementation
|
|
|
|
type
|
|
|
|
TResourceDirectory = packed record
|
|
details : packed record case boolean of
|
|
False : (cursorWidth, cursorHeight : word);
|
|
True : (iconWidth, iconHeight, iconColorCount, iconReserved : BYTE)
|
|
end;
|
|
wPlanes, wBitCount : word;
|
|
lBytesInRes : DWORD;
|
|
wNameOrdinal : word
|
|
end;
|
|
PResourceDirectory = ^TResourceDirectory;
|
|
|
|
resourcestring
|
|
rstCursors = 'Cursors';
|
|
rstIcons = 'Icons';
|
|
|
|
{ TBitmapResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.GetBaseType |
|
|
*----------------------------------------------------------------------*)
|
|
class function TBitmapResourceDetails.GetBaseType: string;
|
|
begin
|
|
result := IntToStr (Integer (RT_BITMAP));
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.GetHeight |
|
|
*----------------------------------------------------------------------*)
|
|
function TBitmapResourceDetails.GetHeight: Integer;
|
|
begin
|
|
result := PBitmapInfoHeader (data.Memory)^.biHeight
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.GetImage |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TBitmapResourceDetails.GetImage(picture: TPicture);
|
|
var
|
|
s : TMemoryStream;
|
|
hdr : TBitmapFileHeader;
|
|
begin
|
|
s := TMemoryStream.Create;
|
|
try
|
|
hdr.bfType :=$4D42; // TBitmap.LoadFromStream requires a bitmapfileheader
|
|
hdr.bfSize := data.size; // before the data...
|
|
hdr.bfReserved1 := 0;
|
|
hdr.bfReserved2 := 0;
|
|
hdr.bfOffBits := sizeof (hdr);
|
|
|
|
s.Write (hdr, sizeof (hdr));
|
|
data.Seek (0, soFromBeginning);
|
|
s.CopyFrom (data, data.size);
|
|
|
|
InternalGetImage (s, picture)
|
|
finally
|
|
s.Free
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.GetPixelFormat |
|
|
*----------------------------------------------------------------------*)
|
|
function TBitmapResourceDetails.GetPixelFormat: TPixelFormat;
|
|
begin
|
|
result := GetBitmapInfoPixelFormat (PBitmapInfoHeader (data.Memory)^);
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.GetWidth |
|
|
*----------------------------------------------------------------------*)
|
|
function TBitmapResourceDetails.GetWidth: Integer;
|
|
begin
|
|
result := PBitmapInfoHeader (data.Memory)^.biWidth
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.SetImage |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TBitmapResourceDetails.InitNew;
|
|
var
|
|
bi : TBitmapInfoHeader;
|
|
imageSize : DWORD;
|
|
bits : PChar;
|
|
begin
|
|
bi.biSize := SizeOf (bi);
|
|
bi.biWidth := DefaultBitmapWidth;
|
|
bi.biHeight := DefaultBitmapHeight;
|
|
bi.biPlanes := 1;
|
|
bi.biBitCount := GetPixelFormatBitCount (DefaultBitmapPixelFormat);
|
|
bi.biCompression := BI_RGB;
|
|
|
|
imageSize := BytesPerScanLine (DefaultBitmapWidth, bi.biBitCount, 32) * DefaultBitmapHeight;
|
|
bi.biSizeImage := imageSize;
|
|
|
|
bi.biXPelsPerMeter := 0;
|
|
bi.biYPelsPerMeter := 0;
|
|
|
|
bi.biClrUsed := 0;
|
|
bi.biClrImportant := 0;
|
|
|
|
data.Write (bi, SizeOf (bi));
|
|
|
|
bits := AllocMem (ImageSize);
|
|
try
|
|
data.Write (bits^, ImageSize);
|
|
finally
|
|
ReallocMem (bits, 0)
|
|
end
|
|
end;
|
|
|
|
procedure TBitmapResourceDetails.InternalGetImage(s : TStream; picture: TPicture);
|
|
var
|
|
pHdr : PBitmapInfoHeader;
|
|
pal : HPalette;
|
|
colors : DWORD;
|
|
hangOnToPalette : Boolean;
|
|
newBmp : TBitmap;
|
|
begin
|
|
s.Seek (0, soFromBeginning);
|
|
picture.Bitmap.IgnorePalette := False;
|
|
picture.Bitmap.LoadFromStream (s);
|
|
|
|
pHdr := PBitmapInfoHeader (data.Memory);
|
|
|
|
// TBitmap makes all RLE encoded bitmaps into pfDevice
|
|
// ... that's not good enough for us! At least
|
|
// select the correct pixel format, preserve their carefully set
|
|
// up palette, etc.
|
|
//
|
|
// But revisit this - we probably shouldn't call LoadFromStream
|
|
// at all if this is the case...
|
|
//
|
|
// You can get a couple of RLE bitmaps out of winhlp32.exe
|
|
|
|
if PHdr^.biCompression in [BI_RLE4, BI_RLE8] then
|
|
begin
|
|
hangOnToPalette := False;
|
|
if pHdr^.biBitCount in [1, 4, 8] then
|
|
begin
|
|
pal := picture.Bitmap.Palette;
|
|
if pal <> 0 then
|
|
begin
|
|
colors := 0;
|
|
GetObject (pal, SizeOf (colors), @Colors);
|
|
|
|
if colors = 1 shl pHdr^.biBitCount then
|
|
begin
|
|
hangOnToPalette := True;
|
|
|
|
newBmp := TBitmap.Create;
|
|
try
|
|
case pHdr^.biBitCount of
|
|
1 : newBmp.PixelFormat := pf1Bit;
|
|
4 : newBmp.PixelFormat := pf4Bit;
|
|
8 : newBmp.PixelFormat := pf8Bit;
|
|
end;
|
|
|
|
newBmp.Width := Picture.Bitmap.Width;
|
|
newBmp.Height := Picture.Bitmap.Height;
|
|
newBmp.Palette := CopyPalette (pal);
|
|
newBmp.Canvas.Draw (0, 0, picture.Bitmap);
|
|
picture.Bitmap.Assign (newBmp);
|
|
finally
|
|
newBmp.Free
|
|
end
|
|
end
|
|
end
|
|
end;
|
|
|
|
if not hangOnToPalette then
|
|
case pHdr^.biBitCount of
|
|
1 : picture.Bitmap.PixelFormat := pf1Bit;
|
|
4 : picture.Bitmap.PixelFormat := pf4Bit;
|
|
8 : picture.Bitmap.PixelFormat := pf8Bit;
|
|
else
|
|
picture.Bitmap.PixelFormat := pf24Bit
|
|
end
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.InternalSetImage |
|
|
| |
|
|
| Save image 'image' to stream 's' as a bitmap |
|
|
| |
|
|
| Parameters: |
|
|
| |
|
|
| s : TStream The stream to save to |
|
|
| image : TPicture The image to save |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TBitmapResourceDetails.InternalSetImage(s: TStream; image: TPicture);
|
|
var
|
|
bmp : TBitmap;
|
|
begin
|
|
s.Size := 0;
|
|
bmp := TBitmap.Create;
|
|
try
|
|
bmp.Assign (image.graphic);
|
|
bmp.SaveToStream (s);
|
|
finally
|
|
bmp.Free;
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TBitmapResourceDetails.SetImage |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TBitmapResourceDetails.SetImage(image : TPicture);
|
|
var
|
|
s : TMemoryStream;
|
|
begin
|
|
s := TMemoryStream.Create;
|
|
try
|
|
InternalSetImage (s, image);
|
|
data.Clear;
|
|
data.Write ((PChar (s.Memory) + sizeof (TBitmapFileHeader))^, s.Size - sizeof (TBitmapFileHeader));
|
|
finally
|
|
s.Free;
|
|
end
|
|
end;
|
|
|
|
{ TIconGroupResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconGroupResourceDetails.GetBaseType |
|
|
*----------------------------------------------------------------------*)
|
|
class function TIconGroupResourceDetails.GetBaseType: string;
|
|
begin
|
|
result := IntToStr (Integer (RT_GROUP_ICON));
|
|
end;
|
|
|
|
{ TCursorGroupResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TCursorGroupResourceDetails.GetBaseType |
|
|
*----------------------------------------------------------------------*)
|
|
class function TCursorGroupResourceDetails.GetBaseType: string;
|
|
begin
|
|
result := IntToStr (Integer (RT_GROUP_CURSOR));
|
|
end;
|
|
|
|
{ TIconResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconResourceDetails.GetBaseType |
|
|
*----------------------------------------------------------------------*)
|
|
class function TIconResourceDetails.GetBaseType: string;
|
|
begin
|
|
result := IntToStr (Integer (RT_ICON));
|
|
end;
|
|
|
|
{ TCursorResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TCursorResourceDetails.GetBaseType |
|
|
*----------------------------------------------------------------------*)
|
|
class function TCursorResourceDetails.GetBaseType: string;
|
|
begin
|
|
result := IntToStr (Integer (RT_CURSOR));
|
|
end;
|
|
|
|
{ TGraphicsResourceDetails }
|
|
|
|
|
|
{ TIconCursorResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.GetHeight |
|
|
*----------------------------------------------------------------------*)
|
|
function TIconCursorResourceDetails.GetHeight: Integer;
|
|
var
|
|
infoHeader : PBitmapInfoHeader;
|
|
begin
|
|
if self is TCursorResourceDetails then // Not very 'OOP'. Sorry
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD))
|
|
else
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory));
|
|
|
|
result := infoHeader.biHeight div 2
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.GetImage |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorResourceDetails.GetImage(picture: TPicture);
|
|
var
|
|
iconCursor : TExIconCursor;
|
|
strm : TMemoryStream;
|
|
hdr : TIconHeader;
|
|
dirEntry : TIconDirEntry;
|
|
infoHeader : PBitmapInfoHeader;
|
|
begin
|
|
if data.Size = 0 then Exit;
|
|
|
|
|
|
strm := Nil;
|
|
if self is TCursorResourceDetails then
|
|
begin
|
|
hdr.wType := 2;
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD));
|
|
iconCursor := TExCursor.Create
|
|
end
|
|
else
|
|
begin
|
|
hdr.wType := 1;
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory));
|
|
iconCursor := TExIcon.Create
|
|
end;
|
|
|
|
try
|
|
strm := TMemoryStream.Create;
|
|
hdr.wReserved := 0;
|
|
hdr.wCount := 1;
|
|
|
|
strm.Write (hdr, sizeof (hdr));
|
|
|
|
dirEntry.bWidth := infoHeader^.biWidth;
|
|
dirEntry.bHeight := infoHeader^.biHeight div 2;
|
|
dirEntry.bColorCount := GetBitmapInfoNumColors (infoHeader^);
|
|
dirEntry.bReserved := 0;
|
|
|
|
dirEntry.wPlanes := infoHeader^.biPlanes;
|
|
dirEntry.wBitCount := infoHeader^.biBitCount;
|
|
|
|
dirEntry.dwBytesInRes := data.Size;
|
|
dirEntry.dwImageOffset := sizeof (hdr) + sizeof (dirEntry);
|
|
|
|
strm.Write (dirEntry, sizeof (dirEntry));
|
|
strm.CopyFrom (data, 0);
|
|
strm.Seek (0, soFromBeginning);
|
|
|
|
iconcursor.LoadFromStream (strm);
|
|
picture.Graphic := iconcursor
|
|
finally
|
|
strm.Free;
|
|
iconcursor.Free
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.SetImage |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorResourceDetails.SetImage(image: TPicture);
|
|
var
|
|
icon : TExIconCursor;
|
|
begin
|
|
icon := TExIconCursor (image.graphic);
|
|
data.Clear;
|
|
data.CopyFrom (icon.Images [icon.CurrentImage].MemoryImage, 0);
|
|
end;
|
|
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.GetPixelFormat |
|
|
*----------------------------------------------------------------------*)
|
|
function TIconCursorResourceDetails.GetPixelFormat: TPixelFormat;
|
|
var
|
|
infoHeader : PBitmapInfoHeader;
|
|
begin
|
|
if self is TCursorResourceDetails then
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD))
|
|
else
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory));
|
|
|
|
result := GetBitmapInfoPixelFormat (infoHeader^);
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.GetWidth |
|
|
*----------------------------------------------------------------------*)
|
|
function TIconCursorResourceDetails.GetWidth: Integer;
|
|
var
|
|
infoHeader : PBitmapInfoHeader;
|
|
begin
|
|
if self is TCursorResourceDetails then
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory) + sizeof (DWORD))
|
|
else
|
|
infoHeader := PBitmapInfoHeader (PChar (data.Memory));
|
|
|
|
result := infoHeader.biWidth
|
|
end;
|
|
|
|
{ TIconCursorGroupResourceDetails }
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.BeforeDelete
|
|
| |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorGroupResourceDetails.AddToGroup(
|
|
details: TIconCursorResourceDetails);
|
|
var
|
|
attributes : PResourceDirectory;
|
|
infoHeader : PBitmapInfoHeader;
|
|
cc : Integer;
|
|
begin
|
|
data.Size := Data.Size + sizeof (TResourceDirectory);
|
|
attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
|
|
|
|
Inc (Attributes, PIconHeader (data.Memory)^.wCount);
|
|
|
|
attributes^.wNameOrdinal := StrToInt (details.ResourceName);
|
|
attributes^.lBytesInRes := details.Data.Size;
|
|
|
|
if details is TIconResourceDetails then
|
|
begin
|
|
infoHeader := PBitmapInfoHeader (PChar (details.data.Memory));
|
|
attributes^.details.iconWidth := infoHeader^.biWidth;
|
|
attributes^.details.iconHeight := infoHeader^.biHeight div 2;
|
|
cc := GetBitmapInfoNumColors (infoHeader^);
|
|
if cc < 256 then
|
|
attributes^.details.iconColorCount := cc
|
|
else
|
|
attributes^.details.iconColorCount := 0;
|
|
attributes^.details.iconReserved := 0
|
|
end
|
|
else
|
|
begin
|
|
infoHeader := PBitmapInfoHeader (PChar (details.data.Memory) + sizeof (DWORD));
|
|
attributes^.details.cursorWidth := infoHeader^.biWidth;
|
|
attributes^.details.cursorHeight := infoHeader^.biHeight div 2
|
|
end;
|
|
|
|
attributes^.wPlanes := infoHeader^.biPlanes;
|
|
attributes^.wBitCount := infoHeader^.biBitCount;
|
|
|
|
Inc (PIconHeader (data.Memory)^.wCount);
|
|
end;
|
|
|
|
procedure TIconCursorGroupResourceDetails.BeforeDelete;
|
|
begin
|
|
fDeleting := True;
|
|
try
|
|
while ResourceCount > 0 do
|
|
Parent.DeleteResource (Parent.IndexOfResource (ResourceDetails [0]));
|
|
finally
|
|
fDeleting := False
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.Contains |
|
|
*----------------------------------------------------------------------*)
|
|
function TIconCursorGroupResourceDetails.Contains(
|
|
details: TIconCursorResourceDetails): Boolean;
|
|
var
|
|
i, id : Integer;
|
|
attributes : PResourceDirectory;
|
|
begin
|
|
Result := False;
|
|
if ResourceNameToInt (details.ResourceType) = ResourceNameToInt (ResourceType) - DIFFERENCE then
|
|
begin
|
|
attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
|
|
id := ResourceNameToInt (details.ResourceName);
|
|
|
|
for i := 0 to PIconHeader (Data.Memory)^.wCount - 1 do
|
|
if attributes^.wNameOrdinal = id then
|
|
begin
|
|
Result := True;
|
|
break
|
|
end
|
|
else
|
|
Inc (attributes)
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.GetImage |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorGroupResourceDetails.GetImage(picture: TPicture);
|
|
var
|
|
i, hdrOffset, imgOffset : Integer;
|
|
iconCursor : TExIconCursor;
|
|
strm : TMemoryStream;
|
|
hdr : TIconHeader;
|
|
dirEntry : TIconDirEntry;
|
|
pdirEntry : PIconDirEntry;
|
|
infoHeader : PBitmapInfoHeader;
|
|
begin
|
|
if data.Size = 0 then Exit;
|
|
|
|
strm := Nil;
|
|
if self is TCursorGroupResourceDetails then
|
|
begin
|
|
hdr.wType := 2;
|
|
hdrOffset := SizeOf (DWORD);
|
|
iconCursor := TExCursor.Create
|
|
end
|
|
else
|
|
begin
|
|
hdr.wType := 1;
|
|
hdrOffset := 0;
|
|
iconCursor := TExIcon.Create
|
|
end;
|
|
|
|
try
|
|
strm := TMemoryStream.Create;
|
|
hdr.wReserved := 0;
|
|
hdr.wCount := ResourceCount;
|
|
|
|
strm.Write (hdr, sizeof (hdr));
|
|
|
|
for i := 0 to ResourceCount - 1 do
|
|
begin
|
|
infoHeader := PBitmapInfoHeader (PChar (ResourceDetails [i].Data.Memory) + hdrOffset);
|
|
dirEntry.bWidth := infoHeader^.biWidth;
|
|
dirEntry.bHeight := infoHeader^.biHeight div 2;
|
|
dirEntry.wPlanes := infoHeader^.biPlanes;
|
|
dirEntry.bColorCount := GetBitmapInfoNumColors (infoHeader^);
|
|
dirEntry.bReserved := 0;
|
|
dirEntry.wBitCount := infoHeader^.biBitCount;
|
|
dirEntry.dwBytesInRes := resourceDetails [i].data.Size;
|
|
dirEntry.dwImageOffset := 0;
|
|
|
|
strm.Write (dirEntry, sizeof (dirEntry));
|
|
end;
|
|
|
|
for i := 0 to ResourceCount - 1 do
|
|
begin
|
|
imgOffset := strm.Position;
|
|
pDirEntry := PIconDirEntry (PChar (strm.Memory) + SizeOf (TIconHeader) + i * SizeOf (TIconDirEntry));
|
|
pDirEntry^.dwImageOffset := imgOffset;
|
|
|
|
strm.CopyFrom (ResourceDetails [i].Data, 0);
|
|
end;
|
|
|
|
if ResourceCount > 0 then
|
|
begin
|
|
strm.Seek (0, soFromBeginning);
|
|
iconcursor.LoadFromStream (strm);
|
|
picture.Graphic := iconcursor
|
|
end
|
|
else
|
|
picture.Graphic := Nil
|
|
finally
|
|
strm.Free;
|
|
iconcursor.Free
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.GetResourceCount |
|
|
*----------------------------------------------------------------------*)
|
|
function TIconCursorGroupResourceDetails.GetResourceCount: Integer;
|
|
begin
|
|
result := PIconHeader (Data.Memory)^.wCount
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.GetResourceDetails |
|
|
*----------------------------------------------------------------------*)
|
|
function TIconCursorGroupResourceDetails.GetResourceDetails(
|
|
idx: Integer): TIconCursorResourceDetails;
|
|
var
|
|
i : Integer;
|
|
res : TResourceDetails;
|
|
attributes : PResourceDirectory;
|
|
iconCursorResourceType : string;
|
|
begin
|
|
result := Nil;
|
|
attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
|
|
Inc (attributes, idx);
|
|
|
|
// DIFFERENCE (from Windows.pas) is 11. It's the difference between a 'group
|
|
// resource' and the resource itself. They called it 'DIFFERENCE' to be annoying.
|
|
|
|
iconCursorResourceType := IntToStr (ResourceNameToInt (ResourceType) - DIFFERENCE);
|
|
for i := 0 to Parent.ResourceCount - 1 do
|
|
begin
|
|
res := Parent.ResourceDetails [i];
|
|
if (res is TIconCursorResourceDetails) and (iconCursorResourceType = res.ResourceType) and (attributes.wNameOrdinal = ResourceNameToInt (res.ResourceName)) then
|
|
begin
|
|
result := TIconCursorResourceDetails (res);
|
|
break
|
|
end
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.InitNew |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorGroupResourceDetails.InitNew;
|
|
var
|
|
imageResource : TIconCursorResourceDetails;
|
|
iconHeader : TIconHeader;
|
|
dir : TResourceDirectory;
|
|
nm : string;
|
|
|
|
begin
|
|
iconHeader.wCount := 1;
|
|
iconHeader.wReserved := 0;
|
|
|
|
if Self is TCursorGroupResourceDetails then
|
|
begin
|
|
iconHeader.wType := 2;
|
|
nm := Parent.GetUniqueResourceName (TCursorResourceDetails.GetBaseType);
|
|
imageResource := TCursorResourceDetails.CreateNew (Parent, ResourceLanguage, nm)
|
|
end
|
|
else
|
|
begin
|
|
iconHeader.wType := 1;
|
|
nm := Parent.GetUniqueResourceName (TIconResourceDetails.GetBaseType);
|
|
imageResource := TIconResourceDetails.CreateNew (Parent, ResourceLanguage, nm)
|
|
end;
|
|
|
|
data.Write (iconHeader, SizeOf (iconHeader));
|
|
|
|
if Self is TIconGroupResourceDetails then
|
|
begin
|
|
dir.details.iconWidth := DefaultIconCursorWidth;
|
|
dir.details.iconHeight := DefaultIconCursorHeight;
|
|
dir.details.iconColorCount := GetPixelFormatNumColors (DefaultIconCursorPixelFormat);
|
|
dir.details.iconReserved := 0
|
|
end
|
|
else
|
|
begin
|
|
dir.details.cursorWidth := DefaultIconCursorWidth;
|
|
dir.details.cursorHeight := DefaultIconCursorHeight
|
|
end;
|
|
|
|
dir.wPlanes := 1;
|
|
dir.wBitCount := GetPixelFormatBitCount (DefaultIconCursorPixelFormat);
|
|
dir.lBytesInRes := imageResource.Data.Size;
|
|
dir.wNameOrdinal := ResourceNametoInt (imageResource.ResourceName);
|
|
|
|
data.Write (dir, SizeOf (dir));
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.BeforeDelete |
|
|
| |
|
|
| If we're deleting an icon/curor resource, remove its reference from |
|
|
| the icon/cursor group resource. |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorResourceDetails.BeforeDelete;
|
|
var
|
|
i : Integer;
|
|
details : TResourceDetails;
|
|
resGroup : TIconCursorGroupResourceDetails;
|
|
begin
|
|
for i := 0 to Parent.ResourceCount - 1 do
|
|
begin
|
|
details := Parent.ResourceDetails [i];
|
|
if (details.ResourceType = IntToStr (ResourceNameToInt (ResourceType) + DIFFERENCE)) then
|
|
begin
|
|
resGroup := details as TIconCursorGroupResourceDetails;
|
|
if resGroup.Contains (Self) then
|
|
begin
|
|
resGroup.RemoveFromGroup (Self);
|
|
break
|
|
end
|
|
end
|
|
end
|
|
end;
|
|
|
|
procedure TIconCursorGroupResourceDetails.LoadImage(
|
|
const FileName: string);
|
|
var
|
|
img : TExIconCursor;
|
|
hdr : TIconHeader;
|
|
i : Integer;
|
|
dirEntry : TResourceDirectory;
|
|
res : TIconCursorResourceDetails;
|
|
resTp : string;
|
|
begin
|
|
BeforeDelete; // Make source there are no existing image resources
|
|
|
|
if Self is TIconGroupResourceDetails then
|
|
begin
|
|
hdr.wType := 1;
|
|
img := TExIcon.Create;
|
|
resTp := TIconResourceDetails.GetBaseType;
|
|
end
|
|
else
|
|
begin
|
|
hdr.wType := 2;
|
|
img := TExCursor.Create;
|
|
resTp := TCursorResourceDetails.GetBaseType;
|
|
end;
|
|
|
|
img.LoadFromFile (FileName);
|
|
|
|
hdr.wReserved := 0;
|
|
hdr.wCount := img.ImageCount;
|
|
|
|
data.Clear;
|
|
|
|
data.Write (hdr, SizeOf (hdr));
|
|
|
|
for i := 0 to img.ImageCount - 1 do
|
|
begin
|
|
if hdr.wType = 1 then
|
|
begin
|
|
dirEntry.details.iconWidth := img.Images [i].FWidth;
|
|
dirEntry.details.iconHeight := img.Images [i].FHeight;
|
|
dirEntry.details.iconColorCount := GetPixelFormatNumColors (img.Images [i].FPixelFormat);
|
|
dirEntry.details.iconReserved := 0
|
|
end
|
|
else
|
|
begin
|
|
dirEntry.details.cursorWidth := img.Images [i].FWidth;
|
|
dirEntry.details.cursorHeight := img.Images [i].FHeight;
|
|
end;
|
|
|
|
dirEntry.wPlanes := 1;
|
|
dirEntry.wBitCount := GetPixelFormatBitCount (img.Images [i].FPixelFormat);
|
|
|
|
dirEntry.lBytesInRes := img.Images [i].FMemoryImage.Size;
|
|
|
|
if hdr.wType = 1 then
|
|
res := TIconResourceDetails.Create (Parent, ResourceLanguage, Parent.GetUniqueResourceName (resTp), resTp, img.Images [i].FMemoryImage.Size, img.Images [i].FMemoryImage.Memory)
|
|
else
|
|
res := TCursorResourceDetails.Create (Parent, ResourceLanguage, Parent.GetUniqueResourceName (resTp), resTp, img.Images [i].FMemoryImage.Size, img.Images [i].FMemoryImage.Memory);
|
|
Parent.AddResource (res);
|
|
dirEntry.wNameOrdinal := ResourceNameToInt (res.ResourceName);
|
|
|
|
data.Write (dirEntry, SizeOf (dirEntry));
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorGroupResourceDetails.RemoveFromGroup |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorGroupResourceDetails.RemoveFromGroup(
|
|
details: TIconCursorResourceDetails);
|
|
var
|
|
i, id, count : Integer;
|
|
attributes, ap : PResourceDirectory;
|
|
begin
|
|
if ResourceNametoInt (details.ResourceType) = ResourceNameToInt (ResourceType) - DIFFERENCE then
|
|
begin
|
|
attributes := PResourceDirectory (PChar (Data.Memory) + sizeof (TIconHeader));
|
|
id := ResourceNametoInt (details.ResourceName);
|
|
|
|
Count := PIconHeader (Data.Memory)^.wCount;
|
|
|
|
for i := 0 to Count - 1 do
|
|
if attributes^.wNameOrdinal = id then
|
|
begin
|
|
if i < Count - 1 then
|
|
begin
|
|
ap := Attributes;
|
|
Inc (ap);
|
|
Move (ap^, Attributes^, SizeOf (TResourceDirectory) * (Count - i - 1));
|
|
end;
|
|
|
|
Data.Size := data.Size - SizeOf (TResourceDirectory);
|
|
PIconHeader (Data.Memory)^.wCount := Count - 1;
|
|
if (Count = 1) and not fDeleting then
|
|
Parent.DeleteResource (Parent.IndexOfResource (Self));
|
|
break
|
|
end
|
|
else
|
|
Inc (attributes)
|
|
end
|
|
end;
|
|
|
|
(*----------------------------------------------------------------------*
|
|
| TIconCursorResourceDetails.InitNew |
|
|
*----------------------------------------------------------------------*)
|
|
procedure TIconCursorResourceDetails.InitNew;
|
|
var
|
|
hdr : TBitmapInfoHeader;
|
|
cImageSize : DWORD;
|
|
pal : HPALETTE;
|
|
entries : PPALETTEENTRY;
|
|
w : DWORD;
|
|
p : PChar;
|
|
|
|
begin
|
|
if Self is TCursorResourceDetails then
|
|
Data.Write (DefaultCursorHotspot, SizeOf (DefaultCursorHotspot));
|
|
|
|
hdr.biSize := SizeOf (hdr);
|
|
hdr.biWidth := DefaultIconCursorWidth;
|
|
hdr.biHeight := DefaultIconCursorHeight * 2;
|
|
hdr.biPlanes := 1;
|
|
hdr.biBitCount := GetPixelFormatBitCount (DefaultIconCursorPixelFormat);
|
|
|
|
if DefaultIconCursorPixelFormat = pf16Bit then
|
|
hdr.biCompression := BI_BITFIELDS
|
|
else
|
|
hdr.biCompression := BI_RGB;
|
|
|
|
hdr.biSizeImage := 0; // See note in unitExIcon
|
|
|
|
hdr.biXPelsPerMeter := 0;
|
|
hdr.biYPelsPerMeter := 0;
|
|
|
|
hdr.biClrUsed := GetPixelFormatNumColors (DefaultIconCursorPixelFormat);
|
|
hdr.biClrImportant := hdr.biClrUsed;
|
|
|
|
Data.Write (hdr, SizeOf (hdr));
|
|
|
|
pal := 0;
|
|
case DefaultIconCursorPixelFormat of
|
|
pf1Bit : pal := SystemPalette2;
|
|
pf4Bit : pal := SystemPalette16;
|
|
pf8Bit : pal := SystemPalette256
|
|
end;
|
|
|
|
entries := Nil;
|
|
try
|
|
if pal > 0 then
|
|
begin
|
|
GetMem (entries, hdr.biClrUsed * sizeof (PALETTEENTRY));
|
|
GetPaletteEntries (pal, 0, hdr.biClrUsed, entries^);
|
|
|
|
data.Write (entries^, hdr.biClrUsed * SizeOf (PALETTEENTRY))
|
|
end
|
|
else
|
|
if hdr.biCompression = BI_BITFIELDS then
|
|
begin { 5,6,5 bitfield }
|
|
w := $0f800; // 1111 1000 0000 0000 5 bit R mask
|
|
data.Write (w, SizeOf (w));
|
|
w := $07e0; // 0000 0111 1110 0000 6 bit G mask
|
|
data.Write (w, SizeOf (w));
|
|
w := $001f; // 0000 0000 0001 1111 5 bit B mask
|
|
data.Write (w, SizeOf (w))
|
|
end
|
|
|
|
finally
|
|
ReallocMem (entries, 0)
|
|
end;
|
|
|
|
// Write dummy image
|
|
cImageSize := BytesPerScanLine (hdr.biWidth, hdr.biBitCount, 32) * DefaultIconCursorHeight;
|
|
p := AllocMem (cImageSize);
|
|
try
|
|
data.Write (p^, cImageSize);
|
|
finally
|
|
ReallocMem (p, 0)
|
|
end;
|
|
|
|
// Write dummy mask
|
|
cImageSize := DefaultIconCursorHeight * DefaultIconCursorWidth div 8;
|
|
|
|
GetMem (p, cImageSize);
|
|
FillChar (p^, cImageSize, $ff);
|
|
|
|
try
|
|
data.Write (p^, cImageSize);
|
|
finally
|
|
ReallocMem (p, 0)
|
|
end;
|
|
end;
|
|
|
|
{ TDIBResourceDetails }
|
|
|
|
class function TDIBResourceDetails.GetBaseType: string;
|
|
begin
|
|
Result := 'DIB';
|
|
end;
|
|
|
|
procedure TDIBResourceDetails.GetImage(picture: TPicture);
|
|
begin
|
|
InternalGetImage (data, Picture);
|
|
end;
|
|
|
|
procedure TDIBResourceDetails.InitNew;
|
|
var
|
|
hdr : TBitmapFileHeader;
|
|
begin
|
|
hdr.bfType := $4d42;
|
|
hdr.bfSize := SizeOf (TBitmapFileHeader) + SizeOf (TBitmapInfoHeader);
|
|
hdr.bfReserved1 := 0;
|
|
hdr.bfReserved2 := 0;
|
|
hdr.bfOffBits := hdr.bfSize;
|
|
data.Write (hdr, SizeOf (hdr));
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDIBResourceDetails.SetImage(image: TPicture);
|
|
begin
|
|
InternalSetImage (data, image);
|
|
end;
|
|
|
|
class function TDIBResourceDetails.SupportsData(Size: Integer;
|
|
data: Pointer): Boolean;
|
|
var
|
|
p : PBitmapFileHeader;
|
|
hdrSize : DWORD;
|
|
begin
|
|
Result := False;
|
|
p := PBitmapFileHeader (data);
|
|
if (p^.bfType = $4d42) and (p^.bfReserved1 = 0) and (p^.bfReserved2 = 0) then
|
|
begin
|
|
hdrSize := PDWORD (PChar (data) + SizeOf (TBitmapFileHeader))^;
|
|
|
|
case hdrSize of
|
|
SizeOf (TBitmapInfoHeader) : Result := True;
|
|
SizeOf (TBitmapV4Header) : Result := True;
|
|
SizeOf (TBitmapV5Header) : Result := True
|
|
end
|
|
end
|
|
end;
|
|
|
|
{ TGraphicsResourceDetails }
|
|
|
|
procedure TGraphicsResourceDetails.SetImage(image: TPicture);
|
|
begin
|
|
data.Clear;
|
|
image.Graphic.SaveToStream (data);
|
|
end;
|
|
|
|
initialization
|
|
TPicture.RegisterFileFormat ('ICO', rstIcons, TExIcon);
|
|
TPicture.RegisterFileFormat ('CUR', rstCursors, TExCursor);
|
|
TPicture.UnregisterGraphicClass (TIcon);
|
|
|
|
|
|
RegisterResourceDetails (TBitmapResourceDetails);
|
|
RegisterResourceDetails (TDIBResourceDetails);
|
|
RegisterResourceDetails (TIconGroupResourceDetails);
|
|
RegisterResourceDetails (TCursorGroupResourceDetails);
|
|
RegisterResourceDetails (TIconResourceDetails);
|
|
RegisterResourceDetails (TCursorResourceDetails);
|
|
finalization
|
|
TPicture.UnregisterGraphicClass (TExIcon);
|
|
TPicture.UnregisterGraphicClass (TExCursor);
|
|
TPicture.RegisterFileFormat ('ICO', 'Icon', TIcon);
|
|
UnregisterResourceDetails (TCursorResourceDetails);
|
|
UnregisterResourceDetails (TIconResourceDetails);
|
|
UnregisterResourceDetails (TCursorGroupResourceDetails);
|
|
UnregisterResourceDetails (TIconGroupResourceDetails);
|
|
UnregisterResourceDetails (TDIBResourceDetails);
|
|
UnregisterResourceDetails (TBitmapResourceDetails);
|
|
end.
|