craig_capel
asked on
Color Gradient
Ok copy and paste this code in, put a memo on the form and 2 buttons.
What this routine does, you pass it the color arguments the start color and finish color, it fades, but not correctly...
anyone know how to fix this?
function ColorGradient(StartColor, EndColor: TColor; Steps,WichStep: integer): Tcolor;
var
Deltas: array [0..2] of Real; //R,G,B
begin
Deltas[0] := (GetRValue(EndColor) - GetRValue(StartColor)) / Steps;
Deltas[1] := (GetGValue(EndColor) - GetGValue(StartColor)) / Steps;
Deltas[2] := (GetBValue(EndColor) - GetBValue(StartColor)) / Steps;
result := RGB(Round(GetRValue(StartC olor) + WichStep * Deltas[0]),
Round(GetGValue(StartColor ) + WichStep * Deltas[1]),
Round(GetBValue(StartColor ) + WichStep * Deltas[2]));
end;
Function CreateRTFFadeStr(Colours,M sg: String): String;
Var
OldCol,BuildStr,TmpCol2,Tm pCol,Tmp: String;
ColorCount,Step,N,P1,P2,Ch arCount: Integer;
ResCol,Col1,Col2: TColor;
L,SR,SG,SB: Integer;
Begin
BuildStr:='';
ColorCount:=0;
CharCount:=Length(Msg);
Tmp:=Colours+',';
For N:=1 to Length(Tmp) do
If Tmp[N]=',' Then
Inc(ColorCount);
Step:=CharCount Div ColorCount;
N:=0;
While (Pos(',',Tmp)>0) do
Begin
P1:=Pos(',',Tmp);
TmpCol:=Copy(Tmp,1,p1-1);
Delete(Tmp,1,P1); //TmpCol = First ColorString (e=g #FF0000)
P1:=Pos(',',Tmp);
TmpCol2:=Copy(Tmp,1,p1-1);
// Delete(Tmp,1,P1); //TmpCol2 = Second ColorString (eg #00FF00)
If Msg<>'' Then
Begin
Col1:=StrToInt('$'+Copy(Tm pCol,2,Len gth(TmpCol )-1));
If TmpCol2<>'' Then
Col2:=StrToInt('$'+Copy(Tm pCol2,2,Le ngth(TmpCo l2)-1));
For N:=1 to Step Do
Begin
ResCol:=ColorGradient(Col1 ,Col2,Step ,N);
TmpCol:=IntToHex(ResCol,6) ;
SR:=StrToInt('$'+Copy(TmpC ol,1,2));
SG:=StrToInt('$'+Copy(TmpC ol,3,2));
SB:=StrToInt('$'+Copy(TmpC ol,5,2));
BuildStr:=BuildStr+';'+'\r ed'+IntToS tr(SR)+'\g reen'+IntT oStr(SG)+' \blue'+Int ToStr(SB)+ '';
End;
End;
TmpCol:='';
TmpCol2:='';
Result:=BuildStr;
End;
End;
procedure TForm1.Button1Click(Sender : TObject);
begin
Memo1.Text:=CreateRTFFadeS tr('#FF000 0,#00FF00, #0000FF',' TXT');
// SHOULD produce T in RED X in Blue and T in GReen
end;
procedure TForm1.Button2Click(Sender : TObject);
begin
Memo1.Text:=CreateRTFFadeS tr('#FF000 0,#00FF00, #0000FF',' AABBCC');
// Should produce (255 of Red) then Gade between them.. etc etc
end;
What this routine does, you pass it the color arguments the start color and finish color, it fades, but not correctly...
anyone know how to fix this?
function ColorGradient(StartColor, EndColor: TColor; Steps,WichStep: integer): Tcolor;
var
Deltas: array [0..2] of Real; //R,G,B
begin
Deltas[0] := (GetRValue(EndColor) - GetRValue(StartColor)) / Steps;
Deltas[1] := (GetGValue(EndColor) - GetGValue(StartColor)) / Steps;
Deltas[2] := (GetBValue(EndColor) - GetBValue(StartColor)) / Steps;
result := RGB(Round(GetRValue(StartC
Round(GetGValue(StartColor
Round(GetBValue(StartColor
end;
Function CreateRTFFadeStr(Colours,M
Var
OldCol,BuildStr,TmpCol2,Tm
ColorCount,Step,N,P1,P2,Ch
ResCol,Col1,Col2: TColor;
L,SR,SG,SB: Integer;
Begin
BuildStr:='';
ColorCount:=0;
CharCount:=Length(Msg);
Tmp:=Colours+',';
For N:=1 to Length(Tmp) do
If Tmp[N]=',' Then
Inc(ColorCount);
Step:=CharCount Div ColorCount;
N:=0;
While (Pos(',',Tmp)>0) do
Begin
P1:=Pos(',',Tmp);
TmpCol:=Copy(Tmp,1,p1-1);
Delete(Tmp,1,P1); //TmpCol = First ColorString (e=g #FF0000)
P1:=Pos(',',Tmp);
TmpCol2:=Copy(Tmp,1,p1-1);
// Delete(Tmp,1,P1); //TmpCol2 = Second ColorString (eg #00FF00)
If Msg<>'' Then
Begin
Col1:=StrToInt('$'+Copy(Tm
If TmpCol2<>'' Then
Col2:=StrToInt('$'+Copy(Tm
For N:=1 to Step Do
Begin
ResCol:=ColorGradient(Col1
TmpCol:=IntToHex(ResCol,6)
SR:=StrToInt('$'+Copy(TmpC
SG:=StrToInt('$'+Copy(TmpC
SB:=StrToInt('$'+Copy(TmpC
BuildStr:=BuildStr+';'+'\r
End;
End;
TmpCol:='';
TmpCol2:='';
Result:=BuildStr;
End;
End;
procedure TForm1.Button1Click(Sender
begin
Memo1.Text:=CreateRTFFadeS
// SHOULD produce T in RED X in Blue and T in GReen
end;
procedure TForm1.Button2Click(Sender
begin
Memo1.Text:=CreateRTFFadeS
// Should produce (255 of Red) then Gade between them.. etc etc
end;
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Ah.... yes, but the problem is that it could be 1,2,3, 4, 5, 6 color values to be passed to produce a gradient...
the math is beyond me i think :P
the math is beyond me i think :P
Hi Craig_capel,
do you want ANY color sequence, or true RAINBOW color scheme?
regards,
odissey1
do you want ANY color sequence, or true RAINBOW color scheme?
regards,
odissey1
ASKER
any sequence, so i could pass in RED, Green Blue Black and it would do a nice gradient
Red... Red/Green / Red/Green/Blue.... on the way to Black....
or Blue Black Blue Black... Blue.../Darker Blue/ Darker / Black... Lightter blue to Blue. a nice graident between..
http://chat-help.co.uk/~ymlite/screenshot.gif <<like this one i already have but the problem is once it does more than 255 char fade, it becomes really blocky and stops working and turns to one color...
Red... Red/Green / Red/Green/Blue.... on the way to Black....
or Blue Black Blue Black... Blue.../Darker Blue/ Darker / Black... Lightter blue to Blue. a nice graident between..
http://chat-help.co.uk/~ymlite/screenshot.gif <<like this one i already have but the problem is once it does more than 255 char fade, it becomes really blocky and stops working and turns to one color...
Hi craig_capel,
This programm does what you wants: Any colors combination, any text string.
Regards,
odissey1
unit RainbowText_3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls,
Math,//Power
StrUtils //PosEx
;
type
TForm1 = class(TForm)
Memo1: TMemo;
RichEdit1: TRichEdit;
Button1: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
NColors: integer;
AColors: array of TColor;
const
PaletteSteps=32; // number of colors to use in color table
// this will make your Text shorter
implementation
{$R *.dfm}
//------------------------ ---------- ---------- ---------- ------
function AdjustGamma(Color: double): Integer;
const Gamma = 0.25; //(0...10) - smooth transition effect
begin
if Color <= 0 then result := 0 else
if Color > 255 then result := 255 else
// result := round(Color);
result := round(255 * Power(Color/255, Gamma) );
end;
function Palette (i: integer): TColor;
var R, G, B: double;
R1,R2,G1,G2,B1,B2: integer;
v1, v2, delta: double;
i1,i2,k1,k2: integer;
C1,C2: TColor;
ch:char;
begin
//note: total PaletteSteps are distributed between NColors
// i-some position between 1 <= ii <= PaletteSteps
// get mix colors
k1:=trunc( (NColors-1) * (i-1) / (PaletteSteps-1) );
k2:=k1+1; if k2 > Ncolors-1 then k2:=Ncolors-1;
v1:=k1 * (PaletteSteps-1) / (NColors-1);
v2:=k2 * (PaletteSteps-1) / (NColors-1);
C1:=AColors[k1];
C2:=AColors[k2];
R1:=GetRValue(C1); G1:=GetGValue(C1); B1:=GetBValue(C1);
R2:=GetRValue(C2); G2:=GetGValue(C2); B2:=GetBValue(C2);
//2-color transition C1->C2
delta := V2 - V1;
R := R1 + (R2-R1) * (i-v1) / delta;
G := G1 + (G2-G1) * (i-v1) / delta;
B := B1 + (B2-B1) * (i-v1) / delta;
result:=RGB( AdjustGamma(R), AdjustGamma(G), AdjustGamma(B) );
end;
//------------------------ ---------- ---------- ---------- ------
function CreateRTFFadeStr(Msg: String): string;
Var i, L, pClr, pClr_bak: integer;
Clr: TColor;
RS: string;
Begin
RS:= '{\rtf1\ansi\ansicpg1252\d eff0\defla ng1033{\fo nttbl{\f0\ fswiss\fch arset0 Arial;}}'
+'\viewkind4\uc1\pard\f0\f s20 ';
// we shell limit color table to some PalletteSteps
// there would be no more then PaletteSteps color in color table
// create clortable
RS:=RS+ '{\colortbl; ';
for i:=0 to PaletteSteps-1 do begin
Clr:= Palette(i);
RS:=RS+ '\red' +IntToStr(GetRValue(Clr))
+ '\green'+IntToStr(GetGValu e(Clr))
+ '\blue' +IntToStr(GetBValue(Clr))+ '; ';
end;
RS:=RS+ '}';
L:=Length(msg);
//stuff string with color modifiers when needed
pClr_bak:=-1;
for i:=0 to L-1 do begin
pClr:=round(1+(PaletteStep s-1) * i / (L-1) ); //find a new color edge
if pClr <> pClr_bak then //edge found
begin
RS:=RS+ '\cf'+IntToStr(pClr)+' '+copy(msg,i+1,1);
pClr_bak:=pClr;
end
else //no color modifier - use current color
RS:=RS+copy(msg,i,1);
end;
//finalize
RS:=RS+'\cf0\par}'; // reset to default color +LF+CR
result:=RS;
End;
procedure SetColors(S: string);
var s1: string;
i,i1,i2: integer;
Strings: TStringList;
begin
// if S = '' then exit;
//separate ColorString into substrings (colors)
Strings:=TStringList.Creat e;
S:=S+','; //add terminator
NColors:=0; //number of colors found
i1:=0; i2:=0;
while PosEx(',', S, i2+1) > 0 do begin
i2:=PosEx(',', S, i2+1);
s1:=MidStr(S, i1+1, i2-(i1+1) );
Strings.Add( Trim(s1) );
Inc(NColors);
i1:=i2;
end;
SetLength(Acolors, NColors); //set dimension of colors array
//define colors
for i:=0 to NColors-1 do
Acolors[i]:=StringToColor( Strings[i] );
Strings.Free;
end;
procedure TForm1.Button1Click(Sender : TObject);
var S: string;
begin
//set text string
S:='';
S:=S+'1. GRANT OF LICENSE.' + '\par';
S:=S+'(a) Microsoft grants you ("Recipient") a limited, non-exclusive,';
S:=S+' nontransferable, royalty-free license to make and use up to three (3)';
S:=S+' copies of the software accompanying this Agreement ("Product") on ';
S:=S+ 'computer systems located on Recipients premises, solely to test the';
S:=S+ 'compatibility of Recipients application or other product(s) which operate';
S:=S+' in conjunction with the Product and to evaluate the Product for the purpose';
S:=S+' of providing feedback thereon to Microsoft. All other rights are reserved';
S:=S+' to Microsoft. Recipient shall not rent, lease, sell, sublicense, assign, ';
S:=S+' or otherwise transfer the Product, including any accompanying printed ';
S:=S+' materials. Recipient shall not reverse engineer, decompile or disassemble ';
S:=S+' the Product except to the extent that this restriction is expressly prohibited ';
S:=S+' by applicable law. Recipient may not disclose the results of any benchmark ';
S:=S+' testing of the Product to any third party without Microsofts prior written';
S:=S+' permission. Microsoft and its suppliers shall retain title and all owner';
// S:='123456789cvbvb123407';
SetColors('clRed,clYellow, clLime,clB lue,clFuch sia');
RichEdit1.Text:=CreateRTFF adeStr(S);
// Memo1.Text:=CreateRTFFadeS tr(S);
end;
end.
This programm does what you wants: Any colors combination, any text string.
Regards,
odissey1
unit RainbowText_3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls,
Math,//Power
StrUtils //PosEx
;
type
TForm1 = class(TForm)
Memo1: TMemo;
RichEdit1: TRichEdit;
Button1: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
NColors: integer;
AColors: array of TColor;
const
PaletteSteps=32; // number of colors to use in color table
// this will make your Text shorter
implementation
{$R *.dfm}
//------------------------
function AdjustGamma(Color: double): Integer;
const Gamma = 0.25; //(0...10) - smooth transition effect
begin
if Color <= 0 then result := 0 else
if Color > 255 then result := 255 else
// result := round(Color);
result := round(255 * Power(Color/255, Gamma) );
end;
function Palette (i: integer): TColor;
var R, G, B: double;
R1,R2,G1,G2,B1,B2: integer;
v1, v2, delta: double;
i1,i2,k1,k2: integer;
C1,C2: TColor;
ch:char;
begin
//note: total PaletteSteps are distributed between NColors
// i-some position between 1 <= ii <= PaletteSteps
// get mix colors
k1:=trunc( (NColors-1) * (i-1) / (PaletteSteps-1) );
k2:=k1+1; if k2 > Ncolors-1 then k2:=Ncolors-1;
v1:=k1 * (PaletteSteps-1) / (NColors-1);
v2:=k2 * (PaletteSteps-1) / (NColors-1);
C1:=AColors[k1];
C2:=AColors[k2];
R1:=GetRValue(C1); G1:=GetGValue(C1); B1:=GetBValue(C1);
R2:=GetRValue(C2); G2:=GetGValue(C2); B2:=GetBValue(C2);
//2-color transition C1->C2
delta := V2 - V1;
R := R1 + (R2-R1) * (i-v1) / delta;
G := G1 + (G2-G1) * (i-v1) / delta;
B := B1 + (B2-B1) * (i-v1) / delta;
result:=RGB( AdjustGamma(R), AdjustGamma(G), AdjustGamma(B) );
end;
//------------------------
function CreateRTFFadeStr(Msg: String): string;
Var i, L, pClr, pClr_bak: integer;
Clr: TColor;
RS: string;
Begin
RS:= '{\rtf1\ansi\ansicpg1252\d
+'\viewkind4\uc1\pard\f0\f
// we shell limit color table to some PalletteSteps
// there would be no more then PaletteSteps color in color table
// create clortable
RS:=RS+ '{\colortbl; ';
for i:=0 to PaletteSteps-1 do begin
Clr:= Palette(i);
RS:=RS+ '\red' +IntToStr(GetRValue(Clr))
+ '\green'+IntToStr(GetGValu
+ '\blue' +IntToStr(GetBValue(Clr))+
end;
RS:=RS+ '}';
L:=Length(msg);
//stuff string with color modifiers when needed
pClr_bak:=-1;
for i:=0 to L-1 do begin
pClr:=round(1+(PaletteStep
if pClr <> pClr_bak then //edge found
begin
RS:=RS+ '\cf'+IntToStr(pClr)+' '+copy(msg,i+1,1);
pClr_bak:=pClr;
end
else //no color modifier - use current color
RS:=RS+copy(msg,i,1);
end;
//finalize
RS:=RS+'\cf0\par}'; // reset to default color +LF+CR
result:=RS;
End;
procedure SetColors(S: string);
var s1: string;
i,i1,i2: integer;
Strings: TStringList;
begin
// if S = '' then exit;
//separate ColorString into substrings (colors)
Strings:=TStringList.Creat
S:=S+','; //add terminator
NColors:=0; //number of colors found
i1:=0; i2:=0;
while PosEx(',', S, i2+1) > 0 do begin
i2:=PosEx(',', S, i2+1);
s1:=MidStr(S, i1+1, i2-(i1+1) );
Strings.Add( Trim(s1) );
Inc(NColors);
i1:=i2;
end;
SetLength(Acolors, NColors); //set dimension of colors array
//define colors
for i:=0 to NColors-1 do
Acolors[i]:=StringToColor(
Strings.Free;
end;
procedure TForm1.Button1Click(Sender
var S: string;
begin
//set text string
S:='';
S:=S+'1. GRANT OF LICENSE.' + '\par';
S:=S+'(a) Microsoft grants you ("Recipient") a limited, non-exclusive,';
S:=S+' nontransferable, royalty-free license to make and use up to three (3)';
S:=S+' copies of the software accompanying this Agreement ("Product") on ';
S:=S+ 'computer systems located on Recipients premises, solely to test the';
S:=S+ 'compatibility of Recipients application or other product(s) which operate';
S:=S+' in conjunction with the Product and to evaluate the Product for the purpose';
S:=S+' of providing feedback thereon to Microsoft. All other rights are reserved';
S:=S+' to Microsoft. Recipient shall not rent, lease, sell, sublicense, assign, ';
S:=S+' or otherwise transfer the Product, including any accompanying printed ';
S:=S+' materials. Recipient shall not reverse engineer, decompile or disassemble ';
S:=S+' the Product except to the extent that this restriction is expressly prohibited ';
S:=S+' by applicable law. Recipient may not disclose the results of any benchmark ';
S:=S+' testing of the Product to any third party without Microsofts prior written';
S:=S+' permission. Microsoft and its suppliers shall retain title and all owner';
// S:='123456789cvbvb123407';
SetColors('clRed,clYellow,
RichEdit1.Text:=CreateRTFF
// Memo1.Text:=CreateRTFFadeS
end;
end.
ASKER
OK....
RS:=RS+ '{\colortbl; ';
for i:=0 to PaletteSteps-1 do begin
Clr:= Palette(i);
RS:=RS+ '\red' +IntToStr(GetRValue(Clr))
+ '\green'+IntToStr(GetGValu e(Clr))
+ '\blue' +IntToStr(GetBValue(Clr))+ '; ';
end;
RS:=RS+ '}';
L:=Length(msg);
As you may have guessed, as a person types it renders the string on the fly and outputs it to richedit producing the fade...
problem, if i type in ABC with the colors FF 00 00 , 00 FF 00, 00 00 FF
It produces 32 steps as that's how many are in the PaletteSteps, the Palette steps should only be 3 if the length of the message is 3, or 1 or if someone types out a lengthy message, even more...
with "ABC" and the colors "Red,Green,Blue" i get 3 rows of
it all ranging from blues yellows greens red orange text from it...
RS:=RS+ '{\colortbl; ';
for i:=0 to PaletteSteps-1 do begin
Clr:= Palette(i);
RS:=RS+ '\red' +IntToStr(GetRValue(Clr))
+ '\green'+IntToStr(GetGValu
+ '\blue' +IntToStr(GetBValue(Clr))+
end;
RS:=RS+ '}';
L:=Length(msg);
As you may have guessed, as a person types it renders the string on the fly and outputs it to richedit producing the fade...
problem, if i type in ABC with the colors FF 00 00 , 00 FF 00, 00 00 FF
It produces 32 steps as that's how many are in the PaletteSteps, the Palette steps should only be 3 if the length of the message is 3, or 1 or if someone types out a lengthy message, even more...
with "ABC" and the colors "Red,Green,Blue" i get 3 rows of
it all ranging from blues yellows greens red orange text from it...
Hi craig_capel,
Did you tried to run the code above? I see output as requested:
S:='123';
SetColors('clRed,clGreen,c lBlue');
result: single line '123'; 1 (Red), 2 (green), 3(blue) - no problem (used PaletteSteps=32).
In my example PaletteSteps could be any. You can put 255 -it will produce same result. I introduced this constant to reduce ColorTable size only. I figured that above 32 steps eye can not distingiush color gradation any more - just run example above and see. So the advantage that you can put color table just once - and then staff RichEdit with strings. But if you want you can change it also on-the-fly (just replace declaration to
var PaletteSteps: integer;)
>with "ABC" and the colors "Red,Green,Blue" i get 3 rows of
>it all ranging from blues yellows greens red orange text from it...
I don't understand what you mean. The above code gives single line 'ABC' with A in Red, B in Green and C in Blue. No blended colors.
(PaletteSteps=32).
S:='ABC';
SetColors('clRed,clGreen,c lBlue');
RichEdit1.Text:=...
To see blended colors string must be longer like 'AaBbC' ('a', 'b' will show blended)
Do you see a rainbow-blended text (~20 lines) in my example?
Regards,
odissey1
P.S. I can drop you a sourcecode if needed.
Did you tried to run the code above? I see output as requested:
S:='123';
SetColors('clRed,clGreen,c
result: single line '123'; 1 (Red), 2 (green), 3(blue) - no problem (used PaletteSteps=32).
In my example PaletteSteps could be any. You can put 255 -it will produce same result. I introduced this constant to reduce ColorTable size only. I figured that above 32 steps eye can not distingiush color gradation any more - just run example above and see. So the advantage that you can put color table just once - and then staff RichEdit with strings. But if you want you can change it also on-the-fly (just replace declaration to
var PaletteSteps: integer;)
>with "ABC" and the colors "Red,Green,Blue" i get 3 rows of
>it all ranging from blues yellows greens red orange text from it...
I don't understand what you mean. The above code gives single line 'ABC' with A in Red, B in Green and C in Blue. No blended colors.
(PaletteSteps=32).
S:='ABC';
SetColors('clRed,clGreen,c
RichEdit1.Text:=...
To see blended colors string must be longer like 'AaBbC' ('a', 'b' will show blended)
Do you see a rainbow-blended text (~20 lines) in my example?
Regards,
odissey1
P.S. I can drop you a sourcecode if needed.
Hi again,
Just checked with PaletteSteps=3. 'ABC' works OK. But you really don't have to change it: 32 -gradation is good enough to satisfy any short or long string
odissey1
Just checked with PaletteSteps=3. 'ABC' works OK. But you really don't have to change it: 32 -gradation is good enough to satisfy any short or long string
odissey1
ASKER
ok, what is the RTF output you get for 'ABC' i will show you what i get...
Hi Craig_capel,
As I said the code above with settings
(PaletteSteps=32).
S:='ABC';
SetColors('clRed,clGreen,c lBlue');
RichEdit1.Text:=...
gives PERFECT output: 'ABC' with A in Red, B in Green and C in Blue.
Just copy and paste example above. If you have any problems - ask for source code. What I suspect, the way you use this code in your program is not what you asked in the forum. My suggestion is: copy/paste code above (add RichEdit1 and Button1 to the form). Check that its working. Then customize to your needs.
One more thought: do you work in 256-color resolution?
regards,
odissey1
As I said the code above with settings
(PaletteSteps=32).
S:='ABC';
SetColors('clRed,clGreen,c
RichEdit1.Text:=...
gives PERFECT output: 'ABC' with A in Red, B in Green and C in Blue.
Just copy and paste example above. If you have any problems - ask for source code. What I suspect, the way you use this code in your program is not what you asked in the forum. My suggestion is: copy/paste code above (add RichEdit1 and Button1 to the form). Check that its working. Then customize to your needs.
One more thought: do you work in 256-color resolution?
regards,
odissey1
ASKER
Right then... i got your demo and i am sure it's what i need so i modified the routine to make it produce the string i need, the routine you used actually puts all the stuff in my following routines do anyway.
what it does now is, pass in the colors, get back just the red/blue/green like this..
Var i, L, pClr, pClr_bak: integer;
Clr: TColor;
RS: string;
Begin
// we shell limit color table to some PalletteSteps
// there would be no more then PaletteSteps color in color table
// create clortable
{ PaletteSteps:=32;
If Length(Msg)<32 Then
PaletteSteps:=Length(Msg); }
PaletteSteps:=Length(Msg) Div NColors;
for i:=0 to PaletteSteps-1 do begin
Clr:= Palette(i);
RS:=RS+ ';\red'+IntToStr(GetBValue (Clr))+'\g reen'+IntT oStr(GetGV alue(Clr)) +'\blue'+I ntToStr(Ge tRValue(Cl r));
// BuildStr:=BuildStr+';'+'\r ed'+IntToS tr(NewR)+' \green'+In tToStr(New G)+'\blue' +IntToStr( NewB)+'';
end;
L:=Length(msg);
//stuff string with color modifiers when needed
pClr_bak:=-1;
{ for i:=0 to L-1 do begin
pClr:=round(1+(PaletteStep s-1) * i / (L-1) ); //find a new color edge
if pClr <> pClr_bak then //edge found
begin
RS:=RS+ '\cf'+IntToStr(pClr)+' '+copy(msg,i+1,1);
pClr_bak:=pClr;
end
else //no color modifier - use current color
RS:=RS+copy(msg,i+1,1);
end;
//finalize}
// RS:=RS+'\cf0\par}'; // reset to default color +LF+CR
result:=RS;
That's exactly the string i need to pass back, just the RGB and since Tcolor is BGR and not RGB i swapped them around..
the problem it's having now is that it stops short, my old routine would produce stuff like this
//my routine
RicheditFadeStr('$FF0000,$ 00FF00,$00 00FF','abc '); =
;\red255\green0\blue0;\red 0\green255 \blue0
//Now your routine
SetColors2('$FF0000,$00FF0 0,$0000FF' ); // new one
Data:=RicheditFadeStrold(' abc'); =
;\red255\green0\blue0;\red 0\green255 \blue0;\re d0\green0\ blue255
//this is perfect great, that's how i wished mine went, RGB ;)
but then i start getting into the problems you see, sticking 32 colors into richedits stream for the color table for your version is great, my version i have to go and add RTF smiley faces and fonts and other stuff, that's why i produce JUST the RGB values (the color table)...
//My Routine for "abcabc"
('$FF0000,$00FF00,$0000FF' ,'abcabc') ; =
;\red255\green0\blue0;\red 170\green8 5\blue0;\r ed85\green 170\blue0; \red0\gree n255\blue0 ;\red0\gre en170\blue 85;\red0\g reen85\blu e170
//Now your routine "abcabc"
SetColors2('$FF0000,$00FF0 0,$0000FF' ); // new one
Data:=RicheditFadeStrold(' abcabc');
;\red255\green0\blue0;\red 224\green2 03\blue0;\ red171\gre en241\blue 0;\red0\gr een255\blu e0;\red0\g reen203\bl ue224;\red 0\green0\b lue255
----------------------HERE IMPORTANT----------------- -
And again, still works :) it does the end colors and all, but for a longer message then it starts going funny..
//MyRoutine
Data:=RicheditFadeStr('$FF 0000,$00FF 00,$0000FF ','abcabc1 2345'); =
;\red255\green0\blue0;\red 204\green5 1\blue0;\r ed153\gree n102\blue0 ;\red102\g reen153\bl ue0;\red51 \green204\ blue0;\red 0\green255 \blue0;\re d0\green20 4\blue51;\ red0\green 153\blue10 2;\red0\gr een102\blu e153;\red0 \green51\b lue204
//YourRoutine for above
SetColors2('$FF0000,$00FF0 0,$0000FF' ); // new one
Data:=RicheditFadeStrold(' abcabc1234 5'); =
;\red255\green0\blue0;\red 241\green1 71\blue0;\ red224\gre en203\blue 0;\red203\ green224\b lue0;\red1 71\green24 1\blue0;\r ed0\green2 55\blue0;\ red0\green 241\blue17 1;\red0\gr een224\blu e203;\red0 \green203\ blue224;\r ed0\green1 71\blue241 ;\red0\gre en0\blue25 5
First Part Red second Green third Blue - Perfect, great, now watch what happens..
OK I just discovered what the problem was i was doing all this testing, the problem comes when i hit more than 32 (graident steps)
Data:=RicheditFadeStr('$FF 0000,$00FF 00,$0000FF ','abcabc1 2345678901 2345678901 2345678901 2345678901 234567890' );
Richedit1.Lines.Add(Data);
should look something like...
;\red255\green0\blue0;\red 246\green9 \blue0;\re d237\green 18\blue0;\ red228\gre en27\blue0 ;\red219\g reen36\blu e0;\red210 \green45\b lue0;\red2 01\green54 \blue0;\re d192\green 63\blue0;\ red183\gre en72\blue0 ;\red174\g reen81\blu e0;\red165 \green90\b lue0;\red1 56\green99 \blue0;\re d147\green 108\blue0; \red138\gr een117\blu e0;\red129 \green126\ blue0;\red 120\green1 35\blue0;\ red111\gre en144\blue 0;\red102\ green153\b lue0;\red9 3\green162 \blue0;\re d84\green1 71\blue0;\ red75\gree n180\blue0 ;\red66\gr een189\blu e0;\red57\ green198\b lue0;\red4 8\green207 \blue0;\re d39\green2 16\blue0;\ red30\gree n225\blue0 ;\red21\gr een234\blu e0;\red12\ green243\b lue0;\red0 \green255\ blue0;\red 0\green246 \blue9;\re d0\green23 7\blue18;\ red0\green 228\blue27 ;\red0\gre en219\blue 36;\red0\g reen210\bl ue45;\red0 \green201\ blue54;\re d0\green19 2\blue63;\ red0\green 183\blue72 ;\red0\gre en174\blue 81;\red0\g reen165\bl ue90;\red0 \green156\ blue99;\re d0\green14 7\blue108; \red0\gree n138\blue1 17;\red0\g reen129\bl ue126;\red 0\green120 \blue135;\ red0\green 111\blue14 4;\red0\gr een102\blu e153;\red0 \green93\b lue162;\re d0\green84 \blue171;\ red0\green 75\blue180 ;\red0\gre en66\blue1 89;\red0\g reen57\blu e198;\red0 \green48\b lue207;\re d0\green39 \blue216;\ red0\green 30\blue225 ;\red0\gre en21\blue2 34;\red0\g reen12\blu e243
Your routine only gives this..
;\red255\green0\blue0;\red 251\green1 29\blue0;\ red246\gre en153\blue 0;\red242\ green169\b lue0;\red2 37\green18 2\blue0;\r ed231\gree n192\blue0 ;\red226\g reen201\bl ue0;\red21 9\green209 \blue0;\re d213\green 216\blue0; \red205\gr een223\blu e0;\red197 \green229\ blue0;\red 187\green2 34\blue0;\ red176\gre en239\blue 0;\red162\ green244\b lue0;\red1 42\green24 9\blue0;\r ed108\gree n253\blue0 ;\red0\gre en255\blue 0;\red0\gr een249\blu e142;\red0 \green244\ blue162;\r ed0\green2 39\blue176 ;\red0\gre en234\blue 187;\red0\ green229\b lue197;\re d0\green22 3\blue205; \red0\gree n216\blue2 13;\red0\g reen209\bl ue219;\red 0\green201 \blue226;\ red0\green 192\blue23 1;\red0\gr een182\blu e237;\red0 \green169\ blue242;\r ed0\green1 53\blue246 ;\red0\gre en129\blue 251;\red0\ green0\blu e255
Because it's more than 32 steps
OK, so this is a simple problem to fix then surely,
Thanks for ALL your help, really appreciated.. i only had this problem for the last 2 years :)
what it does now is, pass in the colors, get back just the red/blue/green like this..
Var i, L, pClr, pClr_bak: integer;
Clr: TColor;
RS: string;
Begin
// we shell limit color table to some PalletteSteps
// there would be no more then PaletteSteps color in color table
// create clortable
{ PaletteSteps:=32;
If Length(Msg)<32 Then
PaletteSteps:=Length(Msg);
PaletteSteps:=Length(Msg) Div NColors;
for i:=0 to PaletteSteps-1 do begin
Clr:= Palette(i);
RS:=RS+ ';\red'+IntToStr(GetBValue
// BuildStr:=BuildStr+';'+'\r
end;
L:=Length(msg);
//stuff string with color modifiers when needed
pClr_bak:=-1;
{ for i:=0 to L-1 do begin
pClr:=round(1+(PaletteStep
if pClr <> pClr_bak then //edge found
begin
RS:=RS+ '\cf'+IntToStr(pClr)+' '+copy(msg,i+1,1);
pClr_bak:=pClr;
end
else //no color modifier - use current color
RS:=RS+copy(msg,i+1,1);
end;
//finalize}
// RS:=RS+'\cf0\par}'; // reset to default color +LF+CR
result:=RS;
That's exactly the string i need to pass back, just the RGB and since Tcolor is BGR and not RGB i swapped them around..
the problem it's having now is that it stops short, my old routine would produce stuff like this
//my routine
RicheditFadeStr('$FF0000,$
;\red255\green0\blue0;\red
//Now your routine
SetColors2('$FF0000,$00FF0
Data:=RicheditFadeStrold('
;\red255\green0\blue0;\red
//this is perfect great, that's how i wished mine went, RGB ;)
but then i start getting into the problems you see, sticking 32 colors into richedits stream for the color table for your version is great, my version i have to go and add RTF smiley faces and fonts and other stuff, that's why i produce JUST the RGB values (the color table)...
//My Routine for "abcabc"
('$FF0000,$00FF00,$0000FF'
;\red255\green0\blue0;\red
//Now your routine "abcabc"
SetColors2('$FF0000,$00FF0
Data:=RicheditFadeStrold('
;\red255\green0\blue0;\red
----------------------HERE
And again, still works :) it does the end colors and all, but for a longer message then it starts going funny..
//MyRoutine
Data:=RicheditFadeStr('$FF
;\red255\green0\blue0;\red
//YourRoutine for above
SetColors2('$FF0000,$00FF0
Data:=RicheditFadeStrold('
;\red255\green0\blue0;\red
First Part Red second Green third Blue - Perfect, great, now watch what happens..
OK I just discovered what the problem was i was doing all this testing, the problem comes when i hit more than 32 (graident steps)
Data:=RicheditFadeStr('$FF
Richedit1.Lines.Add(Data);
should look something like...
;\red255\green0\blue0;\red
Your routine only gives this..
;\red255\green0\blue0;\red
Because it's more than 32 steps
OK, so this is a simple problem to fix then surely,
Thanks for ALL your help, really appreciated.. i only had this problem for the last 2 years :)
Hi Craig_capel,
I hope my input was helpful.
sincerely,
odissey1
comments:
1.
..That's exactly the string i need to pass back, just the RGB and since Tcolor is BGR and not RGB i swapped them around..
-Do we have different graphic boards? I didn't have to swap them
2.
//My Routine for "abcabc"
('$FF0000,$00FF00,$0000FF' ,'abcabc') ; = \red255\green0\blue0;\red1 70\green85 .... <- here G=85
//Now your routine "abcabc"
SetColors2('$FF0000,$00FF0 0,$0000FF' );
Data:=RicheditFadeStrold(' abcabc');
\red255\green0\blue0;\red2 24\green20 3...<---he re G=203. this 'color curve' is controlled by GAMMA. you can tweak 0.5-0.8-1.0 to get desirable smoothness of color transition. This is the same image GAMMA as e.g. in Corel Photopoint.
3.
Data:=RicheditFadeStr('$FF 0000,$00FF 00,$0000FF ','abcabc1 2345678901 2345678901 2345678901 2345678901 234567890' );
Richedit1.Lines.Add(Data);
should look something like...
;\red255\green0\blue0;\red 246\green9 \blue0;\re d237\green 18\blue0;\ red228\gre en27\blue0 ;\red219\g reen36\blu e0;\red210 \green45\b lue0;\red2 01\green54 \blue0;\re d192\green 63\blue0;\ red183\gre en72\blue0 ;\red174\g reen81\blu e0;\red165 \green90\b lue0;\red1 56\green99 \blue0;\re d147\green 108\blue0; \red138\gr een117\blu e0;\red129 \green126\ blue0;\red 120\green1 35\blue0;\ red111\gre en144\blue 0;\red102\ green153\b lue0;\red9 3\green162 \blue0;\re d84\green1 71\blue0;\ red75\gree n180\blue0 ;\red66\gr een189\blu e0;\red57\ green198\b lue0;\red4 8\green207 \blue0;\re d39\green2 16\blue0;\ red30\gree n225\blue0 ;\red21\gr een234\blu e0;\red12\ green243\b lue0;\red0 \green255\ blue0;\red 0\green246 \blue9;\re d0\green23 7\blue18;\ red0\green 228\blue27 ;\red0\gre en219\blue 36;\red0\g reen210\bl ue45;\red0 \green201\ blue54;\re d0\green19 2\blue63;\ red0\green 183\blue72 ;\red0\gre en174\blue 81;\red0\g reen165\bl ue90;\red0 \green156\ blue99;\re d0\green14 7\blue108; \red0\gree n138\blue1 17;\red0\g reen129\bl ue126;\red 0\green120 \blue135;\ red0\green 111\blue14 4;\red0\gr een102\blu e153;\red0 \green93\b lue162;\re d0\green84 \blue171;\ red0\green 75\blue180 ;\red0\gre en66\blue1 89;\red0\g reen57\blu e198;\red0 \green48\b lue207;\re d0\green39 \blue216;\ red0\green 30\blue225 ;\red0\gre en21\blue2 34;\red0\g reen12\blu e243
Your routine only gives this..
;\red255\green0\blue0;\red 251\green1 29\blue0;\ red246\gre en153\blue 0;\red242\ green169\b lue0;\red2 37\green18 2\blue0;\r ed231\gree n192\blue0 ;\red226\g reen201\bl ue0;\red21 9\green209 \blue0;\re d213\green 216\blue0; \red205\gr een223\blu e0;\red197 \green229\ blue0;\red 187\green2 34\blue0;\ red176\gre en239\blue 0;\red162\ green244\b lue0;\red1 42\green24 9\blue0;\r ed108\gree n253\blue0 ;\red0\gre en255\blue 0;\red0\gr een249\blu e142;\red0 \green244\ blue162;\r ed0\green2 39\blue176 ;\red0\gre en234\blue 187;\red0\ green229\b lue197;\re d0\green22 3\blue205; \red0\gree n216\blue2 13;\red0\g reen209\bl ue219;\red 0\green201 \blue226;\ red0\green 192\blue23 1;\red0\gr een182\blu e237;\red0 \green169\ blue242;\r ed0\green1 53\blue246 ;\red0\gre en129\blue 251;\red0\ green0\blu e255
Because it's more than 32 steps
-True. I introduced PaletteSteps to experiment with colors perception and to make output text shorter. Just increase desirable PaletteSteps = 128, 256... could be done on-the-fly. Personally, I don't see color gradations with >=32. But this is subjective.
I hope my input was helpful.
sincerely,
odissey1
comments:
1.
..That's exactly the string i need to pass back, just the RGB and since Tcolor is BGR and not RGB i swapped them around..
-Do we have different graphic boards? I didn't have to swap them
2.
//My Routine for "abcabc"
('$FF0000,$00FF00,$0000FF'
//Now your routine "abcabc"
SetColors2('$FF0000,$00FF0
Data:=RicheditFadeStrold('
\red255\green0\blue0;\red2
3.
Data:=RicheditFadeStr('$FF
Richedit1.Lines.Add(Data);
should look something like...
;\red255\green0\blue0;\red
Your routine only gives this..
;\red255\green0\blue0;\red
Because it's more than 32 steps
-True. I introduced PaletteSteps to experiment with colors perception and to make output text shorter. Just increase desirable PaletteSteps = 128, 256... could be done on-the-fly. Personally, I don't see color gradations with >=32. But this is subjective.
Here is 3-color example.
unit RainbowText_1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls,
Math;
type
TForm1 = class(TForm)
Memo1: TMemo;
RichEdit1: TRichEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function AdjustGamma(Color: double): Integer;
//const Gamma = 0.5;
begin
if Color = 0 then result := 0 //don't want 0^x = 1 for x <> 0
// else result := round(255 * Power(Color/255, Gamma) );
else result := round(255 * sqrt(Color/255) );
end;
function Palette3 (C1,C2,C3: TColor; iMax, i: integer): TColor;
var R, G, B: double;
R1,R2,R3,G1,G2,G3,B1,B2,B3
StartColor,MiddleColor,End
i2: integer;
begin
StartColor :=C1;
MiddleColor:=C2;
EndColor :=C3;
R1:=GetRValue(StartColor);
G1:=GetGValue(StartColor);
B1:=GetBValue(StartColor);
R2:=GetRValue(MiddleColor)
G2:=GetGValue(MiddleColor)
B2:=GetBValue(MiddleColor)
R3:=GetRValue(EndColor);
G3:=GetGValue(EndColor);
B3:=GetBValue(EndColor);
//two-color palette C1->C3
// R := R1 + (R3-R1) * i / iMax;
// G := G1 + (G3-G1) * i / iMax;
// B := B1 + (B3-B1) * i / iMax;
//3-color palette C1->C2->C3
i2:=iMax div 2;
if i <= i2 then begin
R := R1 + (R2-R1) * i / i2;
G := G1 + (G2-G1) * i / i2;
B := B1 + (B2-B1) * i / i2;
end
else begin
R := R2 + (R3-R2) * (i-i2) / (iMax-i2);
G := G2 + (G3-G2) * (i-i2) / (iMax-i2);
B := B2 + (B3-B2) * (i-i2) / (iMax-i2);
end;
// result:=RGB( round(R), round(G), round(B) );
//or you can smooth transition effect
result:=RGB( AdjustGamma(R), AdjustGamma(G), AdjustGamma(B) );
end;
function CreateRTFFadeStr1(C1,C2,C3
Var i, L: integer;
Clr: TColor;
RS: string;
Begin
RS:= '{\rtf1\ansi\ansicpg1252\d
+'\viewkind4\uc1\pard\f0\f
//create clortable
RS:=RS+ '{\colortbl; ';
L:=Length(msg);
for i:=1 to L do begin
Clr:= Palette3(C1,C2,C3,L,i);
RS:=RS+ '\red' +IntToStr(GetRValue(Clr))
+ '\green'+IntToStr(GetGValu
+ '\blue' +IntToStr(GetBValue(Clr))+
end;
RS:=RS+ '}';
//add string
for i:=1 to L do begin
RS:=RS+ '\cf'+IntToStr(i)+' '+copy(msg,i,1);
end;
//finalize
RS:=RS+'\cf0\par}'; // default color +LF+CR
result:=RS;
End;
procedure TForm1.Button1Click(Sender
begin
//3-color transition clRed->clYellow->clBlue
RichEdit1.Text:=CreateRTFF
end;
regards,
odissey1
end.