Mercurial > hgrepos > Python2 > PyMuPDF

comparison mupdf-source/thirdparty/lcms2/utils/delphi/demo1.pas @ 2:b50eed0cc0ef upstream

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
ADD: MuPDF v1.26.7: the MuPDF source as downloaded by a default build of PyMuPDF 1.26.4. The directory name has changed: no version number in the expanded directory now.
author Franz Glasner <fzglas.hg@dom66.de>
date Mon, 15 Sep 2025 11:43:07 +0200
parents
children
comparison
equal deleted inserted replaced
1:1d09e1dec1d9 2:b50eed0cc0ef
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.