How to apply color profiles to produce real color?

[WojTec]

I'm trying get color like in Photoshop. For example for CMYK(0, 0, 100, 0) get RGB(255, 242, 0) instead FFFF00. Based on demo which is not clear for me I got something like this and don't know what next:

Delphi-Quellcode:

var
  IntentCodes: array [0..20] of cmsUInt32Number;

procedure GetProfiles(var ACombo: TComboBox; const AColorSpace: cmsColorSpaceSignature);
var
  Files, Descriptions: TStringList;
  Found: Integer;
  SearchRec: TSearchRec;
  Path, Profile: string;
  Dir: array [0..1024] of Char;
  hProfile: cmsHPROFILE;
  Descrip: array [0..256] of Char;
begin
  Files := TStringList.Create;
  Descriptions := TStringList.Create;
  GetSystemDirectory(Dir, 1023);
  Path := string(Dir) + '\spool\drivers\color\';

  Found := FindFirst(Path + '*.ic?', faAnyFile, SearchRec);
  try
    while Found = 0 do
    begin
      Profile := Path + SearchRec.Name;
      hProfile := cmsOpenProfileFromFile(PAnsiChar(AnsiString(Profile)), 'r');
      if (hProfile <> nil) then
      begin
        if (cmsGetColorSpace(hProfile) = AColorSpace) then
        begin
          cmsGetProfileInfo(hProfile, cmsInfoDescription, 'EN', 'us', Descrip, 256);
          Descriptions.Add(Descrip);
          Files.Add(Profile);
        end;
        cmsCloseProfile(hProfile);
      end;

      Found := FindNext(SearchRec);
    end;
  finally
    FindClose(SearchRec);
  end;

  ACombo.Items := Descriptions;
  ACombo.Tag := Integer(Files);
end;

function SelectedFile(var Combo: TComboBox): string;
var
  List: TStringList;
  n: Integer;
begin

  List := TStringList(Combo.Tag);
  n := Combo.ItemIndex;
  if (n >= 0) then
    SelectedFile := List.Strings[n]
  else
    SelectedFile := Combo.Text;
end;

procedure TForm2.Button1Click(Sender: TObject);
var
  Source, Dest: string;
  hSrc, hDest: cmsHPROFILE;
  xform: cmsHTRANSFORM;
  i, PicW, PicH: Integer;
  Intent: Integer;
  dwFlags: DWORD;
begin

  Source := SelectedFile(cbRGBProfiles);
  Dest := SelectedFile(cbCMYKProfiles);

  if cbCompensation.Checked then
    dwFlags := cmsFLAGS_BLACKPOINTCOMPENSATION
  else
    dwFlags := 0
  ;

  Intent := IntentCodes[cbIntents.ItemIndex];

  //cmsSetAdaptationState(cmsSetAdaptationState(-1));

  if (Source <> '') and (Dest <> '') then
  begin
    hSrc := cmsOpenProfileFromFile(PAnsiChar(AnsiString(Source)), 'r');
    hDest := cmsOpenProfileFromFile(PAnsiChar(AnsiString(Dest)), 'r');

    if (hSrc <> nil) and (hDest <> Nil) then
    begin
      xform := cmsCreateTransform(hSrc, TYPE_BGR_8, hDest, TYPE_BGR_8, Intent,
        dwFlags);
    end
    else
    begin
      xform := nil;
    end;

    if hSrc <> nil then
    begin
      cmsCloseProfile(hSrc);
    end;

    if hDest <> nil then
    begin
      cmsCloseProfile(hDest);
    end;

    if (xform <> nil) then
    begin
      cmsDoTransform(xform, { Input }, { Output }, 1);

      cmsDeleteTransform(xform);

    end;
  end
end;

procedure TForm2.FormCreate(Sender: TObject);
var
  IntentNames: array [0..20] of PAnsiChar;
  I, Count: Integer;
begin
  GetProfiles(cbRGBProfiles, cmsSigRgbData);
  GetProfiles(cbCMYKProfiles, cmsSigCmykData);

  Count := cmsGetSupportedIntents(20, @IntentCodes, @IntentNames);

  cbIntents.Items.BeginUpdate;
  for I := 0 to Count - 1 DO
    cbIntents.Items.Add(string(IntentNames[I]));

  cbIntents.ItemIndex := 0;
  cbIntents.Items.EndUpdate;
end;

:(

[freeway]

your sample code convert a RGB profile to a CMKY profile not even more

>How to apply color profiles to produce real color
FFFF00 + profile = RGB(255, 242, 0)
well, a icc profile reduce your colorspace at least

[WojTec]

Ok, but should be here:

Delphi-Quellcode:

{ Input }, { Output }

cmsDoTransform() is waiting for pointer to bitmap, if I see well in manual, I don't understand how to use it for simple color?

[freeway]

create a 1x1 bitmap
set this pixel to a single color

[WojTec]

Ok, I did it with 1x1 bitmap and finally I got this:

Delphi-Quellcode:

function CreateBitmap: TBitmap;
begin
  Result := TBitmap.Create;
  Result.SetSize(1, 1);
end;

function SingleColor(const AColor: TColor): TBitmap;
begin
  Result := CreateBitmap;
  Result.Canvas.Pixels[0, 0] := AColor;
end;

function GetColor(const ABitmap: TBitmap): TColor;
begin
  Result := ABitmap.Canvas.Pixels[0, 0];
end;

var
  SrcProfile, DstProfile: string;
  hSrc, hDest: cmsHPROFILE;
  Transform: cmsHTRANSFORM;
  Intent: Integer;
  dwFlags: DWORD;
  InColor, OutColor: TBitmap;
begin
  SrcProfile := TICCProfileItem(cbRGBProfiles.Items.Objects[cbRGBProfiles.ItemIndex]).Path;
  DstProfile := TICCProfileItem(cbCMYKProfiles.Items.Objects[cbCMYKProfiles.ItemIndex]).Path;

  if cbCompensation.Checked then
    dwFlags := cmsFLAGS_BLACKPOINTCOMPENSATION
  else
    dwFlags := 0
  ;

  Intent := IntentCodes[cbIntents.ItemIndex];

  //cmsSetAdaptationState(cmsSetAdaptationState(-1));

  if (SrcProfile <> '') and (DstProfile <> '') then
  begin
    hSrc := cmsOpenProfileFromFile(PAnsiChar(AnsiString(SrcProfile)), 'r');
    hDest := cmsOpenProfileFromFile(PAnsiChar(AnsiString(DstProfile)), 'r');

    if (hSrc <> nil) and (hDest <> nil) then
      Transform := cmsCreateTransform(hSrc, TYPE_BGR_8, hDest, TYPE_BGR_8,
        Intent, dwFlags)
    else
      Transform := nil
    ;

    if hSrc <> nil then
      cmsCloseProfile(hSrc);
    ;
    if hDest <> nil then
      cmsCloseProfile(hDest);
    ;

    InColor := SingleColor(RGB(255, 0, 0));
    OutColor := CreateBitmap;
    OutColor.Assign(InColor);

    if (Transform <> nil) then
    try
      cmsDoTransform(Transform, InColor.Scanline[0], OutColor.Scanline[0], 1);
    finally
      cmsDeleteTransform(Transform);
    end;

    Color := SingleColor(OutColor);
  end
end;

So, this should convert RGB to CMYK (here monitor RGB to paint CMYK) - I selected from list sRGB IEC6 1966-2.1 for RGB and US Web Coated (SWOP) v2 for CMYK. I expect CMYK red, but I got RGB red (same as input). What I'm doing wrong? :(

[freeway]

you create OutColor := CreateBitmap but where did you create Incolor ?

PS don´t forgot to release your created bitmaps