* Native imagelist implementation part 2 - win32 by paul and me

git-svn-id: trunk@10907 -

lcl/include/imglist.inc

@@ -200,9 +200,9 @@ var
 begin
   Bmp := TBitmap.Create;
 
-  Bmp.LoadFromLazarusResource(ResourceName);
   if MaskColor <> clNone then
     Bmp.TransparentColor := MaskColor;
+  Bmp.LoadFromLazarusResource(ResourceName);
   {$ifdef IMGLIST_OLDSTYLE}
   Result := AddDirect(Bmp, nil);
   {$else}

lcl/interfaces/win32/win32int.pp

@@ -273,7 +273,7 @@ Uses
 // Win32WSFileCtrl,
  Win32WSForms,
 // Win32WSGrids,
-// Win32WSImgList,
+ Win32WSImgList,
 // Win32WSMaskEdit,
  Win32WSMenus,
  Win32WSPairSplitter,

lcl/interfaces/win32/win32wsimglist.pp

@@ -33,9 +33,10 @@ uses
 // To get as little as posible circles,
 // uncomment only when needed for registration
 ////////////////////////////////////////////////////
-//  ImgList,
+  Windows, SysUtils, ImgList, GraphType, Graphics, LCLType,
+  WinExt, 
 ////////////////////////////////////////////////////
-  WSImgList, WSLCLClasses;
+  WSImgList, WSLCLClasses, WSProc;
 
 type
 
@@ -45,11 +46,147 @@ type
   private
   protected
   public
+    class procedure Clear(AList: TCustomImageList); override;
+    class function CreateHandle(AList: TCustomImageList; ACount, AGrow, AWidth,
+      AHeight: Integer; AData: PRGBAQuad): TLCLIntfHandle; override;
+    class procedure Delete(AList: TCustomImageList; AIndex: Integer); override;
+    class procedure DestroyHandle(AList: TCustomImageList); override;
+    class procedure Draw(AList: TCustomImageList; AIndex: Integer; ACanvas: TCanvas;
+      ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle); 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;
   end;
 
 
 implementation
 
+const
+  DrawingStyleMap: array[TDrawingStyle] of DWord =
+  (
+{ dsFocus       } ILD_FOCUS,
+{ dsSelected    } ILD_SELECTED,
+{ dsNormal      } ILD_NORMAL,
+{ dsTransparent } ILD_TRANSPARENT
+  );
+
+{ TWin32WSCustomImageList }
+
+class procedure TWin32WSCustomImageList.Clear(AList: TCustomImageList);
+begin
+  if not WSCheckHandleAllocated(AList, 'Clear')
+  then Exit;
+  ImageList_SetImageCount(HImageList(AList.Handle), 0);
+end;
+
+class function TWin32WSCustomImageList.CreateHandle(AList: TCustomImageList;
+  ACount, AGrow, AWidth, AHeight: Integer; AData: PRGBAQuad): TLCLIntfHandle;
+var
+  FLags: DWord;
+  hbmImage: HBITMAP;
+begin
+  if (Win32Platform and VER_PLATFORM_WIN32_NT) <> 0 then
+    Flags := ILC_COLOR32 or ILC_MASK
+  else
+    Flags := ILC_COLOR16 or ILC_MASK;
+  Result := ImageList_Create(ACount * AWidth, AHeight, Flags, 0, AGrow);
+  
+  if AData <> nil then
+  begin
+    hbmImage := CreateBitmap(ACount * AWidth, AHeight, 4, 32, AData);
+    ImageList_Add(Result, hbmImage, 0);
+    DeleteObject(hbmImage);
+  end;
+end;
+
+class procedure TWin32WSCustomImageList.Delete(AList: TCustomImageList;
+  AIndex: Integer);
+begin
+  if not WSCheckHandleAllocated(AList, 'Delete')
+  then Exit;
+  ImageList_Remove(HImageList(AList.Handle), AIndex);
+end;
+
+class procedure TWin32WSCustomImageList.DestroyHandle(AList: TCustomImageList);
+begin
+  if not WSCheckHandleAllocated(AList, 'DestroyHandle')
+  then Exit;
+  ImageList_Destroy(AList.Handle);
+end;
+
+class procedure TWin32WSCustomImageList.Draw(AList: TCustomImageList; AIndex: Integer;
+  ACanvas: TCanvas; ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle);
+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_DEFAULT, CLR_DEFAULT,
+    DrawingStyleMap[AStyle]);
+end;
+
+class procedure TWin32WSCustomImageList.Insert(AList: TCustomImageList;
+  AIndex: Integer; AData: PRGBAQuad);
+var
+  AImageList: HImageList;
+  ACount: Integer;
+  hbmImage: HBITMAP;
+begin
+  if not WSCheckHandleAllocated(AList, 'Insert')
+  then Exit;
+
+  AImageList := HImageList(AList.Handle);
+  ACount := ImageList_GetImageCount(AImageList);
+  
+  if (AIndex <= ACount) and (AIndex >= 0) then
+  begin
+    hbmImage := CreateBitmap(AList.Width, AList.Height, 4, 32, AData);
+    ImageList_Add(AImageList, hbmImage, 0);
+    DeleteObject(hbmImage);
+    if AIndex <> ACount 
+    then Move(AList, ACount, AIndex);
+  end;
+end;
+
+class procedure TWin32WSCustomImageList.Move(AList: TCustomImageList;
+  ACurIndex, ANewIndex: Integer);
+var
+  n: integer;
+  Handle: THandle;
+begin
+  if not WSCheckHandleAllocated(AList, 'Move')
+  then Exit;
+  
+  if ACurIndex = ANewIndex
+  then Exit;
+        
+  Handle := AList.Handle;
+  if ACurIndex < ANewIndex
+  then begin       
+    for n := ACurIndex to ANewIndex - 1 do
+      ImageList_Copy(Handle, n + 1, Handle, n, ILCF_SWAP);
+  end
+  else begin
+    for n := ACurIndex downto ANewIndex - 1 do
+      ImageList_Copy(Handle, n - 1, Handle, n, ILCF_SWAP);
+  end;
+
+  
+end;
+
+class procedure TWin32WSCustomImageList.Replace(AList: TCustomImageList;
+  AIndex: Integer; AData: PRGBAQuad);
+var
+  hbmImage: HBITMAP;
+begin
+  if not WSCheckHandleAllocated(AList, 'Replace')
+  then Exit;
+
+  hbmImage := CreateBitmap(AList.Width, AList.Height, 4, 32, AData);
+  ImageList_Replace(HImageList(AList.Handle), AIndex, hbmImage, 0);
+  DeleteObject(hbmImage);
+end;
+
 initialization
 
 ////////////////////////////////////////////////////
@@ -58,6 +195,6 @@ initialization
 // To improve speed, register only classes
 // which actually implement something
 ////////////////////////////////////////////////////
-//  RegisterWSComponent(TCustomImageList, TWin32WSCustomImageList);
+  RegisterWSComponent(TCustomImageList, TWin32WSCustomImageList);
 ////////////////////////////////////////////////////
-end.
+end.

lcl/interfaces/win32/winext.pas

@@ -228,6 +228,14 @@ function ListView_GetHoverTime(hwndLV: HWND): DWORD;
 function ListView_SetHoverTime(hwndLV: HWND; dwHoverTimeMs: DWORD): DWORD;
 }
 
+// missing imagelist macros and constants
+
+const
+  ILCF_MOVE = $00000000;
+  ILCF_SWAP = $00000001;
+
+function ImageList_Copy(himlDst: HIMAGELIST; iDst: longint; himlSrc: HIMAGELIST; Src: longint; uFlags: UINT): BOOL; stdcall; external 'comctl32';
+
 
 { Win32 API functions not included in windows.pp }
 { Get the ancestor at level Flag of window HWnd }

lcl/widgetset/wsimglist.pp

@@ -50,12 +50,16 @@ type
     class procedure Clear(AList: TCustomImageList); virtual;
     class function  CreateHandle(AList: TCustomImageList; ACount, AGrow, AWidth,
       AHeight: Integer; AData: PRGBAQuad): TLCLIntfHandle; virtual;
+
     class procedure Delete(AList: TCustomImageList; AIndex: Integer); virtual;
     class procedure DestroyHandle(AList: TCustomImageList); virtual;
     class procedure Draw(AList: TCustomImageList; AIndex: Integer; ACanvas: TCanvas;
       ABounds: TRect; AEnabled: Boolean; AStyle: TDrawingStyle); virtual;
+
     class procedure Insert(AList: TCustomImageList; AIndex: Integer; AData: PRGBAQuad); virtual;
+
     class procedure Move(AList: TCustomImageList; ACurIndex, ANewIndex: Integer); virtual;
+
     class procedure Replace(AList: TCustomImageList; AIndex: Integer; AData: PRGBAQuad); virtual;
   end;
 

lcl/widgetset/wslclclasses.pp

@@ -436,4 +436,4 @@ initialization
 finalization
   DoFinalization;
 
-end.
+end.

lcl/widgetset/wsproc.pp

@@ -29,20 +29,41 @@ unit WSProc;
 interface
 
 uses
-  SysUtils, Controls;
+  LCLClasses, LCLProc, Controls;
 
 
+function WSCheckHandleAllocated(const AComponent: TLCLHandleComponent;
+                                const AProcName: String): Boolean;
+
 function WSCheckHandleAllocated(const AWincontrol: TWinControl;
                                 const AProcName: String): Boolean;
   
 implementation                                                  
                                                               
-function WSCheckHandleAllocated(const AWincontrol: TWinControl;
+function WSCheckHandleAllocated(const AComponent: TLCLHandleComponent;
   const AProcName: String): Boolean;
+
+  procedure Warn;
+  begin
+    DebugLn('[WARNING] %s called without handle for %s(%s)', [AProcName, AComponent.Name, AComponent.ClassName]);
+  end;
 begin
-  Result := AWinControl.HandleAllocated; 
-  if not Result
-  then Assert(False, Format('trace: [WARNING] %s called without handle for %s(%s)', [AProcName, AWinControl.Name, AWinControl.ClassName]));
+  Result := AComponent.HandleAllocated; 
+  if Result then Exit;
+  Warn;
 end;
 
-end.
+function WSCheckHandleAllocated(const AWincontrol: TWinControl;
+  const AProcName: String): Boolean;
+
+  procedure Warn;
+  begin
+    DebugLn('[WARNING] %s called without handle for %s(%s)', [AProcName, AWincontrol.Name, AWincontrol.ClassName]);
+  end;
+begin
+  Result := AWinControl.HandleAllocated; 
+  if Result then Exit;
+  Warn;
+end;
+
+end.