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
|
unit Unit28;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,Graphics,LCLType,UnitScaleFont;
type arraycouleurs=array of tcolor;
procedure Degrade(couleurdepart,couleurarrivee:tcolor; nombrecouleurs:integer;
var tableaucouleurs:arraycouleurs);
implementation
FUNCTION RGB(CONST r,g,b: BYTE): TColor;
BEGIN
RESULT := (r OR (g SHL 8) OR (b SHL 16))
END {RGB};
function GetRValue(Color: TColor): Byte;
begin
Result := Byte(Color);
end;
function GetGValue(Color: TColor): Byte;
begin
Result := Byte(Color shr 8);
end;
function GetBValue(Color: TColor): Byte;
begin
Result := Byte(Color shr 16);
end;
procedure Degrade(couleurdepart,couleurarrivee:tcolor; nombrecouleurs:integer;
var tableaucouleurs:arraycouleurs);
var
couleurdepartRGB : Array[0..2] Of Byte;
couleuractuelleRGB : Array[0..2] Of Byte;
incrementcouleurRGB : Array[0..2] Of Integer;
i:integer;
Begin
if nombrecouleurs<=1 then exit;
couleurdepartRGB[0] := GetRValue( ColorToRGB( couleurdepart ) );
couleurdepartRGB[1] := GetGValue( ColorToRGB( couleurdepart ) );
couleurdepartRGB[2] := GetBValue( ColorToRGB( couleurdepart ) );
incrementcouleurRGB[0] := GetRValue( ColorToRGB( couleurarrivee )) - couleurdepartRGB[0];
incrementcouleurRGB[1] := GetgValue( ColorToRGB( couleurarrivee )) - couleurdepartRGB[1];
incrementcouleurRGB[2] := GetbValue( ColorToRGB( couleurarrivee )) - couleurdepartRGB[2];
setlength(tableaucouleurs,nombrecouleurs);
for i:=1 to nombrecouleurs do begin
couleuractuelleRGB[0] := (couleurdepartRGB[0] + MulDiv( i-1 , incrementcouleurRGB[0] , nombrecouleurs-1 ));
couleuractuelleRGB[1] := (couleurdepartRGB[1] + MulDiv( i-1 , incrementcouleurRGB[1] , nombrecouleurs-1 ));
couleuractuelleRGB[2] := (couleurdepartRGB[2] + MulDiv( i-1 , incrementcouleurRGB[2] , nombrecouleurs-1 ));
tableaucouleurs[i-1]:=RGB(couleuractuelleRGB[0],couleuractuelleRGB[1],couleuractuelleRGB[2]);
end;
end;
end.
|
