1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
| const
IMAGE_WIDTH = 640;//480;//256;
IMAGE_HEIGHT = 480;//256;
type
// TPixels = array[0..IMAGE_HEIGHT - 1, 0..IMAGE_WIDTH - 1, 0..3] of Byte;
TPixels = array[0..IMAGE_HEIGHT-1, 0..IMAGE_WIDTH-1] of TRGBQuad;
PPixels = ^TPixels;
var
Pixels: PPixels;
procedure Tfrm_DibTest.FormCreate(Sender: TObject);
var
x, y: Integer;
h, v: Integer;
begin
DoubleBuffered := True;
GetMem(Pixels, IMAGE_WIDTH*IMAGE_HEIGHT*SizeOf(TRGBQuad));
for x := 0 to IMAGE_WIDTH - 1 do
for y := 0 to IMAGE_HEIGHT - 1 do
begin
Pixels^[y, x].rgbBlue := x + y;
Pixels^[y, x].rgbGreen := x - y;
Pixels^[y, x].rgbRed := x + x;
Pixels^[y, x].rgbReserved := 255;
end;
end;
procedure Tfrm_DibTest.FormPaint(Sender: TObject);
var
BitsInfos: TBitmapInfo;
Bmp: TBitmap;
begin
FillChar(BitsInfos, SizeOf(BitsInfos), 0);
with BitsInfos do
begin
with bmiHeader do
begin
biSize := SizeOf(TBitmapInfoHeader);
biWidth := IMAGE_WIDTH;
biHeight := -IMAGE_HEIGHT; // inverser le DIB pour avoir la tête en haut
biPlanes := 1;
biBitCount := 32;
end;
end;
Bmp := TBitmap.Create;
try
Bmp.PixelFormat := pf32Bit;
Bmp.width := IMAGE_WIDTH+10; //+10 pour faire une bordure blanche autour des couleurs
Bmp.Height:= IMAGE_HEIGHT+10;
SetDIBitsToDevice(
//cirec Canvas.Handle,
Bmp.Canvas.Handle,
5, 5, IMAGE_WIDTH, IMAGE_HEIGHT,
0, 0, 0, IMAGE_HEIGHT,
//cirec @aPixels,
Pixels,
BitsInfos,
0
);
with Bmp.Canvas do
begin
Brush.Style := bsClear;
Font.Name := 'Arial';
Font.Size := 12;
Font.Style := [fsBold];
TextOut(11, 11, 'Hello World');
Font.Color := clWhite;
TextOut(10, 10, 'Hello World');
end;
Canvas.Draw(10, 10, Bmp);
finally
Bmp.Free;
end;
end;
procedure Tfrm_DibTest.btn_GoClick(Sender: TObject);
var
x, y: Integer;
SrcBmp: TBitmap;
Delta : INTEGER;
LoopCount : INTEGER;
StartTime : DWORD; // Use DWORD to keep D3 and D4 happy
begin
img_Result.Picture:=nil;
frm_DibTest.Caption := '';
StartTime := GetTickCount;
SrcBmp := TBitmap.Create;
try
with SrcBmp do begin
SrcBmp.PixelFormat:=pf32bit;
SrcBmp.Width := IMAGE_WIDTH;
SrcBmp.Height := IMAGE_HEIGHT;
end;
////////////////////////////////////////////////////////////////////////////////
//
// PT : étrangement sous Lazarus c'est ScanLine[0] qui pointe sur le début du
// bitmap et non ScanLine[H - 1] comme sous Delphi (Bitmap avec la tête en bas)
//
////////////////////////////////////////////////////////////////////////////////
//d7 SrcBmp.BeginUpdate;
//AV Move(Pixels, SrcBmp.ScanLine[IMAGE_HEIGHT-1]^, IMAGE_WIDTH*IMAGE_HEIGHT*(SizeOf(Byte)*4));
//AV Move(Pixels, SrcBmp.ScanLine[0]^, IMAGE_WIDTH*IMAGE_HEIGHT*(SizeOf(Byte)*4));
//d7 SrcBmp.EndUpdate();
for y := 0 to IMAGE_HEIGHT-1 do
// CopyMemory(SrcBmp.ScanLine[y], @Pixels[y], IMAGE_WIDTH*SizeOf(TRGBQuad));
CopyMemory(SrcBmp.ScanLine[IMAGE_HEIGHT-1-y], @Pixels[y], IMAGE_WIDTH*SizeOf(TRGBQuad));
img_Result.Picture.Graphic := SrcBmp;
finally
SrcBmp.Free;
end;
Delta := GetTickCount - StartTime; // ms
frm_DibTest.Caption := IntToStr(Delta) + ' Total ms; ' +
Format('%.1f', [Delta / LoopCount]) + ' ms/bitmap';
end; |
Partager