source: trunk/Packages/DpiControls/NativePixelPointer.pas

Last change on this file was 559, checked in by chronos, 3 months ago
File size: 13.0 KB
Line 
1unit NativePixelPointer;
2
3interface
4
5uses
6 Math, Classes, SysUtils, Graphics;
7
8type
9 TColor32 = type Cardinal;
10 TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha);
11 TColor32Planes = array[0..3] of Byte;
12
13 { TPixel32 }
14
15 TPixel32 = packed record
16 private
17 procedure SetRGB(AValue: Cardinal); inline;
18 function GetRGB: Cardinal; inline;
19 public
20 property RGB: Cardinal read GetRGB write SetRGB;
21 case Integer of
22 0: (B, G, R, A: Byte);
23 1: (ARGB: TColor32);
24 2: (Planes: TColor32Planes);
25 3: (Components: array[TColor32Component] of Byte);
26 end;
27 PPixel32 = ^TPixel32;
28
29 { TPixelPointer }
30
31 TPixelPointer = record
32 private
33 function GetPixelARGB: TColor32; inline;
34 function GetPixelB: Byte; inline;
35 function GetPixelG: Byte; inline;
36 function GetPixelPlane(Index: Byte): Byte; inline;
37 function GetPixelR: Byte; inline;
38 function GetPixelA: Byte; inline;
39 function GetPixelPlanes: TColor32Planes;
40 function GetPixelRGB: Cardinal; inline;
41 procedure SetPixelARGB(Value: TColor32); inline;
42 procedure SetPixelB(Value: Byte); inline;
43 procedure SetPixelG(Value: Byte); inline;
44 procedure SetPixelPlane(Index: Byte; AValue: Byte); inline;
45 procedure SetPixelR(Value: Byte); inline;
46 procedure SetPixelA(Value: Byte); inline;
47 procedure SetPixelRGB(Value: Cardinal); inline;
48 public
49 Base: PPixel32;
50 Pixel: PPixel32;
51 Line: PPixel32;
52 BytesPerPixel: Integer;
53 BytesPerLine: Integer;
54 Data: PPixel32;
55 Width: Integer;
56 Height: Integer;
57 procedure NextLine; inline; // Move pointer to start of next line
58 procedure PreviousLine; inline; // Move pointer to start of previous line
59 procedure NextPixel; inline; // Move pointer to next pixel
60 procedure PreviousPixel; inline; // Move pointer to previous pixel
61 procedure SetXY(X, Y: Integer); inline; // Set pixel position relative to base
62 procedure SetX(X: Integer); inline; // Set horizontal pixel position relative to base
63 function GetY: Integer; inline; // Set pixel position relative to base
64 function GetX: Integer; inline; // Set horizontal pixel position relative to base
65 procedure CheckRange; inline; // Check if current pixel position is not out of range
66 function PosValid: Boolean;
67 class function Create(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; static;
68 property PixelARGB: TColor32 read GetPixelARGB write SetPixelARGB;
69 property PixelRGB: Cardinal read GetPixelRGB write SetPixelRGB;
70 property PixelB: Byte read GetPixelB write SetPixelB;
71 property PixelG: Byte read GetPixelG write SetPixelG;
72 property PixelR: Byte read GetPixelR write SetPixelR;
73 property PixelA: Byte read GetPixelA write SetPixelA;
74 property PixelPlane[Index: Byte]: Byte read GetPixelPlane write SetPixelPlane;
75 end;
76 PPixelPointer = ^TPixelPointer;
77
78 function SwapRedBlue(Color: TColor32): TColor32;
79 procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect; SrcBitmap: TRasterImage; SrcPos: TPoint);
80 procedure BitmapStretchRect(DstBitmap: TRasterImage; DstRect: TRect;
81 SrcBitmap: TRasterImage; SrcRect: TRect);
82 procedure BitmapFill(Bitmap: TRasterImage; Color: TColor32);
83 procedure BitmapFillRect(Bitmap: TRasterImage; Color: TColor32; Rect: TRect);
84 procedure BitmapSwapRedBlue(Bitmap:TRasterImage);
85 procedure BitmapInvert(Bitmap: TRasterImage);
86 procedure BitmapBlendColor(Bitmap: TRasterImage; Color: TColor32);
87 function Color32(A, R, G, B: Byte): TColor32;
88 function Color32ToPixel32(Color: TColor32): TPixel32;
89 function Pixel32ToColor32(Color: TPixel32): TColor32;
90 function Color32ToColor(Color: TColor32): TColor;
91 function ColorToColor32(Color: TColor): TColor32;
92
93
94implementation
95
96resourcestring
97 SOutOfRange = 'Pixel pointer out of range [X: %d, Y: %d, Width: %d, Height: %d]';
98 SWrongBitmapSize = 'Wrong bitmap size [width: %d, height: %d]';
99
100{ TPixel32 }
101
102function TPixel32.GetRGB: Cardinal;
103begin
104 Result := ARGB and $ffffff;
105end;
106
107procedure TPixel32.SetRGB(AValue: Cardinal);
108begin
109 ARGB := (ARGB and $ff000000) or (AValue and $ffffff);
110end;
111
112{ TPixelPointer }
113
114procedure TPixelPointer.NextLine; inline;
115begin
116 Line := Pointer(Line) + BytesPerLine;
117 Pixel := Line;
118end;
119
120procedure TPixelPointer.PreviousLine; inline;
121begin
122 Line := Pointer(Line) - BytesPerLine;
123 Pixel := Line;
124end;
125
126procedure TPixelPointer.NextPixel; inline;
127begin
128 Pixel := Pointer(Pixel) + BytesPerPixel;
129end;
130
131procedure TPixelPointer.PreviousPixel; inline;
132begin
133 Pixel := Pointer(Pixel) - BytesPerPixel;
134end;
135
136procedure TPixelPointer.SetXY(X, Y: Integer); inline;
137begin
138 Line := Pointer(Base) + Y * BytesPerLine;
139 SetX(X);
140end;
141
142procedure TPixelPointer.SetX(X: Integer); inline;
143begin
144 Pixel := Pointer(Line) + X * BytesPerPixel;
145end;
146
147function TPixelPointer.GetY: Integer; inline;
148begin
149 Result := (Pointer(Base) - Line) div BytesPerLine;
150end;
151
152function TPixelPointer.GetX: Integer; inline;
153begin
154 Result := (Pointer(Line) - Pixel) div BytesPerPixel;
155end;
156
157procedure TPixelPointer.CheckRange;
158{$IFOPT R+}
159var
160 X: Integer;
161 Y: Integer;
162 D: Integer;
163{$ENDIF}
164begin
165 {$IFOPT R+}
166 if (PByte(Pixel) < PByte(Data)) or
167 (PByte(Pixel) >= PByte(Data) + Height * BytesPerLine) then begin
168 D := PByte(Pixel) - PByte(Data);
169 Y := Trunc(D / BytesPerLine);
170 X := D - Y * BytesPerLine;
171 X := Trunc(X / BytesPerPixel);
172 raise Exception.Create(Format(SOutOfRange, [X, Y, Width, Height]));
173 end;
174 {$ENDIF}
175end;
176
177function TPixelPointer.PosValid: Boolean;
178begin
179 Result := not ((PByte(Pixel) < PByte(Data)) or
180 (PByte(Pixel) >= PByte(Data) + Height * BytesPerLine));
181end;
182
183function TPixelPointer.GetPixelPlanes: TColor32Planes;
184begin
185 CheckRange;
186 Result := Pixel^.Planes;
187end;
188
189function TPixelPointer.GetPixelRGB: Cardinal;
190begin
191 CheckRange;
192 Result := Pixel^.RGB;
193end;
194
195procedure TPixelPointer.SetPixelARGB(Value: TColor32);
196begin
197 CheckRange;
198 Pixel^.ARGB := Value;
199end;
200
201procedure TPixelPointer.SetPixelB(Value: Byte);
202begin
203 CheckRange;
204 Pixel^.B := Value;
205end;
206
207procedure TPixelPointer.SetPixelG(Value: Byte);
208begin
209 CheckRange;
210 Pixel^.G := Value;
211end;
212
213procedure TPixelPointer.SetPixelPlane(Index: Byte; AValue: Byte);
214begin
215 CheckRange;
216 Pixel^.Planes[Index] := AValue;
217end;
218
219procedure TPixelPointer.SetPixelR(Value: Byte);
220begin
221 CheckRange;
222 Pixel^.R := Value;
223end;
224
225procedure TPixelPointer.SetPixelA(Value: Byte);
226begin
227 CheckRange;
228 Pixel^.A := Value;
229end;
230
231function TPixelPointer.GetPixelARGB: TColor32;
232begin
233 CheckRange;
234 Result := Pixel^.ARGB;
235end;
236
237function TPixelPointer.GetPixelB: Byte;
238begin
239 CheckRange;
240 Result := Pixel^.B;
241end;
242
243function TPixelPointer.GetPixelG: Byte;
244begin
245 CheckRange;
246 Result := Pixel^.G;
247end;
248
249function TPixelPointer.GetPixelPlane(Index: Byte): Byte;
250begin
251 CheckRange;
252 Result := Pixel^.Planes[Index];
253end;
254
255function TPixelPointer.GetPixelR: Byte;
256begin
257 CheckRange;
258 Result := Pixel^.R;
259end;
260
261function TPixelPointer.GetPixelA: Byte;
262begin
263 CheckRange;
264 Result := Pixel^.A;
265end;
266
267procedure TPixelPointer.SetPixelRGB(Value: Cardinal);
268begin
269 CheckRange;
270 Pixel^.RGB := Value;
271end;
272
273procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect;
274 SrcBitmap: TRasterImage; SrcPos: TPoint);
275var
276 SrcPtr, DstPtr: TPixelPointer;
277 X, Y: Integer;
278begin
279 SrcBitmap.BeginUpdate(True);
280 DstBitmap.BeginUpdate(True);
281 SrcPtr := TPixelPointer.Create(SrcBitmap, SrcPos.X, SrcPos.Y);
282 DstPtr := TPixelPointer.Create(DstBitmap, DstRect.Left, DstRect.Top);
283 for Y := 0 to DstRect.Height - 1 do begin
284 for X := 0 to DstRect.Width - 1 do begin
285 DstPtr.PixelARGB := SrcPtr.PixelARGB;
286 SrcPtr.NextPixel;
287 DstPtr.NextPixel;
288 end;
289 SrcPtr.NextLine;
290 DstPtr.NextLine;
291 end;
292 SrcBitmap.EndUpdate;
293 DstBitmap.EndUpdate;
294end;
295
296procedure BitmapStretchRect(DstBitmap: TRasterImage; DstRect: TRect;
297 SrcBitmap: TRasterImage; SrcRect: TRect);
298var
299 SrcPtr, DstPtr: TPixelPointer;
300 X, Y: Integer;
301 XX, YY: Integer;
302 R: TRect;
303 C: TColor32;
304begin
305 if (DstRect.Width = SrcRect.Width) and (DstRect.Height = SrcRect.Height) then begin
306 BitmapCopyRect(DstBitmap, DstRect, SrcBitmap, Point(SrcRect.Left, SrcRect.Top));
307 Exit;
308 end;
309 SrcBitmap.BeginUpdate(True);
310 DstBitmap.BeginUpdate(True);
311 SrcPtr := TPixelPointer.Create(SrcBitmap, SrcRect.Left, SrcRect.Top);
312 DstPtr := TPixelPointer.Create(DstBitmap, DstRect.Left, DstRect.Top);
313 for Y := 0 to DstRect.Height - 1 do begin
314 for X := 0 to DstRect.Width - 1 do begin
315 R := Rect(Trunc(X * SrcRect.Width / DstRect.Width),
316 Trunc(Y * SrcRect.Height / DstRect.Height),
317 Trunc((X + 1) * SrcRect.Width / DstRect.Width),
318 Trunc((Y + 1) * SrcRect.Height / DstRect.Height));
319 DstPtr.SetXY(X, Y);
320 SrcPtr.SetXY(R.Left, R.Top);
321 C := SrcPtr.PixelARGB;
322 DstPtr.PixelARGB := C;
323 for YY := 0 to R.Height - 1 do begin
324 for XX := 0 to R.Width - 1 do begin
325 DstPtr.PixelARGB := C;
326 DstPtr.NextPixel;
327 end;
328 DstPtr.NextLine;
329 end;
330 end;
331 end;
332 SrcBitmap.EndUpdate;
333 DstBitmap.EndUpdate;
334end;
335
336procedure BitmapFill(Bitmap: TRasterImage; Color: TColor32);
337var
338 X, Y: Integer;
339 Ptr: TPixelPointer;
340begin
341 Bitmap.BeginUpdate(True);
342 Ptr := TPixelPointer.Create(Bitmap);
343 for Y := 0 to Bitmap.Height - 1 do begin
344 for X := 0 to Bitmap.Width - 1 do begin
345 Ptr.PixelARGB := Color;
346 Ptr.NextPixel;
347 end;
348 Ptr.NextLine;
349 end;
350 Bitmap.EndUpdate;
351end;
352
353procedure BitmapFillRect(Bitmap: TRasterImage; Color: TColor32; Rect: TRect);
354var
355 X, Y: Integer;
356 Ptr: TPixelPointer;
357begin
358 Bitmap.BeginUpdate(True);
359 Ptr := TPixelPointer.Create(Bitmap, Rect.Left, Rect.Top);
360 for Y := 0 to Rect.Height - 1 do begin
361 for X := 0 to Rect.Width - 1 do begin
362 Ptr.PixelARGB := Color;
363 Ptr.NextPixel;
364 end;
365 Ptr.NextLine;
366 end;
367 Bitmap.EndUpdate;
368end;
369
370procedure BitmapSwapRedBlue(Bitmap: TRasterImage);
371var
372 X, Y: Integer;
373 Ptr: TPixelPointer;
374begin
375 Bitmap.BeginUpdate(True);
376 Ptr := TPixelPointer.Create(Bitmap);
377 for Y := 0 to Bitmap.Height - 1 do begin
378 for X := 0 to Bitmap.Width - 1 do begin
379 Ptr.PixelARGB := SwapRedBlue(Ptr.PixelARGB);
380 Ptr.NextPixel;
381 end;
382 Ptr.NextLine;
383 end;
384 Bitmap.EndUpdate;
385end;
386
387procedure BitmapInvert(Bitmap: TRasterImage);
388var
389 X, Y: Integer;
390 Ptr: TPixelPointer;
391begin
392 Bitmap.BeginUpdate(True);
393 Ptr := TPixelPointer.Create(Bitmap);
394 for Y := 0 to Bitmap.Height - 1 do begin
395 for X := 0 to Bitmap.Width - 1 do begin
396 Ptr.PixelARGB := Ptr.PixelARGB xor $ffffff;
397 Ptr.NextPixel;
398 end;
399 Ptr.NextLine;
400 end;
401 Bitmap.EndUpdate;
402end;
403
404procedure BitmapBlendColor(Bitmap: TRasterImage; Color: TColor32);
405var
406 X, Y: Integer;
407 Ptr: TPixelPointer;
408 A, R, G, B: Word;
409 Pixel: TPixel32;
410begin
411 Pixel := Color32ToPixel32(Color);
412 Bitmap.BeginUpdate(True);
413 Ptr := TPixelPointer.Create(Bitmap);
414 for Y := 0 to Bitmap.Height - 1 do begin
415 for X := 0 to Bitmap.Width - 1 do begin
416 A := Ptr.PixelA; //(Ptr.PixelA + Pixel.A) shr 1;
417 R := (Ptr.PixelR + Pixel.R) shr 1;
418 G := (Ptr.PixelG + Pixel.G) shr 1;
419 B := (Ptr.PixelB + Pixel.B) shr 1;
420 Ptr.PixelARGB := Color32(A, R, G, B);
421 Ptr.NextPixel;
422 end;
423 Ptr.NextLine;
424 end;
425 Bitmap.EndUpdate;
426end;
427
428function Color32(A, R, G, B: Byte): TColor32;
429begin
430 Result := ((A and $ff) shl 24) or ((R and $ff) shl 16) or
431 ((G and $ff) shl 8) or ((B and $ff) shl 0);
432end;
433
434function Color32ToPixel32(Color: TColor32): TPixel32;
435begin
436 Result.ARGB := Color;
437end;
438
439function Pixel32ToColor32(Color: TPixel32): TColor32;
440begin
441 Result := Color.ARGB;
442end;
443
444function Color32ToColor(Color: TColor32): TColor;
445begin
446 Result := ((Color shr 16) and $ff) or (Color and $00ff00) or
447 ((Color and $ff) shl 16);
448end;
449
450function ColorToColor32(Color: TColor): TColor32;
451begin
452 Result := $ff000000 or ((Color shr 16) and $ff) or (Color and $00ff00) or
453 ((Color and $ff) shl 16);
454end;
455
456class function TPixelPointer.Create(Bitmap: TRasterImage; BaseX: Integer;
457 BaseY: Integer): TPixelPointer;
458begin
459 Result.Width := Bitmap.Width;
460 Result.Height := Bitmap.Height;
461 if (Result.Width < 0) or (Result.Height < 0) then
462 raise Exception.Create(Format(SWrongBitmapSize, [Result.Width, Result.Height]));
463 Result.BytesPerLine := Bitmap.RawImage.Description.BytesPerLine;
464 Result.BytesPerPixel := Bitmap.RawImage.Description.BitsPerPixel shr 3;
465 Result.Data := PPixel32(Bitmap.RawImage.Data);
466 Result.Base := PPixel32(Bitmap.RawImage.Data + BaseX * Result.BytesPerPixel +
467 BaseY * Result.BytesPerLine);
468 Result.SetXY(0, 0);
469end;
470
471function SwapRedBlue(Color: TColor32): TColor32;
472begin
473 Result := (Color and $ff00ff00) or ((Color and $ff) shl 16) or ((Color shr 16) and $ff);
474end;
475
476end.
Note: See TracBrowser for help on using the repository browser.