1{ $Id: wsimglist.pp 57164 2018-01-27 18:12:35Z ondrej $}
2{
3 *****************************************************************************
4 *                               WSImgList.pp                                *
5 *                               ------------                                *
6 *                                                                           *
7 *                                                                           *
8 *****************************************************************************
9
10 *****************************************************************************
11  This file is part of the Lazarus Component Library (LCL)
12
13  See the file COPYING.modifiedLGPL.txt, included in this distribution,
14  for details about the license.
15 *****************************************************************************
16}
17unit WSImgList;
18
19{$mode objfpc}{$H+}
20{$I lcl_defines.inc}
21
22interface
23////////////////////////////////////////////////////
24// I M P O R T A N T
25////////////////////////////////////////////////////
26// 1) Only class methods allowed
27// 2) Class methods have to be published and virtual
28// 3) To get as little as posible circles, the uses
29//    clause should contain only those LCL units
30//    needed for registration. WSxxx units are OK
31// 4) To improve speed, register only classes in the
32//    initialization section which actually
33//    implement something
34// 5) To enable your XXX widgetset units, look at
35//    the uses clause of the XXXintf.pp
36////////////////////////////////////////////////////
37uses
38  Classes, GraphType, Graphics, IntfGraphics, ImgList, LCLType, LCLIntf,
39  WSLCLClasses, WSProc, WSReferences, WSFactory;
40
41type
42  { TWSCustomImageListResolution }
43
44  TWSCustomImageListResolution = class(TWSLCLReferenceComponent)
45  published
46    class procedure Clear(AList: TCustomImageListResolution); virtual;
47    class function  CreateReference(AList: TCustomImageListResolution; ACount, AGrow, AWidth,
48      AHeight: Integer; AData: PRGBAQuad): TWSCustomImageListReference; virtual;
49
50    class procedure Delete(AList: TCustomImageListResolution; AIndex: Integer); virtual;
51    class procedure DestroyReference(AComponent: TComponent); override;
52    class procedure Draw(AList: TCustomImageListResolution; AIndex: Integer; ACanvas: TCanvas;
53      ABounds: TRect; ABkColor, ABlendColor: TColor; ADrawEffect: TGraphicsDrawEffect; AStyle: TDrawingStyle; AImageType: TImageType); virtual;
54
55    class procedure Insert(AList: TCustomImageListResolution; AIndex: Integer; AData: PRGBAQuad); virtual;
56
57    class procedure Move(AList: TCustomImageListResolution; ACurIndex, ANewIndex: Integer); virtual;
58
59    class procedure Replace(AList: TCustomImageListResolution; AIndex: Integer; AData: PRGBAQuad); virtual;
60  end;
61  TWSCustomImageListResolutionClass = class of TWSCustomImageListResolution;
62
63  procedure RegisterCustomImageListResolution;
64
65implementation
66
67type
68
69  { TDefaultImageListImplementor }
70
71  // Dont use TObjectList due to a bug in it (fixed in fpc > 2.2.2)
72  TDefaultImageListImplementor = class(TList)
73  private
74    FList: TCustomImageListResolution;
75  protected
76    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
77  public
78    constructor Create(AList: TCustomImageListResolution); reintroduce;
79    procedure Draw(AIndex: Integer; ACanvas: TCanvas; ABounds: TRect; ADrawEffect: TGraphicsDrawEffect; AStyle: TDrawingStyle);
80  end;
81
82{ TDefaultImageListImplementor }
83
84procedure TDefaultImageListImplementor.Notify(Ptr: Pointer;
85  Action: TListNotification);
86begin
87  if Action = lnDeleted then
88    TBitmap(Ptr).Free;
89  inherited Notify(Ptr, Action);
90end;
91
92constructor TDefaultImageListImplementor.Create(AList: TCustomImageListResolution);
93begin
94  inherited Create;
95  FList := AList;
96end;
97
98procedure TDefaultImageListImplementor.Draw(AIndex: Integer; ACanvas: TCanvas;
99  ABounds: TRect; ADrawEffect: TGraphicsDrawEffect; AStyle: TDrawingStyle);
100var
101  ABitmap: TBitmap;
102  RawImg: TRawImage;
103  ListImg, DeviceImg: TLazIntfImage;
104  ImgHandle, MskHandle: HBitmap;
105begin
106  if (AIndex < 0) or (AIndex >= Count) then Exit;
107  if ADrawEffect = gdeNormal then
108  begin
109    ABitmap := TBitmap(Items[AIndex]);
110    ACanvas.Draw(ABounds.Left, ABounds.Top, ABitmap);
111  end
112  else
113  begin
114    FList.GetRawImage(AIndex, RawImg);
115    RawImg.PerformEffect(ADrawEffect, True);
116
117    ABitmap := TBitmap.Create;
118    if not CreateCompatibleBitmaps(RawImg, ImgHandle, MskHandle, True)
119    then begin
120      // bummer, the widgetset doesn't support our 32bit format, try device
121      ListImg := TLazIntfImage.Create(RawImg, False);
122      DeviceImg := TLazIntfImage.Create(0, 0, []);
123      DeviceImg.DataDescription := GetDescriptionFromDevice(0, FList.Width, FList.Height);
124      DeviceImg.CopyPixels(ListImg);
125      DeviceImg.GetRawImage(RawImg);
126      RawImage_CreateBitmaps(RawImg, ImgHandle, MskHandle);
127      DeviceImg.Free;
128      ListImg.Free;
129    end;
130    ABitmap.SetHandles(ImgHandle, MskHandle);
131    ACanvas.Draw(ABounds.Left, ABounds.Top, ABitmap);
132    ABitmap.Free;
133    RawImg.FreeData;
134  end;
135end;
136
137function InternalCreateBitmap(AList: TCustomImageListResolution; AWidth, AHeight: Integer; AData: PRGBAQuad): TBitmap;
138var
139  hbmImage, hbmMask: HBitmap;
140  RawImg: TRawImage;
141begin
142  FillChar(RawImg, SizeOf(RawImg), 0);
143  AList.FillDescription(RawImg.Description);
144  RawImg.DataSize := AWidth * AHeight * SizeOF(AData[0]);
145  RawImg.Data := PByte(AData);
146
147  CreateCompatibleBitmaps(RawImg, hbmImage, hbmMask);
148  //RawImage_CreateBitmaps(RawImg, hbmImage, hbmMask);
149  Result := TBitmap.Create;
150  Result.SetHandles(hbmImage, hbmMask);
151end;
152
153
154{ TWSCustomImageListResolution }
155
156class procedure TWSCustomImageListResolution.Clear(AList: TCustomImageListResolution);
157begin
158  if not WSCheckReferenceAllocated(AList, 'Clear')
159  then Exit;
160  TDefaultImageListImplementor(AList.Reference.Ptr).Clear;
161end;
162
163class function TWSCustomImageListResolution.CreateReference(
164  AList: TCustomImageListResolution; ACount, AGrow, AWidth, AHeight: Integer;
165  AData: PRGBAQuad): TWSCustomImageListReference;
166var
167  impl: TDefaultImageListImplementor;
168
169  ABitmap: TBitmap;
170  i: integer;
171begin
172  impl := TDefaultImageListImplementor.Create(AList);
173  Result{%H-}._Init(impl);
174
175  if AData <> nil then
176  begin
177    // this is very slow method :(
178    for i := 0 to ACount - 1 do
179    begin
180      ABitmap := InternalCreateBitmap(AList, AWidth, AHeight, @AData[AWidth * AHeight * i]);
181      impl.Add(ABitmap);
182    end;
183  end;
184end;
185
186class procedure TWSCustomImageListResolution.Delete(AList: TCustomImageListResolution;
187  AIndex: Integer);
188begin
189  if not WSCheckReferenceAllocated(AList, 'Delete')
190  then Exit;
191  TDefaultImageListImplementor(AList.Reference.Ptr).Delete(AIndex);
192end;
193
194class procedure TWSCustomImageListResolution.DestroyReference(AComponent: TComponent);
195begin
196  if not WSCheckReferenceAllocated(TCustomImageListResolution(AComponent), 'DestroyReference')
197  then Exit;
198  TObject(TCustomImageListResolution(AComponent).Reference.Ptr).Free;
199end;
200
201class procedure TWSCustomImageListResolution.Draw(AList: TCustomImageListResolution;
202  AIndex: Integer; ACanvas: TCanvas; ABounds: TRect; ABkColor,
203  ABlendColor: TColor; ADrawEffect: TGraphicsDrawEffect; AStyle: TDrawingStyle;
204  AImageType: TImageType);
205begin
206  if not WSCheckReferenceAllocated(AList, 'Draw')
207  then Exit;
208
209  TDefaultImageListImplementor(AList.Reference.Ptr).Draw(AIndex, ACanvas, ABounds, ADrawEffect, AStyle);
210end;
211
212class procedure TWSCustomImageListResolution.Insert(AList: TCustomImageListResolution;
213  AIndex: Integer; AData: PRGBAQuad);
214var
215  AImageList: TDefaultImageListImplementor;
216  ACount: Integer;
217  ABitmap: TBitmap;
218begin
219  if not WSCheckReferenceAllocated(AList, 'Insert')
220  then Exit;
221
222  AImageList := TDefaultImageListImplementor(AList.Reference.Ptr);
223  ACount := AImageList.Count;
224
225  if (AIndex <= ACount) and (AIndex >= 0) then
226  begin
227    ABitmap := InternalCreateBitmap(AList, AList.Width, AList.Height, AData);
228    AImageList.Add(ABitmap);
229    if AIndex <> ACount then
230      Move(AList, ACount, AIndex);
231  end;
232end;
233
234class procedure TWSCustomImageListResolution.Move(AList: TCustomImageListResolution;
235  ACurIndex, ANewIndex: Integer);
236begin
237  if not WSCheckReferenceAllocated(AList, 'Move')
238  then Exit;
239
240  if ACurIndex = ANewIndex
241  then Exit;
242
243  TDefaultImageListImplementor(AList.Reference.Ptr).Move(ACurIndex, ANewIndex);
244end;
245
246class procedure TWSCustomImageListResolution.Replace(AList: TCustomImageListResolution;
247  AIndex: Integer; AData: PRGBAQuad);
248var
249  ABitmap: TBitmap;
250begin
251  if not WSCheckReferenceAllocated(AList, 'Replace')
252  then Exit;
253
254  ABitmap := InternalCreateBitmap(AList, AList.Width, AList.Height, AData);
255  TDefaultImageListImplementor(AList.Reference.Ptr)[AIndex] := ABitmap;
256end;
257
258{ WidgetSetRegistration }
259
260procedure RegisterCustomImageListResolution;
261const
262  Done: Boolean = False;
263begin
264  if Done then exit;
265  if not WSRegisterCustomImageListResolution then
266    RegisterWSComponent(TCustomImageListResolution, TWSCustomImageListResolution);
267  Done := True;
268end;
269
270end.
271