utils/delphi/demo1.pas

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