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