lcl: native resource support:

- add implementation for LoadFromResourceName and LoadFromResourceID for TIcon and TCursorImage
  - try loading icon from native resource if appropriate lrs resource is not available

git-svn-id: trunk@23290 -

lcl/graphics.pp

@@ -795,8 +795,8 @@ type
     procedure LoadFromStream(Stream: TStream); virtual; abstract;
     procedure LoadFromMimeStream(AStream: TStream; const AMimeType: string); virtual;
     procedure LoadFromLazarusResource(const ResName: String); virtual;
-    procedure LoadFromResourceName(Instance: THandle; const ResName: String);
-    procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
+    procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual;
+    procedure LoadFromResourceID(Instance: THandle; ResID: Integer); virtual;
     procedure LoadFromClipboardFormat(FormatID: TClipboardFormat); virtual;
     procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
       FormatID: TClipboardFormat); virtual;
@@ -1607,6 +1607,11 @@ type
     procedure SetSize(AWidth, AHeight: integer); override;
     class function GetFileExtensions: string; override;
     function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
+    procedure LoadFromResourceName(Instance: THandle; const ResName: String); override;
+    procedure LoadFromResourceID(Instance: THandle; ResID: Integer); override;
+    {$IFDEF FPC_HAS_WINLIKERESOURCES}
+    procedure LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle);
+    {$ENDIF}
     function BitmapHandleAllocated: boolean; override;
     function MaskHandleAllocated: boolean; override;
     function PaletteAllocated: boolean; override;
@@ -1628,6 +1633,7 @@ type
     procedure HandleNeeded; override;
   public
     function ReleaseHandle: HICON;
+    function GetResourceType: TResourceType; override;
     property Handle: HICON read GetIconHandle write SetIconHandle;
   end;
   
@@ -1705,6 +1711,7 @@ type
     class function GetTypeID: Word; override;
   public
     class function GetFileExtensions: string; override;
+    function GetResourceType: TResourceType; override;
     function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
     function ReleaseHandle: HCURSOR;
     property HotSpot: TPoint read GetHotSpot;

lcl/include/application.inc

@@ -359,6 +359,10 @@ end;
        needs to occur.
 ------------------------------------------------------------------------------}
 procedure TApplication.Initialize;
+{$IFDEF FPC_HAS_WINLIKERESOURCES}
+var
+  Res: TFPResourceHandle;
+{$ENDIF}
 begin
   inherited Initialize;
   // interface object and screen
@@ -375,7 +379,15 @@ begin
 
   // application icon
   if LazarusResources.Find('MAINICON') <> nil then
-    Icon.LoadFromLazarusResource('MAINICON');
+    Icon.LoadFromLazarusResource('MAINICON')
+  {$IFDEF FPC_HAS_WINLIKERESOURCES}
+  else
+  begin
+    Res := FindResource(HInstance, PChar('MAINICON'), RT_GROUP_ICON);
+    if Res <> 0 then
+      Icon.LoadFromResourceHandle(Hinstance, Res);
+  end;
+  {$ENDIF}
 end;
 
 {------------------------------------------------------------------------------

lcl/include/cursorimage.inc

@@ -43,6 +43,11 @@ begin
   Result := 'cur';
 end;
 
+function TCursorImage.GetResourceType: TResourceType;
+begin
+  Result := RT_GROUP_CURSOR;
+end;
+
 class function TCursorImage.GetSharedImageClass: TSharedRasterImageClass;
 begin
   Result := TSharedCursorImage;

lcl/include/icon.inc

@@ -53,6 +53,34 @@ type
   
   PIconDirEntry = ^TIconDirEntry;
 
+  // executables and libraries has the next structures for icons and cursors
+  TGrpIconDirEntry = packed record
+    bWidth: Byte;               // Width, in pixels, of the image
+    bHeight: Byte;              // Height, in pixels, of the image
+    bColorCount: Byte;          // Number of colors in image (0 if >=8bpp)
+    bReserved: Byte;            // Reserved
+    case Byte of
+      1: (
+        // icon
+        wPlanes: Word;          // color planes
+        wBpp: Word;             // bits per pixel
+        // common
+        dwBytesInRes: Dword;    // how many bytes in this resource?
+        nID: Word;              // the ID
+      );
+      2:(
+        // cursor
+        wXHotSpot: Word;
+        wYHotSpot: Word;
+      );
+  end;
+
+  TGrpIconDir = packed record
+    idReserved: Word; // Reserved (must be 0)
+    idType: Word;     // Resource type (1 for icons)
+    idCount: Word;    //  How many images?
+    idEntries: array[0..0] of TGrpIconDirEntry; // The entries for each image
+  end;
 
 function TestStreamIsIcon(const AStream: TStream): boolean;
 var
@@ -613,6 +641,95 @@ begin
   end;
 end;
 
+procedure TCustomIcon.LoadFromResourceName(Instance: THandle; const ResName: String);
+{$IFDEF FPC_HAS_WINLIKERESOURCES}
+var
+  ResType: TResourceType;
+  ResHandle: TFPResourceHandle;
+{$ENDIF}
+begin
+{$IFDEF FPC_HAS_WINLIKERESOURCES}
+  ResType := GetResourceType;
+  if ResType = nil then Exit;
+
+  ResHandle := FindResource(Instance, PChar(ResName), ResType);
+  if ResHandle = 0 then
+    raise EResNotFound.Create(ResName); // todo: valid exception
+  LoadFromResourceHandle(Instance, ResHandle);
+{$ENDIF}
+end;
+
+procedure TCustomIcon.LoadFromResourceID(Instance: THandle; ResID: Integer);
+{$IFDEF FPC_HAS_WINLIKERESOURCES}
+var
+  ResType: TResourceType;
+  ResHandle: TFPResourceHandle;
+{$ENDIF}
+begin
+  {$IFDEF FPC_HAS_WINLIKERESOURCES}
+  ResType := GetResourceType;
+  if ResType = nil then Exit;
+
+  ResHandle := FindResource(Instance, PChar(ResID), ResType);
+  if ResHandle = 0 then
+    raise EResNotFound.Create(''); // todo: valid exception
+  LoadFromResourceHandle(Instance, ResHandle);
+  {$ENDIF}
+end;
+
+{$IFDEF FPC_HAS_WINLIKERESOURCES}
+procedure TCustomIcon.LoadFromResourceHandle(Instance: THandle; ResHandle: TFPResourceHandle);
+var
+  GlobalHandle: TFPResourceHGlobal;
+  Dir: ^TGrpIconDir;
+  DirEntry: TGrpIconDirEntry;
+  IconEntry: TIconDirEntry;
+  i, offset: integer;
+  Stream: TMemoryStream;
+  IconStream: TResourceStream;
+begin
+  // build a usual ico/cur stream using several RT_ICON resources
+  GlobalHandle := LoadResource(Instance, ResHandle);
+  if GlobalHandle = 0 then
+    Exit;
+  Dir := LockResource(GlobalHandle);
+  if Dir = nil then
+    Exit;
+
+  Stream := TMemoryStream.Create;
+  try
+    // write icon header
+    Stream.Write(Dir^, SizeOf(TIconHeader));
+    // write icon entries headers
+    offset := Stream.Position + SizeOf(IconEntry) * Dir^.idCount;
+    for i := 0 to Dir^.idCount - 1 do
+    begin
+      DirEntry := Dir^.idEntries[i];
+      Move(DirEntry, IconEntry, SizeOf(DirEntry));
+      IconEntry.dwImageOffset := offset;
+      inc(offset, IconEntry.dwBytesInRes);
+      Stream.Write(IconEntry, SizeOf(IconEntry));
+    end;
+    // write icons data
+    for i := 0 to Dir^.idCount - 1 do
+    begin
+      IconStream := TResourceStream.CreateFromID(Instance, Dir^.idEntries[i].nID, RT_ICON);
+      try
+        Stream.CopyFrom(IconStream, IconStream.Size);
+      finally
+        IconStream.Free;
+      end;
+    end;
+    Stream.Position := 0;
+    ReadData(Stream);
+  finally
+    Stream.Free;
+    UnLockResource(GlobalHandle);
+    FreeResource(GlobalHandle);
+  end;
+end;
+{$ENDIF}
+
 function TCustomIcon.MaskHandleAllocated: boolean;
 begin
   Result := (FCurrent <> -1) and (TIconImage(TSharedIcon(FSharedImage).FImages[FCurrent]).FMaskHandle <> 0);
@@ -1222,6 +1339,11 @@ begin
   Result := FSharedImage.ReleaseHandle;
 end;
 
+function TIcon.GetResourceType: TResourceType;
+begin
+  Result := RT_GROUP_ICON;
+end;
+
 procedure TIcon.SetIconHandle(const AValue: HICON);
 begin
   SetHandle(AValue);

lcl/lcltype.pp

@@ -1953,13 +1953,41 @@ const
 {$ifdef windows}
   RT_CURSOR = Windows.RT_CURSOR;
   RT_BITMAP = Windows.RT_BITMAP;
-  RT_ICON   = Windows.RT_ICON;
+  RT_ICON = Windows.RT_ICON;
+  RT_MENU = Windows.RT_MENU;
+  RT_DIALOG = Windows.RT_DIALOG;
+  RT_STRING = Windows.RT_STRING;
+  RT_FONTDIR = Windows.RT_FONTDIR;
+  RT_FONT = Windows.RT_FONT;
+  RT_ACCELERATOR = Windows.RT_ACCELERATOR;
   RT_RCDATA = Windows.RT_RCDATA;
+  RT_MESSAGETABLE = Windows.RT_MESSAGETABLE;
+  RT_GROUP_CURSOR = Windows.RT_GROUP_CURSOR;
+  RT_GROUP_ICON = Windows.RT_GROUP_ICON;
+  RT_VERSION = Windows.RT_VERSION;
+  RT_ANICURSOR = Windows.RT_ANICURSOR;
+  RT_ANIICON = Windows.RT_ANIICON;
+  RT_HTML = Windows.RT_HTML;
+  RT_MANIFEST = Windows.RT_MANIFEST;
 {$else}
   RT_CURSOR = TResourceType(1);
   RT_BITMAP = TResourceType(2);
-  RT_ICON   = TResourceType(3);
+  RT_ICON = TResourceType(3);
+  RT_MENU = TResourceType(4);
+  RT_DIALOG = TResourceType(5);
+  RT_STRING = TResourceType(6);
+  RT_FONTDIR = TResourceType(7);
+  RT_FONT = TResourceType(8);
+  RT_ACCELERATOR = TResourceType(9);
   RT_RCDATA = TResourceType(10);
+  RT_MESSAGETABLE = TResourceType(11);
+  RT_GROUP_CURSOR = TResourceType(12);
+  RT_GROUP_ICON = TResourceType(14);
+  RT_VERSION = TResourceType(16);
+  RT_ANICURSOR = TResourceType(21);
+  RT_ANIICON = TResourceType(22);
+  RT_HTML = TResourceType(23);
+  RT_MANIFEST = TResourceType(24);
 {$endif}
 
 

lcl/lresources.pp

@@ -3019,7 +3019,7 @@ function InitLazResourceComponent(Instance: TComponent;
     {$ifdef UseRES}
     if Stream = nil then
     begin
-      FPResource := FindResource(HInstance, TResourceType(ResName), RT_RCDATA);
+      FPResource := FindResource(HInstance, PChar(ResName), RT_RCDATA);
       if FPResource <> 0 then
         Stream := TLazarusResourceStream.CreateFromHandle(HInstance, FPResource);
     end;