Convert color to/from HTML/fr

From Free Pascal wiki
Jump to: navigation, search

English (en) español (es) français (fr)

Cette unité a des fonctions qui convertissent une valeur TColor de/vers une chaîne de couleur HTML: #rrggbb. Elle peut aussi convertir des chaînes de couleur HTML: #rgb.

Auteur: User:Alextp

unit ATStringProc_HtmlColor;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, Graphics;
 
//convert TColor -> HTML color string #rrggbb
function SColorToHtmlColor(Color: TColor): string;
//convert string which starts with HTML color token #rgb, #rrggbb -> TColor, get len of color-string
function SHtmlColorToColor(s: string; out Len: integer; Default: TColor): TColor;
 
 
implementation
 
function IsCharWord(ch: char): boolean;
begin
  Result:= ch in ['a'..'z', 'A'..'Z', '_', '0'..'9'];
end;
 
function IsCharHex(ch: char): boolean;
begin
  Result:= ch in ['0'..'9', 'a'..'f', 'A'..'F'];
end;
 
function SColorToHtmlColor(Color: TColor): string;
var
  N: Longint;
begin
  if Color=clNone then
    begin Result:= ''; exit end;
  N:= ColorToRGB(Color);
  Result:= '#'+
    IntToHex(Red(N), 2)+
    IntToHex(Green(N), 2)+
    IntToHex(Blue(N), 2);
end;
 
function SHtmlColorToColor(s: string; out Len: integer; Default: TColor): TColor;
var
  N1, N2, N3: integer;
  i: integer;
begin
  Result:= Default;
  Len:= 0;
  if (s<>'') and (s[1]='#') then Delete(s, 1, 1);
  if (s='') then exit;
 
  //delete after first nonword char
  i:= 1;
  while (i<=Length(s)) and IsCharWord(s[i]) do Inc(i);
  Delete(s, i, Maxint);
 
  //allow only #rgb, #rrggbb
  Len:= Length(s);
  if (Len<>3) and (Len<>6) then exit;
 
  for i:= 1 to Len do
    if not IsCharHex(s[i]) then exit;
 
  if Len=6 then
  begin
    N1:= StrToInt('$'+Copy(s, 1, 2));
    N2:= StrToInt('$'+Copy(s, 3, 2));
    N3:= StrToInt('$'+Copy(s, 5, 2));
  end
  else
  begin
    N1:= StrToInt('$'+s[1]+s[1]);
    N2:= StrToInt('$'+s[2]+s[2]);
    N3:= StrToInt('$'+s[3]+s[3]);
  end;
 
  Result:= RGBToColor(N1, N2, N3);
end;
 
 
end.

Voir aussi