workbench/libs/lcms2/utils/delphi/demo1.pas

   1 unit demo1;
   2
   3 interface
   4
   5 uses
   6   Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   7   ExtCtrls, StdCtrls, ExtDlgs, lcms2dll, ComCtrls;
   8
   9 type
  10   TForm1 = class(TForm)
  11
  12     Image1: TImage;
  13     Image2: TImage;
  14     Panel1: TPanel;
  15     Splitter1: TSplitter;
  16     Button2: TButton;
  17     ComboBoxInput: TComboBox;
  18     ComboBoxOutput: TComboBox;
  19     Label1: TLabel;
  20     Label2: TLabel;
  21     WBCompensation: TCheckBox;
  22     NoTransform: TCheckBox;
  23     RadioGroup1: TRadioGroup;
  24     OpenPictureDialog1: TOpenPictureDialog;
  25     Button1: TButton;
  26     ProgressBar1: TProgressBar;
  27     ComboBoxIntent: TComboBox;
  28     Label3: TLabel;
  29     Button3: TButton;
  30     Button4: TButton;
  31     OpenDialog1: TOpenDialog;
  32     Label4: TLabel;
  33     ScrollBar1: TScrollBar;
  34
  35     procedure Button2Click(Sender: TObject);
  36     procedure Button1Click(Sender: TObject);
  37     procedure Button3Click(Sender: TObject);
  38     procedure Button4Click(Sender: TObject);
  39     procedure ComboBoxIntentChange(Sender: TObject);
  40     procedure ScrollBar1Change(Sender: TObject);
  41   private
  42     { Private declarations }
  43     function ComputeFlags: DWORD;
  44
  45   public
  46     constructor Create(Owner: TComponent); Override;
  47     { Public declarations }
  48   end;
  49
  50 var
  51   Form1: TForm1;
  52
  53 implementation
  54
  55 {$R *.DFM}
  56
  57 CONST
  58   IS_INPUT = $1;
  59   IS_DISPLAY = $2;
  60   IS_COLORSPACE = $4;
  61   IS_OUTPUT = $8;
  62   IS_ABSTRACT = $10;
  63
  64 VAR
  65    IntentCodes: array [0 .. 20] of cmsUInt32Number;
  66
  67 FUNCTION InSignatures(Signature: cmsProfileClassSignature;  dwFlags: DWORD): Boolean;
  68 BEGIN
  69
  70   if (((dwFlags AND IS_DISPLAY) <> 0) AND (Signature = cmsSigDisplayClass)) then
  71     InSignatures := TRUE
  72   else if (((dwFlags AND IS_OUTPUT) <> 0) AND (Signature = cmsSigOutputClass))
  73     then
  74     InSignatures := TRUE
  75   else if (((dwFlags AND IS_INPUT) <> 0) AND (Signature = cmsSigInputClass))
  76     then
  77     InSignatures := TRUE
  78   else if (((dwFlags AND IS_COLORSPACE) <> 0) AND
  79       (Signature = cmsSigColorSpaceClass)) then
  80     InSignatures := TRUE
  81   else if (((dwFlags AND IS_ABSTRACT) <> 0) AND
  82       (Signature = cmsSigAbstractClass)) then
  83     InSignatures := TRUE
  84   else
  85     InSignatures := FALSE
  86 END;
  87
  88 PROCEDURE FillCombo(var Combo: TComboBox; Signatures: DWORD);
  89 var
  90   Files, Descriptions: TStringList;
  91   Found: Integer;
  92   SearchRec: TSearchRec;
  93   Path, Profile: String;
  94   Dir: ARRAY [0 .. 1024] OF Char;
  95   hProfile: cmsHPROFILE;
  96   Descrip: array [0 .. 256] of Char;
  97 begin
  98   Files := TStringList.Create;
  99   Descriptions := TStringList.Create;
 100   GetSystemDirectory(Dir, 1023);
 101   Path := String(Dir) + '\SPOOL\DRIVERS\COLOR\';
 102   Found := FindFirst(Path + '*.ic?', faAnyFile, SearchRec);
 103   while Found = 0 do
 104   begin
 105     Profile := Path + SearchRec.Name;
 106     hProfile := cmsOpenProfileFromFile(PAnsiChar(AnsiString(Profile)), 'r');
 107     if (hProfile <> NIL) THEN
 108     begin
 109
 110       if ((cmsGetColorSpace(hProfile) = cmsSigRgbData) AND InSignatures
 111           (cmsGetDeviceClass(hProfile), Signatures)) then
 112       begin
 113         cmsGetProfileInfo(hProfile, cmsInfoDescription, 'EN', 'us', Descrip,
 114           256);
 115         Descriptions.Add(Descrip);
 116         Files.Add(Profile);
 117       end;
 118       cmsCloseProfile(hProfile);
 119     end;
 120
 121     Found := FindNext(SearchRec);
 122
 123   end;
 124   FindClose(SearchRec);
 125   Combo.Items := Descriptions;
 126   Combo.Tag := Integer(Files);
 127 end;
 128
 129 // A rather simple Logger... note the "cdecl" convention
 130 PROCEDURE ErrorLogger(ContextID: cmsContext; ErrorCode: cmsUInt32Number;
 131   Text: PAnsiChar); Cdecl;
 132 begin
 133   MessageBox(0, PWideChar(WideString(Text)), 'Something is going wrong...',
 134     MB_OK OR MB_ICONWARNING or MB_TASKMODAL);
 135 end;
 136
 137 constructor TForm1.Create(Owner: TComponent);
 138 var
 139   IntentNames: array [0 .. 20] of PAnsiChar;
 140   i, n: Integer;
 141 begin
 142   inherited Create(Owner);
 143
 144    // Set the logger
 145   cmsSetLogErrorHandler(ErrorLogger);
 146
 147   ScrollBar1.Min := 0;
 148   ScrollBar1.Max := 100;
 149
 150   FillCombo(ComboBoxInput, IS_INPUT OR IS_COLORSPACE OR IS_DISPLAY);
 151   FillCombo(ComboBoxOutput, $FFFF  );
 152
 153
 154   // Get the supported intents
 155   n := cmsGetSupportedIntents(20, @IntentCodes, @IntentNames);
 156
 157
 158   ComboBoxIntent.Items.BeginUpdate;
 159   ComboBoxIntent.Items.Clear;
 160   for i:= 0 TO n - 1 DO
 161     ComboBoxIntent.Items.Add(String(IntentNames[i]));
 162
 163   ComboBoxIntent.ItemIndex := 0;
 164   ComboBoxIntent.Items.EndUpdate;
 165 end;
 166
 167
 168
 169 procedure TForm1.ScrollBar1Change(Sender: TObject);
 170 var d: Integer;
 171     s: String;
 172 begin
 173      d := ScrollBar1.Position;
 174      Str(d, s);
 175      Label4.Caption := 'Adaptation state '+s + '% (Abs. col only)';
 176 end;
 177
 178 procedure TForm1.Button2Click(Sender: TObject);
 179 begin
 180   if OpenPictureDialog1.Execute then
 181   begin
 182     Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
 183     Image1.Picture.Bitmap.PixelFormat := pf24bit;
 184
 185     Image2.Picture.LoadFromFile(OpenPictureDialog1.FileName);
 186     Image2.Picture.Bitmap.PixelFormat := pf24bit;
 187
 188   end
 189 end;
 190
 191 function SelectedFile(var Combo: TComboBox): string;
 192 var
 193   List: TStringList;
 194   n: Integer;
 195 begin
 196
 197   List := TStringList(Combo.Tag);
 198   n := Combo.ItemIndex;
 199   if (n >= 0) then
 200     SelectedFile := List.Strings[n]
 201   else
 202     SelectedFile := Combo.Text;
 203 end;
 204
 205 procedure TForm1.ComboBoxIntentChange(Sender: TObject);
 206 begin
 207    ScrollBar1.Enabled := (ComboBoxIntent.itemIndex = 3);
 208 end;
 209
 210 function TForm1.ComputeFlags: DWORD;
 211 var
 212   dwFlags: DWORD;
 213 begin
 214   dwFlags := 0;
 215   if (WBCompensation.Checked) then
 216   begin
 217     dwFlags := dwFlags OR cmsFLAGS_BLACKPOINTCOMPENSATION
 218   end;
 219
 220   if (NoTransform.Checked) then
 221   begin
 222     dwFlags := dwFlags OR cmsFLAGS_NULLTRANSFORM
 223   end;
 224
 225   case RadioGroup1.ItemIndex of
 226     0:
 227       dwFlags := dwFlags OR cmsFLAGS_NOOPTIMIZE;
 228     1:
 229       dwFlags := dwFlags OR cmsFLAGS_HIGHRESPRECALC;
 230     3:
 231       dwFlags := dwFlags OR cmsFLAGS_LOWRESPRECALC;
 232   end;
 233
 234   ComputeFlags := dwFlags
 235 end;
 236
 237 procedure TForm1.Button1Click(Sender: TObject);
 238 var
 239   Source, Dest: String;
 240   hSrc, hDest: cmsHPROFILE;
 241   xform: cmsHTRANSFORM;
 242   i, PicW, PicH: Integer;
 243   Intent: Integer;
 244   dwFlags: DWORD;
 245 begin
 246
 247   Source := SelectedFile(ComboBoxInput);
 248   Dest := SelectedFile(ComboBoxOutput);
 249
 250   dwFlags := ComputeFlags;
 251
 252   Intent := IntentCodes[ComboBoxIntent.ItemIndex];
 253
 254   cmsSetAdaptationState(  ScrollBar1.Position / 100.0 );
 255
 256   if (Source <> '') AND (Dest <> '') then
 257   begin
 258     hSrc := cmsOpenProfileFromFile(PAnsiChar(AnsiString(Source)), 'r');
 259     hDest := cmsOpenProfileFromFile(PAnsiChar(AnsiString(Dest)), 'r');
 260
 261     if (hSrc <> Nil) and (hDest <> Nil) then
 262     begin
 263       xform := cmsCreateTransform(hSrc, TYPE_BGR_8, hDest, TYPE_BGR_8, Intent,
 264         dwFlags);
 265     end
 266     else
 267     begin
 268       xform := nil;
 269     end;
 270
 271     if hSrc <> nil then
 272     begin
 273       cmsCloseProfile(hSrc);
 274     end;
 275
 276     if hDest <> Nil then
 277     begin
 278       cmsCloseProfile(hDest);
 279     end;
 280
 281     if (xform <> nil) then
 282     begin
 283
 284       PicW := Image2.Picture.width;
 285       PicH := Image2.Picture.height;
 286       ProgressBar1.Min := 0;
 287       ProgressBar1.Max := PicH;
 288       ProgressBar1.Step := 1;
 289
 290       for i := 0 TO (PicH - 1) do
 291       begin
 292         if ((i MOD 100) = 0) then
 293           ProgressBar1.Position := i;
 294
 295         cmsDoTransform(xform, Image1.Picture.Bitmap.Scanline[i],
 296           Image2.Picture.Bitmap.Scanline[i], PicW);
 297
 298       end;
 299       ProgressBar1.Position := PicH;
 300
 301       cmsDeleteTransform(xform);
 302
 303     end;
 304
 305     Image2.Repaint;
 306     ProgressBar1.Position := 0;
 307   end
 308 end;
 309
 310 procedure TForm1.Button3Click(Sender: TObject);
 311 begin
 312   if OpenDialog1.Execute then
 313     ComboBoxInput.Text := OpenDialog1.FileName;
 314 end;
 315
 316 procedure TForm1.Button4Click(Sender: TObject);
 317 begin
 318   if OpenDialog1.Execute then
 319     ComboBoxOutput.Text := OpenDialog1.FileName;
 320 end;
 321
 322 end.