SRL Archive - Research & Development Lounge

{.Script Info:
# ScriptName  = Color Tolerance Ranges
# Author      = TOB (Tigiot)
# Description = Used to find the range of colors with a certain tolerance.
# Version     =
# Date        = August 17, 2007
# Comments    = The thing is weird, with a tolerance of 50 it will return more results for gaps of 1000 than 100.
/Script Info}
program ColorToleranceRanges;

const Color1 = 555555;
const Tol = 255;
const ColorGaps = 10;

var Color2, ColorsFile, NumberOfColors: Integer;
var Colors: string;

begin
  Color2:= Color1;
  repeat
    Color2:= Color2 - ColorGaps;
    if(Color2 > 16777215) then Color2:= 16777215;
    if(Color2 < 0) then Color2:= 0;
    if(SimilarColors(Color1, Color2, Tol)) then
    begin
      Colors:= IntToStr(Color2) + Chr(13) + trim(Colors);
      NumberOfColors:= NumberOfColors + 1;
      //Writeln(IntToStr(NumberOfColors));
    end else
      Break;
  until((Color2 = 16777215) or (Color2 = 0));
  Colors:= Colors + '---------' + Chr(13) + IntToStr(Color1) + Chr(13) + '---------';
  Color2:= Color1;
  repeat
    Color2:= Color2 + ColorGaps;
    if(Color2 > 16777215) then Color2:= 16777215;
    if(Color2 < 0) then Color2:= 0;
    if(SimilarColors(Color1, Color2, Tol)) then
    begin
      Colors:= trim(Colors) + Chr(13) + IntToStr(Color2);
      NumberOfColors:= NumberOfColors + 1;
      //Writeln(IntToStr(NumberOfColors));
    end else
      Break;
  until((Color2 = 16777215) or (Color2 = 0));
  Writeln(Colors);

  ColorsFile:= RewriteFile(AppPath + 'Colors.txt', False);
  WriteFileString(ColorsFile, Colors);
  CloseFile(ColorsFile);

  Writeln(IntToStr(NumberOfColors) + ' color(s).');
  Writeln('Filename: ' + AppPath + 'Colors.txt');
  ColorsFile:= OpenFile(AppPath + 'Colors.txt', False);
  Writeln('Filesize: ' + IntToStr(ColorsFile) + ' bytes.');
  CloseFile(ColorsFile);
end.

It's a bit odd with some things.

Open file in WordPad or the like (Notepad won't show the line breaks).

May I form this up?

Good job.

Go ahead.

Here you go:

program New;

var
  SantyForm : TForm;
  Label1 : TLabel;
  Colour, Tolerance, ColorGap : TEdit;
  PickColour, Button1, Button2 : TButton;
  Started : Boolean;
  Background : TImage;
  Colours : TMemo;

  ColorsFile, NumberOfColors, RedSwirl, TheColour, Color1, Color2, Tol, ColorGaps,
    x, y : Integer;
  Colors : string;

procedure CalculateColorTolerance; forward;

procedure GetTheColour(Senders : TObject);
begin
  PickColor(TheColour, x, y);
  Colour.Text := IntToStr(TheColour);
  Colour.Font.Color := TheColour;
  if TheColour < 3500000 then
  begin
    Colour.Color := clWhite;
  end else
    Colour.Color := clBlack;
end;

procedure Declare(Senders : TObject);
begin
  Started := True;
  Color1 := StrToInt(Colour.Text);
  Tol := StrToInt(Tolerance.Text);
  if (Tol > 255) then
    Tol := 255;
  ColorGaps := StrToInt(ColorGap.Text);
  CalculateColorTolerance;
end;

procedure Terminate(Senders : TObject);
begin
  Started := False;
  SantyForm.ModalResult := MrOk;
end;

procedure ColorToleranceForm;
begin
  SantyForm := CreateForm;
  with SantyForm do
  begin
    Position := poScreenCenter;
    BorderStyle := bsNone;
    FormStyle := fsStayOnTop;
    Caption := 'frmDesign';
    Position := poScreenCenter;
    ClientHeight := 330;
    ClientWidth := 300;
    Font.Color := clWindowText;
    Font.Name := 'MS Sans Serif';
  end;

  Background := TImage.Create(SantyForm);
  with Background do
  begin
    Parent := SantyForm;
    SetBounds(0, 0, 300, 330);
    RedSwirl := BitmapFromString(1000, 1, 'z78DAD597DB4E262110845F8933C3' +
      '250CF0FE8FB4F1034399C91A5DF36FA21715A374D187EAA6C798B' +
      '79F2B81159C6F583C98C1FB0DF9A7A901BCC00672BE71BEC1D30A' +
      'D841FE7B3B308270DE9CB961B8EF5F8244740F41A2E3CFA65B904' +
      '83BD9E8C4DBC94927EA4EDE3AA9ECC4DE31EEB00166C033601864' +
      '7BC0306018E46DC030F06AC030F00430131F260C138609C38461E' +
      '2C38467C233F164C236619B4370FE0095A70BDE726F157F2EF173' +
      'F91C258A15913D91AEA877066EC94C918C45C9A43B79EE53F2BF6' +
      'A51A446AB6A416A6AA4EE4B0F55949C45E1F879DBA3FF8655C3AA' +
      '61D5B8A561D5A274D0B25ABD8655EDD26B55BA0FDB1AA52B61A8F' +
      '6746B59BD0C4FE9A7970B6C8543A5BC0CABDC8827D589CFE544B7' +
      'E26D4132D35E303DDAA7581F58042FC12C9804A3601025788982E' +
      'ADC46B4A10AE9A293266A290FCDA48772DC433F53F4738B7E8AA8' +
      '284945BCD448F5D31F9AB9E47580A14479356028E6BC26170C579' +
      '357E6927707DB0BDB0BFF335619AB8CE719AB8C55C62A93E1CC5D' +
      '89F3891C266E495C9FF030C19FE04FF047CE479823CC11E608738' +
      '43972327032E0498039C01C600E9C0CF8C0AFC6E38387D9C3EC61' +
      'F6F8E0F1C1C3EC6076303B981DCC0E66C779C779B7CEC36FE1B7F' +
      '05BF82DFC162B8B95C5CA6280E9FBB8DC23CC4881579140623730' +
      'BC0763E462737EACFCDDCBF9283C97F057B9B71F7F16CDF6D38BF' +
      'F59E2AA12EF38D7EE9C78C955961C36C9ED3C39DFF98F52972AF5' +
      '1A27945DD320B52EA2817EB4B174B23593444B5534368FF6B60EA' +
      '3E8B3886EC7D1F3D2F6D67912FD57E98B7EFA65F5CEEEA328FD75' +
      '49DF35E9C7794AB47BD64B2F27E9F14B7ABFC94C98B2193A99215' +
      '166CB2533A7CA2CEAB23D1A995D4E665A945997650616998D4D66' +
      '6697592AD375496FCF5EF798CCE131BD75AAEBB4D757405F87E7D' +
      'BF1F95BF3DD37EBB9633889B1496682CCFF2E998FA7467BAADFFF' +
      '7107687263979D44F563453F417CCEA2A22ABB503F3BD207FDA87' +
      '254335574220AD9AAF07FD931AAD462C8B6EF643F4CB23796C76E' +
      '3F65B777B28BC66F6EF5F6B1D5C77FDAED5FBDE17F7DB7D7ADDE7' +
      'D73AB4F92492FDF4DE67C4F7DD8EDABD4284BD5A27CAF39F98E33' +
      'E7FBEEC3175FFF555FAC5F991E5D266A3A1DB4B7C726DD176471B' +
      '8E575F0E735F903257356ED');
    SafeCopyCanvas(GetBitmapCanvas(RedSwirl), Background.Canvas, 100, 0, 1000, 1, 0, 0, 2500, 900);
  end;

  Label1 := TLabel.Create(SantyForm);
  with Label1 do
  begin
    Parent := SantyForm;
    SetBounds(59, 12, 178, 28);
    Caption := 'Colour Tolerance Aid';
    with Font do
    begin
      Height := -24;
      Color := clYellow;
      Name := 'Monotype Corsiva';
    end;
  end;

  Colour := TEdit.Create(SantyForm);
  with Colour do
  begin
    Parent := SantyForm;
    SetBounds(50, 79, 96, 21);
    Font.Color := clWhite;
    Color := clBlack;
    Text := 'Colour';
  end;

  Tolerance := TEdit.Create(SantyForm);
  with Tolerance do
  begin
    Parent := SantyForm;
    SetBounds(163, 79, 96, 21);
    Color := clBlack;
    Font.Color := clWhite;
    Text := 'Tolerance';
  end;

  ColorGap := TEdit.Create(SantyForm);
  with ColorGap do
  begin
    Parent := SantyForm;
    SetBounds(106, 115, 96, 21);
    Color := clBlack;
    Font.Color := clWhite;
    Text := 'Colour Gap';
  end;

  PickColour := TButton.Create(SantyForm);
  with PickColour do
  begin
    Parent := SantyForm;
    SetBounds(7, 79, 36, 21);
    Caption := 'Pick';
    Font.Name := 'MS Sans Serif';
    OnClick := @GetTheColour;
  end;

  Button1 := TButton.Create(SantyForm);
  with Button1 do
  begin
    Parent := SantyForm;
    SetBounds(79, 158, 68, 25);
    Caption := 'Calculate';
    TabOrder := 12;
    OnClick := @Declare;
  end;

  Button2 := TButton.Create(SantyForm);
  with Button2 do
  begin
    Parent := SantyForm;
    SetBounds(163, 158, 68, 25);
    Caption := 'Cancel';
    TabOrder := 13;
    OnClick := @Terminate;
  end;

  Colours := TMemo.Create(SantyForm);
  with Colours do
  begin
    Parent := SantyForm;
    SetBounds(29, 200, 241, 121);
    Colours.Alignment := taCenter;
    Colours.Lines.Add('Colours');
  end;
end;

procedure SafeColorToleranceForm;
var
  V : TVariantArray;
begin
  SetArrayLength(V, 0);
  ThreadSafeCall('ColorToleranceForm', V);
end;

procedure ShowColorToleranceFormModal;
begin
  SantyForm.ShowModal;
end;

procedure SafeShowColorToleranceFormModal;
var
  V : TVariantArray;
begin
  SetArrayLength(V, 0);
  ThreadSafeCall('ShowColorToleranceFormModal', V);
end;

procedure MainColorToleranceForm;
begin
  try
    SafeColorToleranceForm;
    SafeShowColorToleranceFormModal;
  except
    WriteLn('An error seems to have occurred in: ColorToleranceForm');
  end;
end;

procedure CalculateColorTolerance;
begin
  Color2 := Color1;
  repeat
    Color2 := Color2 - ColorGaps;
    if (Color2 > 16777215) then Color2 := 16777215;
    if (Color2 < 0) then Color2 := 0;
    if (SimilarColors(Color1, Color2, Tol)) then
    begin
      Colors := IntToStr(Color2) + Chr(13) + trim(Colors);
      NumberOfColors := NumberOfColors + 1;
    end else
      Break;
  until ((Color2 = 16777215) or (Color2 = 0));
  Colors := Colors + '---------' + Chr(13) + IntToStr(Color1) + Chr(13) + '---------';
  Color2 := Color1;
  repeat
    Color2 := Color2 + ColorGaps;
    if (Color2 > 16777215) then Color2 := 16777215;
    if (Color2 < 0) then Color2 := 0;
    if (SimilarColors(Color1, Color2, Tol)) then
    begin
      Colors := trim(Colors) + Chr(13) + IntToStr(Color2);
      NumberOfColors := NumberOfColors + 1;
    end else
      Break;
  until ((Color2 = 16777215) or (Color2 = 0));
  Colours.Lines.Clear;
  Colours.Lines.Add(Colors);

  ColorsFile := RewriteFile(AppPath + 'Colors.txt', False);
  WriteFileString(ColorsFile, Colors);
  CloseFile(ColorsFile);

  Colours.Lines.Add(IntToStr(NumberOfColors) + ' color(s).');
  Colours.Lines.Add('Filename: ' + AppPath + 'Colors.txt');
  ColorsFile := OpenFile(AppPath + 'Colors.txt', False);
  Colours.Lines.Add('Filesize: ' + IntToStr(ColorsFile) + ' bytes.');
  CloseFile(ColorsFile);
end;

begin
  ClearDebug;
  GetSelf.WindowState := wsMinimized;
  MainColorToleranceForm;
  GetSelf.WindowState := wsNormal;
end.

Kewl lookin' …

I think I know what forward does… But what exactly?

It will let you declare a procedure so you can use it in a procedure then you can write the code for it later down in the script. It's useful for if 2 procedure's need each other.

Thanks.

nice job. now if, in that form, you cold have a little bar that would show each of those colours in a row, in the coluor that they actually are…:p

From: The Claw
nice job. now if, in that form, you cold have a little bar that would show each of those colours in a row, in the coluor that they actually are…:p

Lol, someone else could code that :P and like I said before if you had a big range you'd need to condense it somehow.

Does this just loop through tons of colors?

From: bullzeye95
Does this just loop through tons of colors?

Yes, it loops through comparing them with SimilarColors()