SOURCE CODE v1.7.5
program sipc;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.Title := 'Scanner ICC Profile Creator';
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, PJShellFolders, ExtCtrls, ExtDlgs, ShellAPI,
INIFILES, registry, ieview, imageenview, ieopensavedlg, jpeg, WinXP,
ShFolder, Shlobj, AdvSmoothPanel, AdvGroupBox, AdvOfficeButtons,
AdvGlassButton, AdvPanel, AutoUpgrader, ComCtrls, cxdrive10, imageenio,
Lucombo, dblucomb;
type
TForm1 = class(TForm)
PJDlg1: TPJBrowseDialog;
SaveDialog1: TSaveDialog;
OpenDialog1: TOpenImageEnDialog;
OpenDialog2: TOpenDialog;
AdvSmoothPanel1: TAdvSmoothPanel;
WinXP1: TWinXP;
AdvSmoothPanel2: TAdvSmoothPanel;
AdvSmoothPanel3: TAdvSmoothPanel;
AdvSmoothPanel4: TAdvSmoothPanel;
ImgLabel: TLabel;
AdvPanel1: TAdvPanel;
image1: TImageEnView;
TargetBtn: TAdvGlassButton;
CaptureBtn: TAdvGlassButton;
ReferenceBtn: TAdvGlassButton;
RefLabel: TLabel;
AdvSmoothPanel5: TAdvSmoothPanel;
AdvSmoothPanel6: TAdvSmoothPanel;
AdvSmoothPanel7: TAdvSmoothPanel;
AdvSmoothPanel8: TAdvSmoothPanel;
scanner_edit: TDBLUEdit;
model_edit: TDBLUEdit;
descr_edit: TDBLUEdit;
copy_edit: TDBLUEdit;
Label1: TLabel;
Label4: TLabel;
Label6: TLabel;
Label7: TLabel;
RadioGroup2: TAdvOfficeRadioGroup;
RadioGroup1: TAdvOfficeRadioGroup;
AdvPanel2: TAdvPanel;
HelpBtn: TAdvGlassButton;
ExitBtn: TAdvGlassButton;
CreateBtn: TAdvGlassButton;
UpgBtn: TAdvGlassButton;
upg1: TAutoUpgrader;
UpPanel: TAdvSmoothPanel;
ProgressBar: TProgressBar;
ProgLbl: TLabel;
AdvGlassButton1: TAdvGlassButton;
CheckBtn: TAdvGlassButton;
SetupBtn: TAdvGlassButton;
ImageEnIO1: TImageEnIO;
Label2: TLabel;
procedure TargetBtnClick(Sender: TObject);
procedure RefrenceBtnClick(Sender: TObject);
procedure ExitBtnClick(Sender: TObject);
procedure CreateBtnClick(Sender: TObject);
procedure Proc_run(ProgramName : String; Wait: Boolean);
procedure FormCreate(Sender: TObject);
function FileDeleteRB(AFileName:string): boolean;
procedure HelpBtnClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
function FindWin: string;
procedure CaptureBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
function BrowseURL(const URL: string) : boolean;
function GetSpecialFolderPath(folder : integer) : string;
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure UpgBtnClick(Sender: TObject);
procedure upg1Done(Sender: TObject; FileSize: Integer);
procedure upg1Error(Sender: TObject);
procedure upg1NoUpdateAvailable(Sender: TObject);
procedure upg1Progress(Sender: TObject; TotalSize, ReadSize,
ReadPercents: Integer);
procedure AdvGlassButton1Click(Sender: TObject);
procedure FillIn;
private
{ Private declarations }
function RefreshDriveInfo(StateIndex: string): int64;
function Get_File_Size(const S: string): Int64;
function SpaceInfo: boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
icc_file, ref_file, out_file, tar_dir, ref_dir, prof_dir,
scanner, model, descr, copyright, common: string;
m, alg: string[1];
btn_flag, temp_img, cancel_scan: boolean;
stateindex: integer;
implementation
uses Unit3;
{$R *.dfm}
procedure TForm1.TargetBtnClick(Sender: TObject);
begin
OpenDialog1.Filter:= 'TIFF images (*.tif; *.tiff)|*.tif;*.tiff';
OPenDIalog1.InitialDir:=tar_dir;
OpenDialog1.FileName:='';
If OpenDialog1.Execute then
begin
icc_file:= OpenDialog1.FileName;
tar_dir:= ExtractFilePath(OpenDialog1.FileName);
ImgLabel.Caption:= ExtractFileName(OpenDialog1.FileName);
try
Image1.IO.LoadFromFile(OpenDialog1.FileName);
except
Image1.Blank;
Showmessage('Error opening the image');
end;
end
else
Image1.Blank;
end;
procedure TForm1.upg1Done(Sender: TObject; FileSize: Integer);
begin
Application.MessageBox('Upgrade done. Press OK to restart program', PChar(Application.Title), mb_Ok or mb_IconInformation);
UpPanel.Visible:=false;
end;
procedure TForm1.upg1Error(Sender: TObject);
begin
Application.MessageBox(PChar('An error has occurred on upgrading.'#13#10#10'Possible reasons:'#13#10 +
' 1. No Internet connection or connection lost.'#13#10 + ' 2. Update file not found.'#13#10 + ' 3. User aborted upgrade.'), PChar(Application.Title), mb_Ok or mb_IconStop);
UpPanel.Visible:=false;
end;
procedure TForm1.upg1NoUpdateAvailable(Sender: TObject);
begin
Application.MessageBox('No update available.', PChar(Application.Title), mb_Ok or mb_IconInformation);
end;
procedure TForm1.upg1Progress(Sender: TObject; TotalSize, ReadSize,
ReadPercents: Integer);
begin
UpPanel.Visible:=true;
ProgressBar.Position := ReadPercents;
ProgLbl.Caption:='Download Progress: ' + IntToStr(ReadPercents) + '% done...';
end;
procedure TForm1.RefrenceBtnClick(Sender: TObject);
begin
OpenDialog2.Filter:= 'Reference Files (*.txt; *q60; *.it8; *.cgt; *.cgats)|*.txt; *.q60; *.it8; *.cgt; *.cgats';
OpenDialog2.InitialDir:= ref_dir;
OpenDialog2.FileName:='';
If OpenDialog2.Execute then
begin
btn_flag:=true;
ref_file:= OpenDialog2.FileName;
ref_dir:= ExtractFilePath(OpenDialog2.FileName);
RefLabel.Caption:=ExtractFileName(OpenDialog2.FileName);
end
else
begin
ref_file:='';
btn_flag:=false;
end;
end;
procedure TForm1.ExitBtnClick(Sender: TObject);
begin
close;
end;
procedure TForm1.CreateBtnClick(Sender: TObject);
var
proc: textfile;
f_path, fle, sc, md, desc, cop, w_dir, test_dir, test_dir2: string;
error: integer;
begin
Case RadioGroup1.ItemIndex of
0: m:='l';
1: m:='m';
2: m:='h';
3: m:='u';
else
m:='m';
end;
case RadioGroup2.ItemIndex of
0: alg:= 'l';
1: alg:= 'x';
2: alg:= 'g';
3: alg:= 's';
else
alg:='l';
end;
If SpaceInfo then
begin
If (btn_flag) AND (Image1.IEBitmap.Height>1) then
begin
test_dir:= extractFilePath(icc_file);
test_dir2:= test_dir+'testdir_'+inttostr(random(10000));
{$IOChecks off}
MkDir(test_dir2);
error := IOResult;
if error = 0 then
begin
RmDir(test_dir2);
{$IOChecks on}
f_path:=ExtractFilePath(ref_file);
If scanner_edit.Text='' then
sc:='Scanner_SIPC'
else
sc:=scanner_edit.Text;
If model_edit.Text='' then
md:='Model_SIPC'
else
md:=model_edit.Text;
If descr_edit.Text='' then
desc:='Profile_SIPC'
else
desc:=descr_edit.Text;
If copy_edit.Text='' then
cop:='Copyright_SIPC'
else
cop:=copy_edit.Text;
fle:= common+'\sipc\proc.bat';
Assignfile(proc, fle);
Rewrite(proc);
Writeln(proc, '@echo off');
Writeln(proc, '"'+ExtractFilePath(Application.ExeName)+'argyll\bin\scanin" -v "'+icc_file+'" "'+ExtractFilePath(Application.ExeName)+
'argyll\ref\It8.cht" "'+ref_file+'"');
Closefile(proc);
Proc_Run(fle, true);
If FileExists(ChangeFileExt(icc_file, '.ti3')) then
begin
AssignFile(proc, fle);
Rewrite(proc);
Writeln(proc, '@echo off');
Writeln(proc, '"'+ExtractFilePath(Application.ExeName)+'argyll\bin\colprof" -v -A"'+sc+'" -M"'+md+'" -D"'+desc+'" -C"'+cop+'" -q'+m+' -a'+alg+' "'+
ChangeFileExt(icc_file, '')+'"');
CloseFile(proc);
Proc_Run(fle, true);
w_dir:=FindWin;
SaveDialog1.FileName:='';
SaveDialog1.InitialDir:=prof_dir;
SaveDialog1.DefaultExt:= '*.icm';
SaveDialog1.Filter:= 'ICC Profile File (*.icm)|*.icm';
SaveDialog1.Title:= 'Save Profile';
If SaveDialog1.Execute then
begin
out_file:=SaveDialog1.FileName;
CopyFile(PChar(ChangeFileExt(icc_file, '.icm')), PChar(out_file), False);
MessageDlg('ICC Profile saved to:'+#13#13+ExtractFilePath(SaveDialog1.FileName), mtInformation, [mbOk], 0);
end;
If FileExists(ChangeFileExt(icc_file, '.icm')) then
FileDeleteRB(ChangeFileExt(icc_file, '.icm'));
If FileExists(fle) then
FileDeleteRB(fle);
If FileExists(ChangeFileExt(icc_File, '.ti3')) then
FileDeleteRB(ChangeFileExt(icc_File, '.ti3'));
end
else
MessageDlg('ERROR extracting RGB values. Cannot continue.', mtInformation, [mbOk], 0);
end
else
begin
{$IOChecks on}
ShowMessage('ERROR! Please make sure that the user have sufficient rights to process the IT8 image file in the current folder or the folder is not read-only.');
exit;
end;
end
else
MessageDlg('Please select valid target and reference file.', mtInformation,
[mbOk], 0);
end
else
exit;
end;
procedure TForm1.Proc_Run(ProgramName : String; Wait: Boolean);
var
StartInfo : TStartupInfo;
ProcInfo : TProcessInformation;
CreateOK : Boolean;
begin
{ fill with known state }
FillChar(StartInfo,SizeOf(TStartupInfo),#0);
FillChar(ProcInfo,SizeOf(TProcessInformation),#0);
StartInfo.cb := SizeOf(TStartupInfo);
CreateOK := CreateProcess(nil, PChar(ProgramName), nil, nil,False,
CREATE_NEW_PROCESS_GROUP+NORMAL_PRIORITY_CLASS,
nil, nil, StartInfo, ProcInfo);
{ check to see if successful }
if CreateOK then
begin
//may or may not be needed. Usually wait for child processes
if Wait then
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end
else
begin
ShowMessage('Unable to run program.');
end;
CloseHandle(ProcInfo.hProcess);
CloseHandle(ProcInfo.hThread);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=VK_F1 then
BrowseURL(ExtractFilePath(Application.ExeName)+'sipc.html');
end;
procedure TForm1.FormCreate(Sender: TObject);
var
myINI : TINIFile;
begin
common:= GetSpecialFolderPath(26);
if NOT (directoryexists(common+'\sipc')) then
begin
{$I-}
MkDir(common+'\sipc');
{$I+}
end;
Image1.Blank;
btn_flag:=false;
temp_img:=false;
myINI := TINIFile.Create(common+'\sipc\sipc.ini');
tar_dir:=myINI.ReadString('Directories', 'TARGET', GetSpecialFolderPath(CSIDL_MYPICTURES));
ref_dir:=myINI.ReadString('Directories', 'REFERENCE', GetSpecialFolderPath(CSIDL_COMMON_APPDATA)+'\sipc\Reference Files');
scanner_edit.Text:=myINI.ReadString('Settings', 'SCANNER', 'Device_name');
model_edit.Text:=myINI.ReadString('Settings', 'MODEL', 'Model');
descr_edit.Text:=myINI.ReadString('Settings', 'DESCRIPTION', 'My_profile');
copy_edit.Text:=myINI.ReadString('Settings', 'COPYRIGHT', 'Copyright_free');
myINI.Free;
prof_dir:= FindWin+'\system32\spool\drivers\color';
end;
function TForm1.FileDeleteRB(AFileName:string): boolean;
var Struct: TSHFileOpStruct;
pFromc: array[0..255] of char;
Resultval: integer;
begin
if not FileExists(AFileName) then begin
Result := False;
exit;
end
else begin
fillchar(pfromc,sizeof(pfromc),0) ;
StrPcopy(pfromc,expandfilename(AFileName)+#0#0) ;
Struct.wnd := 0;
Struct.wFunc := FO_DELETE;
Struct.pFrom := pFromC;
Struct.pTo := nil;
Struct.fFlags:= FOF_ALLOWUNDO or FOF_NOCONFIRMATION
or FOF_SILENT;
Struct.fAnyOperationsAborted := false;
Struct.hNameMappings := nil;
Resultval := ShFileOperation(Struct) ;
Result := (Resultval = 0) ;
end;
end;
procedure TForm1.HelpBtnClick(Sender: TObject);
begin
BrowseURL(ExtractFilePath(Application.ExeName)+'sipc.html');
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
myINI : TINIFile;
begin
myINI := TINIFile.Create(common+'\sipc\sipc.ini');
myINI.WriteString('Directories', 'TARGET', tar_dir);
myINI.WriteString('Directories', 'REFERENCE', ref_dir);
myINI.WriteString('Settings', 'SCANNER', scanner_edit.text);
myINI.WriteString('Settings', 'MODEL', model_edit.text);
myINI.WriteString('Settings', 'DESCRIPTION', descr_edit.text);
myINI.WriteString('Settings', 'COPYRIGHT', copy_edit.text);
myINI.Free;
If FileExists(ExtractFilePath(Application.ExeName)+'temp.tif') then
FileDeleteRB(ExtractFilePath(Application.ExeName)+'temp.tif');
end;
function TForm1.FindWin:string;
var
PWindowsDir: array [0..255] of Char;
begin
GetWindowsDirectory(PWindowsDir,255);
Result:=StrPas(PWindowsDir);
end;
procedure TForm1.CaptureBtnClick(Sender: TObject);
var
ie: TImageEnView;
begin
image1.Blank;
ie:=TImageEnView.Create(nil);
FillIn;
ImageEnIO1.AttachedImageEn:= ie;
ImageEnIO1.SelectAcquireSource;
if ImageEnIO1.Acquire then
cancel_scan:=false
else
cancel_scan:=true;
image1.Assign(ie);
ie.free;
if NOT cancel_scan then
begin
if image1.Bitmap.Width>10 then
begin
Screen.Cursor:=crHourglass;
SaveDialog1.FileName:='';
SaveDialog1.InitialDir:= ExtractFileDrive(Application.ExeName)+'\';
SaveDialog1.DefaultExt:= '*.tif';
SaveDialog1.Filter:= 'TIFF Image (*.tif)|*.tif';
SaveDialog1.Title:= 'Please save the image.';
If SaveDialog1.Execute then
begin
Image1.IO.SaveToFileTIFF(SaveDialog1.FileName);
icc_file:= SaveDialog1.FileName;
imgLabel.Caption:= ExtractFileName(icc_file);
end
else
begin
Image1.Blank;
icc_file:='';
imgLabel.Caption:= '*.tif';
end;
Screen.Cursor:=crDefault;
end
else
begin
Image1.Blank;
icc_file:='';
imgLabel.Caption:= '*.tif';
end;
end;
end;
procedure TForm1.FillIn;
begin
ImageEnIO1.TWainParams.VisibleDialog:=true;
ImageEnIO1.TWainParams.ProgressIndicators:=true;
ImageEnIO1.TWainParams.PixelType.CurrentValue:= 2;
ImageEnIO1.TWainParams.YResolution.CurrentValue:=300;
ImageEnIO1.TWainParams.XResolution.CurrentValue:=300;
ImageEnIO1.TWainParams.BufferedTransfer:=true;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
Image1.LegacyBitmap:=false;
cancel_scan:= false;
end;
procedure TForm1.AdvGlassButton1Click(Sender: TObject);
begin
upg1.Abort;
UpPanel.Visible:=false;
end;
procedure TForm1.UpgBtnClick(Sender: TObject);
begin
upg1.CheckUpdate;
end;
function TForm1.SpaceInfo: boolean;
var
file_dr: string;
my_res, my_file: string;
i, j: int64;
begin
file_dr:=ExtractFileDrive(icc_file);
i:= Get_File_Size(icc_file);
j:= RefreshDriveInfo(File_dr);
if NOT (i=-1) then
begin
i:=i*2;
my_file:=formatfloat('0.00',i/1048576);
my_res:=formatfloat('0.00',(j/1048576));
if i>=j then
begin
result:=false;
showmessage('Not enough space on the disk. Free space: '+my_res+
'MB. Required minimum space: '+my_file+'MB');
end
else
result:=true;
end;
end;
function TForm1.BrowseURL(const URL: string) : boolean;
var
Browser: string;
begin
Result := True;
Browser := '';
with TRegistry.Create do
try
RootKey := HKEY_CLASSES_ROOT;
Access := KEY_QUERY_VALUE;
if OpenKey('\htmlfile\shell\open\command', False) then
Browser := ReadString('') ;
CloseKey;
finally
Free;
end;
if Browser = '' then
begin
Result := False;
Exit;
end;
Browser := Copy(Browser, Pos('"', Browser) + 1, Length(Browser)) ;
Browser := Copy(Browser, 1, Pos('"', Browser) - 1) ;
ShellExecute(0, 'open', PChar(Browser), PChar(URL), nil, SW_SHOW) ;
end;
function TForm1.GetSpecialFolderPath(folder : integer) : string;
const
SHGFP_TYPE_CURRENT = 0;
var
path: array [0..MAX_PATH] of char;
begin
if SUCCEEDED(SHGetFolderPath(0,folder,0,SHGFP_TYPE_CURRENT,@path[0])) then
Result := path
else
Result := '';
end;
function TForm1.RefreshDriveInfo(StateIndex: string): int64;
var
i: Integer;
begin
Result:=-1;
if StateIndex='C:' then
i:=2;
if StateIndex='D:' then
i:=3;
if StateIndex='E:' then
i:=4;
if StateIndex='F:' then
i:=5;
if StateIndex='G:' then
i:=6;
if StateIndex='H:' then
i:=7;
if StateIndex='I:' then
i:=8;
if StateIndex='J:' then
i:=9;
if StateIndex='K:' then
i:=10;
if StateIndex='L:' then
i:=11;
if StateIndex='M:' then
i:=12;
if StateIndex='N:' then
i:=13;
if StateIndex='O:' then
i:=14;
if StateIndex='P:' then
i:=15;
if StateIndex='Q:' then
i:=16;
if StateIndex='R:' then
i:=17;
if StateIndex='S:' then
i:=18;
if StateIndex='T:' then
i:=19;
if StateIndex='U:' then
i:=20;
if StateIndex='V:' then
i:=21;
if StateIndex='W:' then
i:=22;
if StateIndex='X:' then
i:=23;
if StateIndex='Y:' then
i:=24;
if StateIndex='Z:' then
i:=25;
if cxDrive[i].Available.AsBoolean then
Result:= cxDrive[i].Space.BytesAvailable.AsNumber;
end;
function TForm1.Get_File_Size(const S: string): Int64;
var
SearchRec: TSearchRec;
sgPath: string;
inRetval, I1: Integer;
begin
sgPath := ExpandFileName(s);
try
inRetval := FindFirst(ExpandFileName(s), faAnyFile, SearchRec);
if inRetval = 0 then
I1 := SearchRec.Size
else
I1 := -1;
finally
SysUtils.FindClose(SearchRec);
end;
Result := I1;
end;
end.
|