source: trunk/Packages/bgrabitmap/bgralclbitmap.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 32.6 KB
Line 
1unit BGRALCLBitmap;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, Graphics, GraphType, BGRABitmapTypes, BGRADefaultBitmap;
9
10type
11 { TBGRALCLBitmap }
12
13 TBGRALCLBitmap = class(TBGRADefaultBitmap)
14 protected
15 function LoadFromRawImage(ARawImage: TRawImage; DefaultOpacity: byte;
16 AlwaysReplaceAlpha: boolean = False; RaiseErrorOnInvalidPixelFormat: boolean = True): boolean; override;
17 function CreateDefaultFontRenderer: TBGRACustomFontRenderer; override;
18 procedure DoLoadFromBitmap; override;
19 procedure RebuildBitmap; override;
20 function CreatePtrBitmap(AWidth, AHeight: integer; AData: PBGRAPixel
21 ): TBGRAPtrBitmap; override;
22 procedure AssignRasterImage(ARaster: TRasterImage); virtual;
23 procedure ExtractXorMask;
24 public
25 procedure Assign(Source: TPersistent); override;
26 procedure LoadFromResource(AFilename: string; AOptions: TBGRALoadingOptions); overload; override;
27 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
28 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
29 procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
30 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
31 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
32 procedure LoadFromDevice({%H-}DC: HDC); override;
33 procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override;
34 procedure TakeScreenshotOfPrimaryMonitor; override;
35 procedure TakeScreenshot({%H-}ARect: TRect); override;
36 end;
37
38 { TBGRALCLPtrBitmap }
39
40 TBGRALCLPtrBitmap = class(TBGRAPtrBitmap)
41
42 procedure RebuildBitmap; override;
43 function CreatePtrBitmap(AWidth, AHeight: integer; AData: PBGRAPixel): TBGRAPtrBitmap; override;
44 function CreateDefaultFontRenderer: TBGRACustomFontRenderer; override;
45 function LoadFromRawImage(ARawImage: TRawImage; DefaultOpacity: byte;
46 AlwaysReplaceAlpha: boolean=False; {%H-}RaiseErrorOnInvalidPixelFormat: boolean
47 =True): boolean; override;
48 public
49 procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
50 procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
51 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
52 procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
53 ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
54 end;
55
56implementation
57
58uses Types, BGRAText, LCLType, LCLIntf, FPimage;
59
60type
61 TCopyPixelProc = procedure (psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
62
63procedure ApplyMask1bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
64var currentBit: byte;
65begin
66 currentBit := 1;
67 while count > 0 do
68 begin
69 if psrc^ and currentBit <> 0 then pdest^.alpha := 0;
70 inc(pdest);
71 if currentBit = 128 then
72 begin
73 currentBit := 1;
74 inc(psrc);
75 end else
76 currentBit := currentBit shl 1;
77 dec(count);
78 end;
79end;
80
81procedure ApplyMask1bitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
82var currentBit: byte;
83begin
84 currentBit := 128;
85 while count > 0 do
86 begin
87 if psrc^ and currentBit <> 0 then pdest^.alpha := 0;
88 inc(pdest);
89 if currentBit = 1 then
90 begin
91 currentBit := 128;
92 inc(psrc);
93 end else
94 currentBit := currentBit shr 1;
95 dec(count);
96 end;
97end;
98
99procedure CopyFromBW_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte);
100var currentBit: byte;
101begin
102 currentBit := 1;
103 while count > 0 do
104 begin
105 if psrc^ and currentBit <> 0 then
106 pdest^ := BGRAWhite
107 else
108 pdest^ := BGRABlack;
109 pdest^.alpha := DefaultOpacity;
110 inc(pdest);
111 if currentBit = 128 then
112 begin
113 currentBit := 1;
114 inc(psrc);
115 end else
116 currentBit := currentBit shl 1;
117 dec(count);
118 end;
119end;
120
121procedure CopyFromBW_SetAlphaBitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte);
122var currentBit: byte;
123begin
124 currentBit := 128;
125 while count > 0 do
126 begin
127 if psrc^ and currentBit <> 0 then
128 pdest^ := BGRAWhite
129 else
130 pdest^ := BGRABlack;
131 pdest^.alpha := DefaultOpacity;
132 inc(pdest);
133 if currentBit = 1 then
134 begin
135 currentBit := 128;
136 inc(psrc);
137 end else
138 currentBit := currentBit shr 1;
139 dec(count);
140 end;
141end;
142
143procedure CopyFrom24Bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
144begin
145 while count > 0 do
146 begin
147 PWord(pdest)^ := PWord(psrc)^;
148 (PByte(pdest)+2)^ := (psrc+2)^;
149 pdest^.alpha := DefaultOpacity;
150 inc(psrc,sourcePixelSize);
151 inc(pdest);
152 dec(count);
153 end;
154end;
155
156procedure CopyFrom24Bit_SwapRedBlue(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
157begin
158 while count > 0 do
159 begin
160 PByte(pdest)^ := (psrc+2)^;
161 (PByte(pdest)+1)^ := (psrc+1)^;
162 (PByte(pdest)+2)^ := psrc^;
163 pdest^.alpha := DefaultOpacity;
164 inc(psrc,sourcePixelSize);
165 inc(pdest);
166 dec(count);
167 end;
168end;
169
170procedure CopyFromARGB_KeepAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
171begin
172 while count > 0 do
173 begin
174 PDWord(pdest)^ := ((PByte(psrc)+3)^ shl TBGRAPixel_BlueShift) or
175 ((PByte(psrc)+2)^ shl TBGRAPixel_GreenShift) or
176 ((PByte(psrc)+1)^ shl TBGRAPixel_RedShift) or
177 (PByte(psrc)^ shl TBGRAPixel_AlphaShift);
178 dec(count);
179 inc(pdest);
180 inc(psrc, sourcePixelSize);
181 end;
182end;
183
184procedure CopyFromARGB_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
185begin
186 while count > 0 do
187 begin
188 PDWord(pdest)^ := ((PByte(psrc)+3)^ shl TBGRAPixel_BlueShift) or
189 ((PByte(psrc)+2)^ shl TBGRAPixel_GreenShift) or
190 ((PByte(psrc)+1)^ shl TBGRAPixel_RedShift) or
191 (DefaultOpacity shl TBGRAPixel_AlphaShift);
192 inc(psrc, sourcePixelSize);
193 inc(pdest);
194 dec(count);
195 end;
196end;
197
198procedure CopyFromARGB_ReplaceZeroAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
199const ARGB_ColorMask = {$IFDEF ENDIAN_LITTLE}$FFFFFF00{$ELSE}$00FFFFFF{$ENDIF};
200 ARGB_RedShift = {$IFDEF ENDIAN_LITTLE}8{$ELSE}16{$ENDIF};
201 ARGB_GreenShift = {$IFDEF ENDIAN_LITTLE}16{$ELSE}8{$ENDIF};
202 ARGB_BlueShift = {$IFDEF ENDIAN_LITTLE}24{$ELSE}0{$ENDIF};
203var
204 sourceval: NativeUint;
205 alphaValue: NativeUint;
206 OpacityOrMask: NativeUint;
207begin
208 OpacityOrMask := DefaultOpacity shl TBGRAPixel_AlphaShift;
209 while count > 0 do
210 begin
211 sourceval := plongword(psrc)^;
212 alphaValue := {$IFDEF ENDIAN_LITTLE}sourceval and $ff{$ELSE}sourceval shr 24{$ENDIF};
213 if (alphaValue = 0) and ((sourceval and ARGB_ColorMask) <> 0) then //if not black but transparent
214 begin
215 PDWord(pdest)^ := (((sourceval shr ARGB_BlueShift) and $ff) shl TBGRAPixel_BlueShift) or
216 (((sourceval shr ARGB_GreenShift) and $ff) shl TBGRAPixel_GreenShift) or
217 (((sourceval shr ARGB_RedShift) and $ff) shl TBGRAPixel_RedShift) or
218 OpacityOrMask;
219 end else
220 begin
221 PDWord(pdest)^ := (((sourceval shr ARGB_BlueShift) and $ff) shl TBGRAPixel_BlueShift) or
222 (((sourceval shr ARGB_GreenShift) and $ff) shl TBGRAPixel_GreenShift) or
223 (((sourceval shr ARGB_RedShift) and $ff) shl TBGRAPixel_RedShift) or
224 (alphaValue shl TBGRAPixel_AlphaShift);
225 end;
226 dec(count);
227 inc(pdest);
228 inc(psrc, sourcePixelSize);
229 end;
230end;
231
232const
233 BGRA_AlphaMask = 255 shl TBGRAPixel_AlphaShift;
234 BGRA_RedMask = 255 shl TBGRAPixel_RedShift;
235 BGRA_GreenMask = 255 shl TBGRAPixel_GreenShift;
236 BGRA_BlueMask = 255 shl TBGRAPixel_BlueShift;
237 BGRA_ColorMask = BGRA_RedMask or BGRA_GreenMask or BGRA_BlueMask;
238
239procedure CopyFrom32Bit_KeepAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
240begin
241 if sourcePixelSize = 4 then
242 move(psrc^,pdest^,count*sizeof(TBGRAPixel))
243 else
244 begin
245 while count > 0 do
246 begin
247 PDWord(pdest)^ := PDWord(psrc)^;
248 dec(count);
249 inc(pdest);
250 inc(psrc, sourcePixelSize);
251 end;
252 end;
253end;
254
255procedure CopyFrom32Bit_SwapRedBlue_KeepAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
256var srcValue: NativeUInt;
257begin
258 while count > 0 do
259 begin
260 srcValue := PDWord(psrc)^;
261 PDWord(pdest)^ := (srcValue and not (BGRA_RedMask or BGRA_BlueMask))
262 or (((srcValue and BGRA_RedMask) shr TBGRAPixel_RedShift) shl TBGRAPixel_BlueShift)
263 or (((srcValue and BGRA_BlueMask) shr TBGRAPixel_BlueShift) shl TBGRAPixel_RedShift);
264 dec(count);
265 inc(pdest);
266 inc(psrc, sourcePixelSize);
267 end;
268end;
269
270procedure CopyFrom32Bit_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
271var
272 OpacityOrMask: NativeUInt;
273begin
274 OpacityOrMask := DefaultOpacity shl TBGRAPixel_AlphaShift;
275 while count > 0 do
276 begin
277 PDWord(pdest)^ := (PDWord(psrc)^ and not BGRA_AlphaMask) or OpacityOrMask;
278 inc(psrc, sourcePixelSize);
279 inc(pdest);
280 dec(count);
281 end;
282end;
283
284procedure CopyFrom32Bit_SwapRedBlue_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
285begin
286 while count > 0 do
287 begin
288 pdest^.red := PBGRAPixel(psrc)^.blue;
289 pdest^.green := PBGRAPixel(psrc)^.green;
290 pdest^.blue := PBGRAPixel(psrc)^.red;
291 pdest^.alpha := DefaultOpacity; //use default opacity
292 inc(psrc, sourcePixelSize);
293 inc(pdest);
294 dec(count);
295 end;
296end;
297
298procedure CopyFrom32Bit_ReplaceZeroAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
299var sourceval: NativeUInt;
300 OpacityOrMask : NativeUInt;
301begin
302 OpacityOrMask := DefaultOpacity shl TBGRAPixel_AlphaShift;
303 while count > 0 do
304 begin
305 sourceval := plongword(psrc)^;
306 if ((sourceVal shr TBGRAPixel_AlphaShift) and $ff = 0) and ((sourceval and BGRA_ColorMask) <> 0) then //if not black but transparent
307 plongword(pdest)^ := (sourceval and BGRA_ColorMask) or OpacityOrMask //use default opacity
308 else
309 plongword(pdest)^ := plongword(psrc)^;
310 dec(count);
311 inc(pdest);
312 inc(psrc, sourcePixelSize);
313 end;
314end;
315
316procedure CopyFrom32Bit_SwapRedBlue_ReplaceZeroAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
317var sourceval: NativeUInt;
318 OpacityOrMask : NativeUInt;
319begin
320 OpacityOrMask := DefaultOpacity shl TBGRAPixel_AlphaShift;
321 while count > 0 do
322 begin
323 sourceval := plongword(psrc)^;
324 if ((sourceVal shr TBGRAPixel_AlphaShift) and $ff = 0) and ((sourceval and BGRA_ColorMask) <> 0) then //if not black but transparent
325 plongword(pdest)^ := (((sourceval and BGRA_RedMask) shr TBGRAPixel_RedShift) shl TBGRAPixel_BlueShift)
326 or (((sourceval and BGRA_BlueMask) shr TBGRAPixel_BlueShift) shl TBGRAPixel_RedShift)
327 or (sourceval and BGRA_GreenMask)
328 or OpacityOrMask
329 else
330 plongword(pdest)^ := (((sourceval and BGRA_RedMask) shr TBGRAPixel_RedShift) shl TBGRAPixel_BlueShift)
331 or (((sourceval and BGRA_BlueMask) shr TBGRAPixel_BlueShift) shl TBGRAPixel_RedShift)
332 or (sourceval and (BGRA_GreenMask or BGRA_AlphaMask));
333 dec(count);
334 inc(pdest);
335 inc(psrc, sourcePixelSize);
336 end;
337end;
338
339procedure DoCopyProc(ADestination: TBGRACustomBitmap; ACopyProc: TCopyPixelProc; AData: PByte; ABytesPerLine, ABitsPerPixel: integer; ALineOrder: TRawImageLineOrder; ADefaultOpacity: byte);
340var
341 n: integer;
342 psource_byte, pdest_byte,
343 psource_first, pdest_first: PByte;
344 psource_delta, pdest_delta: integer;
345begin
346 if (ALineOrder = ADestination.LineOrder) and
347 (ABytesPerLine = (ABitsPerPixel shr 3) * cardinal(ADestination.Width)) then
348 ACopyProc(AData, ADestination.Data, ADestination.NbPixels, ABitsPerPixel shr 3, ADefaultOpacity)
349 else
350 begin
351 if ALineOrder = riloTopToBottom then
352 begin
353 psource_first := AData;
354 psource_delta := ABytesPerLine;
355 end else
356 begin
357 psource_first := AData + (ADestination.Height-1) * ABytesPerLine;
358 psource_delta := -ABytesPerLine;
359 end;
360
361 if ADestination.LineOrder = riloTopToBottom then
362 begin
363 pdest_first := PByte(ADestination.Data);
364 pdest_delta := ADestination.Width*sizeof(TBGRAPixel);
365 end else
366 begin
367 pdest_first := PByte(ADestination.Data) + (ADestination.Height-1)*ADestination.Width*sizeof(TBGRAPixel);
368 pdest_delta := -ADestination.Width*sizeof(TBGRAPixel);
369 end;
370
371 psource_byte := psource_first;
372 pdest_byte := pdest_first;
373 for n := ADestination.Height-1 downto 0 do
374 begin
375 ACopyProc(psource_byte, PBGRAPixel(pdest_byte), ADestination.Width, ABitsPerPixel shr 3, ADefaultOpacity);
376 inc(psource_byte, psource_delta);
377 inc(pdest_byte, pdest_delta);
378 end;
379 end;
380end;
381
382procedure ApplyRawImageMask(ADestination: TBGRACustomBitmap; const ARawImage: TRawImage);
383var
384 copyProc: TCopyPixelProc;
385begin
386 if (ARawImage.Description.MaskBitsPerPixel = 1) and (ARawImage.Mask <> nil) then
387 begin
388 if ARawImage.Description.BitOrder = riboBitsInOrder then
389 copyProc := @ApplyMask1bit
390 else
391 copyProc := @ApplyMask1bitRev;
392 DoCopyProc(ADestination, copyProc, ARawImage.Mask, ARawImage.Description.MaskBytesPerLine, ARawImage.Description.MaskBitsPerPixel, ARawImage.Description.LineOrder, 0);
393 ADestination.InvalidateBitmap;
394 end;
395end;
396
397{ Load raw image data. It must be 32bit, 24 bits or 1bit per pixel}
398function LoadFromRawImageImplementation(ADestination: TBGRADefaultBitmap; const ARawImage: TRawImage;
399 DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean;
400var
401 mustSwapRedBlue: boolean;
402 copyProc: TCopyPixelProc;
403 nbColorChannels: integer;
404
405 function FormatError(message: string): boolean;
406 begin
407 if RaiseErrorOnInvalidPixelFormat then
408 raise Exception.Create('Invalid raw image format. ' + message)
409 else
410 result := false;
411 end;
412
413begin
414 if (ARawImage.Description.Width <> cardinal(ADestination.Width)) or
415 (ARawImage.Description.Height <> cardinal(ADestination.Height)) then
416 raise Exception.Create('Bitmap size is inconsistant');
417
418 if (ADestination.Height=0) or (ADestination.Width=0) then
419 begin
420 result := true;
421 exit;
422 end;
423
424 if ARawImage.Description.BitsPerPixel = 1 then
425 begin
426 if ARawImage.Description.BitOrder = riboBitsInOrder then
427 copyProc := @CopyFromBW_SetAlpha
428 else
429 copyProc := @CopyFromBW_SetAlphaBitRev;
430 DefaultOpacity := 255;
431 end else
432 begin
433 if ((ARawImage.Description.BitsPerPixel and 7) <> 0) then
434 begin
435 result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but multiple of 8bit expected');
436 exit;
437 end;
438
439 if (ARawImage.Description.BitsPerPixel < 24) then
440 begin
441 result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but at least 24bit expected');
442 exit;
443 end;
444
445 nbColorChannels := 0;
446 if (ARawImage.Description.RedPrec > 0) then inc(nbColorChannels);
447 if (ARawImage.Description.GreenPrec > 0) then inc(nbColorChannels);
448 if (ARawImage.Description.BluePrec > 0) then inc(nbColorChannels);
449
450 if (nbColorChannels < 3) then
451 begin
452 result := FormatError('One or more color channel is missing (RGB expected)');
453 exit;
454 end;
455
456 //channels are in ARGB order
457 if (ARawImage.Description.BitsPerPixel >= 32) and
458 (ARawImage.Description.AlphaPrec = 8) and
459 (((ARawImage.Description.AlphaShift = 0) and
460 (ARawImage.Description.RedShift = 8) and
461 (ARawImage.Description.GreenShift = 16) and
462 (ARawImage.Description.BlueShift = 24) and
463 (ARawImage.Description.ByteOrder = riboLSBFirst)) or
464 ((ARawImage.Description.AlphaShift = ARawImage.Description.BitsPerPixel - 8) and
465 (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
466 (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
467 (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
468 (ARawImage.Description.ByteOrder = riboMSBFirst))) then
469 begin
470 if AlwaysReplaceAlpha then
471 copyProc := @CopyFromARGB_SetAlpha
472 else if DefaultOpacity = 0 then
473 copyProc := @CopyFromARGB_KeepAlpha
474 else
475 copyProc := @CopyFromARGB_ReplaceZeroAlpha;
476 end
477 else //channels are in ARGB order but alpha is not used
478 if (ARawImage.Description.BitsPerPixel >= 32) and
479 (ARawImage.Description.AlphaPrec = 0) and
480 (((ARawImage.Description.RedShift = 8) and
481 (ARawImage.Description.GreenShift = 16) and
482 (ARawImage.Description.BlueShift = 24) and
483 (ARawImage.Description.ByteOrder = riboLSBFirst)) or
484 ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
485 (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
486 (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
487 (ARawImage.Description.ByteOrder = riboMSBFirst))) then
488 begin
489 DefaultOpacity := 255;
490 copyProc := @CopyFromARGB_SetAlpha;
491 end
492 else
493 begin
494 //channels are in RGB order (alpha channel may follow)
495 if (ARawImage.Description.BitsPerPixel >= 24) and
496 (((ARawImage.Description.RedShift = 0) and
497 (ARawImage.Description.GreenShift = 8) and
498 (ARawImage.Description.BlueShift = 16) and
499 (ARawImage.Description.ByteOrder = riboLSBFirst)) or
500 ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 8) and
501 (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
502 (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 24) and
503 (ARawImage.Description.ByteOrder = riboMSBFirst))) then
504 begin
505 mustSwapRedBlue:= not TBGRAPixel_RGBAOrder;
506 end
507 else
508 //channels are in BGR order (alpha channel may follow)
509 if (ARawImage.Description.BitsPerPixel >= 24) and
510 (((ARawImage.Description.BlueShift = 0) and
511 (ARawImage.Description.GreenShift = 8) and
512 (ARawImage.Description.RedShift = 16) and
513 (ARawImage.Description.ByteOrder = riboLSBFirst)) or
514 ((ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 8) and
515 (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
516 (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 24) and
517 (ARawImage.Description.ByteOrder = riboMSBFirst))) then
518 begin
519 mustSwapRedBlue:= TBGRAPixel_RGBAOrder;
520 end
521 else
522 begin
523 result := FormatError('BitsPerPixel: ' + IntToStr(ARawImage.Description.BitsPerPixel) + ', '
524 + 'RedShit: ' + IntToStr(ARawImage.Description.RedShift) + ', Prec: ' + IntToStr(ARawImage.Description.RedPrec)+ ', '
525 + 'GreenShit: ' + IntToStr(ARawImage.Description.GreenShift) + ', Prec: ' + IntToStr(ARawImage.Description.GreenPrec)+ ', '
526 + 'BlueShift: ' + IntToStr(ARawImage.Description.BlueShift) + ', Prec: ' + IntToStr(ARawImage.Description.BluePrec)+ ', '
527 + 'AlphaShift: ' + IntToStr(ARawImage.Description.AlphaShift) + ', Prec: ' + IntToStr(ARawImage.Description.AlphaPrec) );
528 exit;
529 end;
530
531 if not mustSwapRedBlue then
532 begin
533 if ARawImage.Description.BitsPerPixel = 24 then
534 copyProc := @CopyFrom24Bit
535 else
536 if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
537 copyProc := @CopyFrom32Bit_SetAlpha
538 else if DefaultOpacity = 0 then
539 copyProc := @CopyFrom32Bit_KeepAlpha
540 else
541 copyProc := @CopyFrom32Bit_ReplaceZeroAlpha;
542 end else
543 begin
544 if ARawImage.Description.BitsPerPixel = 24 then
545 copyProc := @CopyFrom24Bit_SwapRedBlue
546 else
547 if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
548 copyProc := @CopyFrom32Bit_SwapRedBlue_SetAlpha
549 else if DefaultOpacity = 0 then
550 copyProc := @CopyFrom32Bit_SwapRedBlue_KeepAlpha
551 else
552 copyProc := @CopyFrom32Bit_SwapRedBlue_ReplaceZeroAlpha;
553 end;
554 end;
555 end;
556
557 DoCopyProc(ADestination, copyProc, ARawImage.Data, ARawImage.Description.BytesPerLine, ARawImage.Description.BitsPerPixel, ARawImage.Description.LineOrder, DefaultOpacity);
558 ADestination.InvalidateBitmap;
559
560 ApplyRawImageMask(ADestination, ARawImage);
561 result := true;
562end;
563
564{ Draw BGRA data to a canvas with transparency }
565procedure DataDrawTransparentImplementation(ACanvas: TCanvas; Rect: TRect;
566 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
567var
568 Temp: TBitmap;
569 RawImage: TRawImage;
570 BitmapHandle, MaskHandle: HBitmap;
571begin
572 RawImage.Init;
573 RawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(AWidth, AHeight);
574 RawImage.Description.LineOrder := ALineOrder;
575 RawImage.Data := PByte(AData);
576 RawImage.DataSize := AWidth * AHeight * sizeof(TBGRAPixel);
577 if not RawImage_CreateBitmaps(RawImage, BitmapHandle, MaskHandle, False) then
578 raise FPImageException.Create('Failed to create bitmap handle');
579 Temp := TBitmap.Create;
580 Temp.Handle := BitmapHandle;
581 Temp.MaskHandle := MaskHandle;
582 ACanvas.StretchDraw(Rect, Temp);
583 Temp.Free;
584end;
585
586{ Draw BGRA data to a canvas without transparency }
587procedure DataDrawOpaqueImplementation(ACanvas: TCanvas; Rect: TRect;
588 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
589var
590 Temp: TBitmap;
591 RawImage: TRawImage;
592 BitmapHandle, MaskHandle: HBitmap;
593 CreateResult: boolean;
594 tempShift: byte;
595begin
596 if (AHeight = 0) or (AWidth = 0) then
597 exit;
598
599 RawImage.Init;
600 RawImage.Description.Init_BPP32_B8G8R8_BIO_TTB(AWidth,AHeight);
601 RawImage.Description.LineOrder := ALineOrder;
602 RawImage.Description.LineEnd := rileDWordBoundary;
603 RawImage.Data := PByte(AData);
604 RawImage.DataSize:= AWidth*AHeight*sizeof(TBGRAPixel);
605 if TBGRAPixel_RGBAOrder then
606 begin
607 tempShift := RawImage.Description.RedShift;
608 RawImage.Description.RedShift := RawImage.Description.BlueShift;
609 RawImage.Description.BlueShift := tempShift;
610 end;
611 CreateResult := RawImage_CreateBitmaps(RawImage, BitmapHandle, MaskHandle, False);
612
613 if not CreateResult then
614 raise FPImageException.Create('Failed to create bitmap handle');
615
616 Temp := TBitmap.Create;
617 Temp.Handle := BitmapHandle;
618 Temp.MaskHandle := MaskHandle;
619 ACanvas.StretchDraw(Rect, Temp);
620 Temp.Free;
621end;
622
623procedure GetImageFromCanvasImplementation(ADestination: TBGRADefaultBitmap; CanvasSource: TCanvas; x, y: integer);
624var
625 bmp: TBitmap;
626 subBmp: TBGRACustomBitmap;
627 subRect: TRect;
628 cw,ch: integer;
629begin
630 cw := CanvasSource.Width;
631 ch := CanvasSource.Height;
632 if (x < 0) or (y < 0) or (x+ADestination.Width > cw) or
633 (y+ADestination.Height > ch) then
634 begin
635 ADestination.FillTransparent;
636 if (x+ADestination.Width <= 0) or (y+ADestination.Height <= 0) or
637 (x >= cw) or (y >= ch) then
638 exit;
639
640 if (x > 0) then subRect.Left := x else subRect.Left := 0;
641 if (y > 0) then subRect.Top := y else subRect.Top := 0;
642 if (x+ADestination.Width > cw) then subRect.Right := cw else
643 subRect.Right := x+ADestination.Width;
644 if (y+ADestination.Height > ch) then subRect.Bottom := ch else
645 subRect.Bottom := y+ADestination.Height;
646
647 subBmp := ADestination.NewBitmap(subRect.Right-subRect.Left,subRect.Bottom-subRect.Top);
648 subBmp.GetImageFromCanvas(CanvasSource,subRect.Left,subRect.Top);
649 ADestination.PutImage(subRect.Left-x,subRect.Top-y,subBmp,dmSet);
650 subBmp.Free;
651 exit;
652 end;
653 bmp := TBitmap.Create;
654 bmp.PixelFormat := pf24bit;
655 bmp.Width := ADestination.Width;
656 bmp.Height := ADestination.Height;
657 bmp.Canvas.CopyRect(Classes.rect(0, 0, ADestination.Width, ADestination.Height), CanvasSource,
658 Classes.rect(x, y, x + ADestination.Width, y + ADestination.Height));
659 LoadFromRawImageImplementation(ADestination, bmp.RawImage, 255, True, False);
660 bmp.Free;
661 ADestination.InvalidateBitmap;
662end;
663
664{ TBGRALCLPtrBitmap }
665
666procedure TBGRALCLPtrBitmap.RebuildBitmap;
667var
668 RawImage: TRawImage;
669 BitmapHandle, MaskHandle: HBitmap;
670begin
671 if FBitmap <> nil then
672 FBitmap.Free;
673
674 FBitmap := TBitmapTracker.Create(self);
675
676 if (FWidth > 0) and (FHeight > 0) then
677 begin
678 RawImage.Init;
679 if TBGRAPixel_RGBAOrder then
680 RawImage.Description.Init_BPP32_R8G8B8A8_BIO_TTB(FWidth, FHeight)
681 else
682 RawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(FWidth, FHeight);
683 RawImage.Description.LineOrder := FLineOrder;
684 RawImage.Data := PByte(FData);
685 RawImage.DataSize := FWidth * FHeight * sizeof(TBGRAPixel);
686 if not RawImage_CreateBitmaps(RawImage, BitmapHandle, MaskHandle, False) then
687 raise FPImageException.Create('Failed to create bitmap handle');
688 FBitmap.Handle := BitmapHandle;
689 FBitmap.MaskHandle := MaskHandle;
690 end;
691
692 FBitmap.Canvas.AntialiasingMode := amOff;
693 FBitmapModified := False;
694end;
695
696function TBGRALCLPtrBitmap.CreatePtrBitmap(AWidth, AHeight: integer;
697 AData: PBGRAPixel): TBGRAPtrBitmap;
698begin
699 Result:= TBGRALCLPtrBitmap.Create(AWidth,AHeight,AData);
700end;
701
702function TBGRALCLPtrBitmap.CreateDefaultFontRenderer: TBGRACustomFontRenderer;
703begin
704 result := TLCLFontRenderer.Create;
705end;
706
707function TBGRALCLPtrBitmap.LoadFromRawImage(ARawImage: TRawImage;
708 DefaultOpacity: byte; AlwaysReplaceAlpha: boolean;
709 RaiseErrorOnInvalidPixelFormat: boolean): boolean;
710begin
711 DiscardBitmapChange;
712 result := LoadFromRawImageImplementation(self,ARawImage,DefaultOpacity,AlwaysReplaceAlpha,RaiseErrorOnInvalidPixelFormat);
713end;
714
715procedure TBGRALCLPtrBitmap.GetImageFromCanvas(CanvasSource: TCanvas; x,
716 y: integer);
717begin
718 DiscardBitmapChange;
719 GetImageFromCanvasImplementation(self,CanvasSource,x,y);
720end;
721
722procedure TBGRALCLPtrBitmap.DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
723 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
724begin
725 DataDrawTransparentImplementation(ACanvas, Rect, AData, ALineOrder, AWidth, AHeight);
726end;
727
728procedure TBGRALCLPtrBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
729 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
730begin
731 DataDrawOpaqueImplementation(ACanvas, Rect, AData, ALineOrder, AWidth, AHeight);
732end;
733
734function TBGRALCLBitmap.LoadFromRawImage(ARawImage: TRawImage;
735 DefaultOpacity: byte; AlwaysReplaceAlpha: boolean;
736 RaiseErrorOnInvalidPixelFormat: boolean): boolean;
737begin
738 DiscardBitmapChange;
739 result := LoadFromRawImageImplementation(self,ARawImage,DefaultOpacity,AlwaysReplaceAlpha,RaiseErrorOnInvalidPixelFormat);
740end;
741
742function TBGRALCLBitmap.CreateDefaultFontRenderer: TBGRACustomFontRenderer;
743begin
744 result := TLCLFontRenderer.Create;
745end;
746
747procedure TBGRALCLBitmap.DoLoadFromBitmap;
748begin
749 if FBitmap <> nil then
750 begin
751 LoadFromRawImage(FBitmap.RawImage, FCanvasOpacity);
752 if FAlphaCorrectionNeeded then DoAlphaCorrection;
753 end;
754end;
755
756procedure TBGRALCLBitmap.RebuildBitmap;
757var
758 RawImage: TRawImage;
759 BitmapHandle, MaskHandle: HBitmap;
760begin
761 if FBitmap <> nil then
762 FBitmap.Free;
763
764 FBitmap := TBitmapTracker.Create(self);
765
766 if (FWidth > 0) and (FHeight > 0) then
767 begin
768 RawImage.Init;
769 if TBGRAPixel_RGBAOrder then
770 RawImage.Description.Init_BPP32_R8G8B8A8_BIO_TTB(FWidth, FHeight)
771 else
772 RawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(FWidth, FHeight);
773 RawImage.Description.LineOrder := FLineOrder;
774 RawImage.Data := PByte(FData);
775 RawImage.DataSize := FWidth * FHeight * sizeof(TBGRAPixel);
776 if not RawImage_CreateBitmaps(RawImage, BitmapHandle, MaskHandle, False) then
777 raise FPImageException.Create('Failed to create bitmap handle');
778 FBitmap.Handle := BitmapHandle;
779 FBitmap.MaskHandle := MaskHandle;
780 end;
781
782 FBitmap.Canvas.AntialiasingMode := amOff;
783 FBitmapModified := False;
784 FAlphaCorrectionNeeded:= false;
785end;
786
787function TBGRALCLBitmap.CreatePtrBitmap(AWidth, AHeight: integer;
788 AData: PBGRAPixel): TBGRAPtrBitmap;
789begin
790 Result:= TBGRALCLPtrBitmap.Create(AWidth, AHeight, AData);
791end;
792
793procedure TBGRALCLBitmap.Assign(Source: TPersistent);
794begin
795 if Source is TRasterImage then
796 begin
797 AssignRasterImage(TRasterImage(Source));
798 end else
799 inherited Assign(Source);
800
801 if Source is TCursorImage then
802 begin
803 HotSpot := TCursorImage(Source).HotSpot;
804 ExtractXorMask;
805 end
806 else if Source is TIcon then
807 begin
808 HotSpot := Point(0,0);
809 ExtractXorMask;
810 end;
811end;
812
813procedure TBGRALCLBitmap.LoadFromResource(AFilename: string;
814 AOptions: TBGRALoadingOptions);
815var
816 icon: TCustomIcon;
817 ext: String;
818begin
819 if BGRAResource.IsWinResource(AFilename) then
820 begin
821 ext:= Uppercase(ExtractFileExt(AFilename));
822 if (ext = '.ICO') or (ext = '.CUR') then
823 begin
824 if ext= '.ICO' then icon := TIcon.Create
825 else icon := TCursorImage.Create;
826 try
827 icon.LoadFromResourceName(HInstance, ChangeFileExt(AFilename,''));
828 icon.Current:= icon.GetBestIndexForSize(Size(65536,65536));
829 self.AssignRasterImage(icon);
830 finally
831 icon.Free;
832 end;
833 exit;
834 end;
835 end;
836
837 inherited LoadFromResource(AFilename, AOptions);
838end;
839
840procedure TBGRALCLBitmap.AssignRasterImage(ARaster: TRasterImage);
841var TempBmp: TBitmap;
842begin
843 DiscardBitmapChange;
844 SetSize(ARaster.Width, ARaster.Height);
845 if LoadFromRawImage(ARaster.RawImage,0,False,False) then
846 begin
847 If Empty then
848 begin
849 AlphaFill(255); // if bitmap seems to be empty, assume
850 // it is an opaque bitmap without alpha channel
851 ApplyRawImageMask(self, ARaster.RawImage);
852 end;
853 end else
854 if (ARaster is TBitmap) or (ARaster is TCustomIcon) then
855 begin //try to convert
856 TempBmp := TBitmap.Create;
857 TempBmp.Width := ARaster.Width;
858 TempBmp.Height := ARaster.Height;
859 TempBmp.Canvas.Draw(0,0,ARaster);
860 try
861 LoadFromRawImage(TempBmp.RawImage,255,False,true);
862 ApplyRawImageMask(self, ARaster.RawImage);
863 finally
864 TempBmp.Free;
865 end;
866 end else
867 raise Exception.Create('Unable to convert image to 24 bit');
868end;
869
870procedure TBGRALCLBitmap.ExtractXorMask;
871var
872 y, x: Integer;
873 p: PBGRAPixel;
874begin
875 DiscardXorMask;
876 for y := 0 to Height-1 do
877 begin
878 p := ScanLine[y];
879 for x := 0 to Width-1 do
880 begin
881 if (p^.alpha = 0) and (PDWord(p)^<>0) then
882 begin
883 NeedXorMask;
884 XorMask.SetPixel(x,y, p^);
885 end;
886 inc(p);
887 end;
888 end;
889end;
890
891procedure TBGRALCLBitmap.DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
892 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
893begin
894 DataDrawTransparentImplementation(ACanvas, Rect, AData, ALineOrder, AWidth, AHeight);
895end;
896
897procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
898 AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
899begin
900 DataDrawOpaqueImplementation(ACanvas, ARect, AData, ALineOrder, AWidth, AHeight);
901end;
902
903procedure TBGRALCLBitmap.GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer
904 );
905begin
906 DiscardBitmapChange;
907 GetImageFromCanvasImplementation(self,CanvasSource,x,y);
908end;
909
910procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC);
911var
912 rawImage: TRawImage;
913 sourceSize: TPoint;
914begin
915 sourceSize := Point(0,0);
916 GetDeviceSize(DC, sourceSize);
917 if (sourceSize.x = 0) or (sourceSize.y = 0) then
918 begin
919 SetSize(0,0);
920 exit;
921 end;
922 try
923 if not RawImage_FromDevice(rawImage, DC, rect(0,0,sourceSize.x,sourceSize.y)) then
924 raise Exception.Create('Cannot get raw image from device');
925 SetSize(rawImage.Description.Width, rawImage.Description.Height);
926 LoadFromRawImage(rawImage,255);
927 finally
928 rawImage.FreeData;
929 end;
930end;
931
932procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
933var
934 rawImage: TRawImage;
935begin
936 if (ARect.Right <= ARect.Left) or (ARect.Bottom <= ARect.Top) then
937 begin
938 SetSize(0,0);
939 exit;
940 end;
941 try
942 if not RawImage_FromDevice(rawImage, DC, ARect) then
943 raise Exception.Create('Cannot get raw image from device');
944 SetSize(rawImage.Description.Width, rawImage.Description.Height);
945 LoadFromRawImage(rawImage,255);
946 finally
947 rawImage.FreeData;
948 end;
949end;
950
951procedure TBGRALCLBitmap.TakeScreenshotOfPrimaryMonitor;
952var primaryDC: THandle;
953begin
954 primaryDC := LCLIntf.GetDC(0);
955 LoadFromDevice(primaryDC);
956 LCLIntf.ReleaseDC(0, primaryDC);
957end;
958
959procedure TBGRALCLBitmap.TakeScreenshot(ARect: TRect);
960var primaryDC: THandle;
961begin
962 primaryDC := LCLIntf.GetDC(0);
963 LoadFromDevice(primaryDC, ARect);
964 LCLIntf.ReleaseDC(0, primaryDC);
965end;
966
967end.
968
Note: See TracBrowser for help on using the repository browser.