1 unit demo1;
2 
3 interface
4 
5 uses
6   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7   ExtCtrls, StdCtrls, ExtDlgs, lcmsdll, 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 
33     procedure Button2Click(Sender: TObject);
34     procedure Button1Click(Sender: TObject);
35     procedure Button3Click(Sender: TObject);
36     procedure Button4Click(Sender: TObject);
37   private
38     { Private declarations }
ComputeFlagsnull39     function ComputeFlags: DWORD;
40 
41   public
42    constructor Create(Owner: TComponent); Override;
43     { Public declarations }
44   end;
45 
46 var
47   Form1: TForm1;
48 
49 implementation
50 
51 {$R *.DFM}
52 
53 CONST
54 IS_INPUT   = $1;
55 IS_DISPLAY = $2;
56 IS_COLORSPACE = $4;
57 IS_OUTPUT     = $8;
58 IS_ABSTRACT   = $10;
59 
60 
InSignaturesnull61 FUNCTION InSignatures(Signature:icProfileClassSignature; dwFlags: DWORD): Boolean;
62 BEGIN
63 
64         if (((dwFlags AND IS_DISPLAY) <> 0) AND (Signature = icSigDisplayClass)) then InSignatures  := TRUE
65         else
66         if (((dwFlags AND IS_OUTPUT) <> 0) AND (Signature = icSigOutputClass)) then InSignatures := TRUE
67         else
68         if (((dwFlags AND IS_INPUT) <> 0) AND (Signature = icSigInputClass)) then InSignatures := TRUE
69         else
70         if (((dwFlags AND IS_COLORSPACE) <> 0) AND (Signature = icSigColorSpaceClass)) then InSignatures := TRUE
71         else
72         if (((dwFlags AND IS_ABSTRACT) <> 0) AND (Signature = icSigAbstractClass)) then InSignatures := TRUE
73         else
74            InSignatures := FALSE
75 END;
76 
77 PROCEDURE FillCombo(var Combo: TComboBox; Signatures: DWORD);
78 var
79    Files, Descriptions : TStringList;
80    Found: Integer;
81    SearchRec: TSearchRec;
82    Path, Profile: String;
83    Dir: ARRAY[0..1024] OF Char;
84    hProfile : cmsHPROFILE;
85 begin
86        Files        := TStringList.Create;
87        Descriptions := TStringList.Create;
88        GetSystemDirectory(Dir, 1023);
89        Path := String(Dir) + '\SPOOL\DRIVERS\COLOR\';
90        Found := FindFirst(Path + '*.icm', faAnyFile, SearchRec);
91        while Found = 0 do
92        begin
93             Profile := Path + SearchRec.Name;
94             hProfile := cmsOpenProfileFromFile(PChar(Profile), 'r');
95             if (hProfile <> NIL) THEN
96             begin
97 
98              if  ((cmsGetColorSpace(hProfile) = icSigRgbData) AND
99                   InSignatures(cmsGetDeviceClass(hProfile), Signatures)) then
100              begin
101                           Descriptions.Add(cmsTakeProductDesc(hProfile));
102                           Files.Add(Profile);
103              end;
104              cmsCloseProfile(hProfile);
105             end;
106 
107             Found := FindNext(SearchRec);
108 
109        end;
110        FindClose(SearchRec);
111        Combo.Items := Descriptions;
112        Combo.Tag   := Integer(Files);
113 end;
114 
115 
116 constructor TForm1.Create(Owner: TComponent);
117 begin
118      inherited Create(Owner);
119      FillCombo(ComboBoxInput, IS_INPUT OR IS_COLORSPACE OR IS_DISPLAY);
120      FillCombo(ComboBoxOutput, $FFFF {IS_DISPLAY} );
121      ComboBoxIntent.ItemIndex := INTENT_PERCEPTUAL;
122 end;
123 
124 procedure TForm1.Button2Click(Sender: TObject);
125 begin
126      if OpenPictureDialog1.Execute then begin
127             Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
128             Image1.Picture.Bitmap.PixelFormat := pf24bit;
129             Image2.Picture.Bitmap := TBitmap.Create;
130             Image2.Picture.Bitmap.PixelFormat := pf24bit;
131             Image2.Picture.Bitmap.Dormant;
132             Image2.Picture.Bitmap.width  := Image1.Picture.Bitmap.width;
133             Image2.Picture.Bitmap.height := Image1.Picture.Bitmap.height;
134             end
135 end;
136 
SelectedFilenull137 function SelectedFile(var Combo: TComboBox):string;
138 var List: TStringList;
139     n: Integer;
140 begin
141 
142      List := TStringList(Combo.Tag);
143      n := Combo.ItemIndex;
144      if (n >= 0) then
145         SelectedFile := List.Strings[n]
146      else
147          SelectedFile := Combo.Text;
148 end;
149 
150 
ComputeFlagsnull151 function TForm1.ComputeFlags: DWORD;
152 var dwFlags: DWORD;
153 begin
154      dwFlags := 0;
155      if (WBCompensation.Checked) then
156      begin
157         dwFlags := dwFlags OR cmsFLAGS_WHITEBLACKCOMPENSATION
158      end;
159 
160      if (NoTransform.Checked) then
161      begin
162         dwFlags := dwFlags OR cmsFLAGS_NULLTRANSFORM
163      end;
164 
165 
166      case RadioGroup1.ItemIndex of
167      0: dwFlags := dwFlags OR cmsFLAGS_NOTPRECALC;
168      2: dwFlags := dwFlags OR cmsFLAGS_HIGHRESPRECALC;
169      3: dwFlags := dwFlags OR cmsFLAGS_LOWRESPRECALC;
170      end;
171 
172      ComputeFlags := dwFlags
173 end;
174 
175 procedure TForm1.Button1Click(Sender: TObject);
176 var
177   Source, Dest: String;
178   hSrc, hDest : cmsHPROFILE;
179   xform: cmsHTRANSFORM;
180   i, PicW, PicH: Integer;
181   Intent: Integer;
182   dwFlags : DWORD;
183 begin
184 
185 
186      Source := SelectedFile(ComboBoxInput);
187      Dest   := SelectedFile(ComboBoxOutput);
188 
189      dwFlags := ComputeFlags;
190 
191      Intent := ComboBoxIntent.ItemIndex;
192 
193      if (Source <> '') AND (Dest <> '') then
194      begin
195           hSrc := cmsOpenProfileFromFile(PChar(Source), 'r');
196           hDest:= cmsOpenProfileFromFile(PChar(Dest), 'r');
197 
198           xform := cmsCreateTransform(hSrc, TYPE_BGR_8, hDest, TYPE_BGR_8,
199                                            Intent, dwFlags);
200 
201 
202           PicW := Image2.Picture.Width;
203           PicH := Image2.Picture.Height;
204           ProgressBar1.Min := 0;
205           ProgressBar1.Max := PicH;
206           ProgressBar1.Step := 1;
207 
208           for i:= 0 TO (PicH -1) do
209           begin
210                if ((i MOD 100) = 0) then
211                               ProgressBar1.Position := i;
212 
213                cmsDoTransform(xform,
214                               Image1.Picture.Bitmap.Scanline[i],
215                               Image2.Picture.Bitmap.Scanline[i],
216                               PicW);
217 
218           end;
219           ProgressBar1.Position := PicH;
220 
221           cmsDeleteTransform(xform);
222           cmsCloseProfile(hSrc);
223           cmsCloseProfile(hDest);
224           Image2.Repaint;
225           ProgressBar1.Position := 0;
226      end
227 end;
228 
229 procedure TForm1.Button3Click(Sender: TObject);
230 begin
231  if OpenDialog1.Execute then
232   ComboBoxInput.Text:=OpenDialog1.FileName;
233 end;
234 
235 procedure TForm1.Button4Click(Sender: TObject);
236 begin
237  if OpenDialog1.Execute then
238   ComboBoxOutput.Text:=OpenDialog1.FileName;
239 end;
240 
241 end.
242