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; |
Envoyé par Jipété
Répondre avec citation
] : 2 secondes pour l'afficher 
))
), c'est le "par conséquent" qui me choque : toutes (parce qu'in fine tout est API dans le monde Windows, nan ?) les API's graphiques sont comme ça ? Première fois que j'en entends parler...
si on parle d'opacité ou de transparence 
) 
, je ne peux pas faire plus 
TBitmap sous Lazarus et D7 ne sont pas identiques
Partager