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