Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/delphi/navody/JBOOSTER.ZIP/Source/Support.pas

Pascal/Delphi Source File | 2002-06-15 | 63KB | 1,988 lines

(*************************************************************************)
(*                                jBooster                               *)
(*                        (c) [e-mail]                    *)
(*************************************************************************)
 Unit Support;
 {$J+,H+,A+,B-,I-}

 Interface

 Uses
  { standart }
    SysUtils, Windows, Classes,
  { vcl }
    StdCtrls, Controls, Graphics, Dialogs, Forms,
  { formats }
    JPeg,
  { private }
    Rasters;

(*************************************************************************)
(*                         customizable values                           *)
(*************************************************************************)
 Const
  { Application }
    AppName = 'jBooster';
    Version = '1.09b';
  { names }
    IniName = AppName + '.ini';
    LogName = AppName + '.log';
    HlpName = AppName + '.txt';
    ScvName = AppName + '.csv';
    DatName = AppName + '.dat';

(*************************************************************************)
(*                          report\error handlers                        *)
(*************************************************************************)
 Type
     PReportHandler = procedure (const Mssg: string; Prx: TMsgDlgType);

 procedure Alarm (const Mssg: string; Pfx: TMsgDlgType);
 function Confirm (const Wrn, Qst: string): boolean;
 procedure Error (const Name, Mssg: string);
 procedure SysError (const Name: string; RC: Dword);
 procedure Warning (const Name, Mssg: string);
 procedure Inform (const Mssg: string);

 Const
   { report handler }
     Report : PReportHandler = Alarm;
   { error count }
     Errors : integer = 0;
   { report prefixs }
     ErrPrefix = '!';
     BegPrefix = '?';
     EndPrefix = '=';
     AnyPrefix = ' ';

(*************************************************************************)
(*                              support                                  *)
(*************************************************************************)
 Const
  { special chars + prefix chars }
    Illegals = [#0..#31,'\','|','/','*','?',':','>','<','"','.'] + ['!','='];
  { digits }
    Numerics = ['0'..'9'];

 function StrToInt (const S: string; var I: integer): boolean;
 function StrToDateTime (const S: string; var DT: TDateTime): boolean;
 function PathDelimiter (const Path: string; Del: boolean = false): string;
 function SizeStr (W, H : integer): string;
 function FileSizeStr (Z: longword): string;
 function TrackToQuality (Track: integer): integer;
 function TrackToLikeness (Track: integer): integer;
 function isThumbnail (const FileName: string): boolean;
 function isValid: boolean;
 procedure AppTitle;
 function CatalogTime (var Time: TFileTime): boolean;
 function OpenText (var Txt: Text; const Name: string; Mode: boolean): boolean;

(*************************************************************************)
(*                                parameters                             *)
(*************************************************************************)
 Type
    TFormat = 0..1;
    TOrder = 0..7;

 Const
  { autorun flag }
    ParmAuto = 'AUTO';
  { list breaker }
    ListBreak = ';';
  { text breaker }
    TextBreak = ',';
  { path history }
    MaxHistory = 8;
  { extension }
    ExtLen = 4;
  { format }
    MaxFormat = High (TFormat);
    MinFormat = Low (TFormat);
  { pixel format }
    MaxPixelFormat = 2;
  { panels }
    MaxPanel = 2;
  { scale }
    MaxScale = 10;
    MinScale = 0;
  { quality }
    MaxQuality = 10;
    MinQuality = 0;
  { preview font }
    MaxColor = $00FFFFFF;
    MinColor = $00000000;
    MaxFont  = 9;
    MinFont  = 6;
  { firstnumber }
    MinFirst = 0;
    MaxFirst = 999999999;
    LenFirst = 9;
  { digits }
    MaxDigits = 9;
    MinDigits = 0;
    LenDigits = 1;
  { step }
    MaxStep = 999999;
    MinStep = 1;
    LenStep = 6;
  { anchor }
    MinAnchor = Low (TAnchor);
    MaxAnchor = High (TAnchor);
  { order }
    MinOrder = Low (TOrder);
    MaxOrder = High (TOrder);
  { custom width\height }
    MinCustom = 1;
    MaxCustom = 999;
    LenCustom = 3;
    StdCustom = 90;
  { compare }
    MinLike = 0;
    MaxLike = 25;
  { other }
    LenNamePart = 64;
    LenComment = 24;
  { forms  }
    MinView = 100;
    MinTop = -18;
    MinLeft = -100;
    MinWidth = 400;
    MinHeight = 357;

 Const
  { curr format }
    Files : integer = 0;
  { curr path }
    PathIndex : integer = 0;
  { curr panel }
    PanelIndex: integer = 0;
  { list sort flag }
    fSortList : boolean = true;
  { numerate }
    fRename : boolean = false;
    Order : integer = 0;
    fDecs : boolean = false;
    FirstNum : integer = 0;
    NextFirst : boolean = true;
    Digits : integer = 0;
    StepCount : integer = 1;
    Prefix : string = '';
    Postfix : string = '';
    fAttribute : boolean = false;
    fFileTime : boolean = false;
  { thumbnails }
    fThumbnail : boolean = false;
    Scale : integer = 3;
    ThumbnailQuality : integer = 7;
    Mark : string = '$';
  { custom size }
    fCustom : boolean = false;
    CtmWidth : integer = StdCustom;
    CtmHeight : integer = StdCustom;
    CtmMode : boolean = false;
    AnchorX : integer = 1;
    AnchorY : integer = 1;
    FillColor : integer = MinColor;
  { include }
    fInclude : boolean = false;
    Comment : string = '';
    fImgSize : boolean = false;
    fFilSize : boolean = false;
  { font }
    FontBold : boolean = false;
    FontItalic : boolean = false;
    FontUnderline : boolean = false;
    FontStrikeOut : boolean = false;
    FontName : string = 'MS Serif';
    FontColor : TColor = MinColor;
    FontSize : integer = 6;
    BGround  : TColor = 15724275;
  { collection }
    fCollection : boolean = false;
    fDuplicate : boolean = false;
    Likeness : integer = 0;
    fDescription : boolean = false;
  { autosave }
    AutoSave : boolean = false;
  { custom colors }
    Colors : TStringList = nil;
  { forms position and size }
    MainLeft : integer = 200;
    MainTop : integer = 100;
    MainWidth : integer = MinWidth;
    MainHeight : integer = MinHeight;
    ViewLeft : integer = 10;
    ViewTop : integer = 10;
    ViewWidth : integer = 360;
    ViewHeight: integer = 400;

 Const
  { curr format }
    psFiles = 'FilesIndex';
  { curr path }
    psPath = 'Path';
    psPathIndex = 'PathIndex';
  { curr panel }
    psPanelIndex = 'PanelIndex';
  { list sort flag }
    psSortList = 'SortList';
  { numerate }
    psRename = 'Numerate';
    psOrder = 'OrderIndex';
    psDecs = 'Decrease';
    psFirstNum = 'First';
    psNextFirst = 'UpdateFirst';
    psDigits = 'Digits';
    psStepCount = 'Step';
    psPrefix = 'Prefix';
    psPostfix = 'Postfix';
    psAttribute = 'SetReadOnly';
    psFileTime = 'UpdateFileTime';
  { thumbnails }
    psThumbnail = 'CreateThumbnails';
    psScale = 'ThumbnailScale';
    psThumbnailQuality  = 'ThumbnailQuality';
    psMark  = 'ThumbnailMark';
  { custom size }
    psCustom = 'CustomSize';
    psCtmWidth = 'CustomWidth';
    psCtmHeight = 'CustomHeight';
    psCtmMode = 'CutOrFill';
    psAnchorX = 'HorAlign';
    psAnchorY  = 'VerAlign';
    psFillColor = 'FillColor';
  { include }
    psInclude = 'Include';
    psComment = 'IncludeText';
    psImgSize = 'IncludeImageSize';
    psFilSize = 'IncludeFileSize';
  { font }
    psFontBold = 'FontBold';
    psFontItalic = 'FontItalic';
    psFontUnderline = 'FontUnderline';
    psFontStrikeOut = 'FontStrikeOut';
    psFontName = 'FontName';
    psFontColor = 'FontColor';
    psFontSize = 'FontSize';
    psBGround = 'FontBackGround';
  { custom colors }
    psColors = 'Color';
  { collection }
    psCollection = 'CollectionCheck';
    psDuplicate = 'FindDuplicate';
    psLikeness = 'Likeness';
    psDescription = 'Description';
  { autosave }
    psAutoSave = 'AutoSave';
  { forms position and size }
    psMainLeft = 'WindowLeft';
    psMainTop  = 'WindowTop';
    psMainWidth = 'WindowWidth';
    psMainHeight = 'WindowHeight';
    psViewLeft = 'ViewerWindowLeft';
    psViewTop = 'ViewerWindowTop';
    psViewWidth = 'ViewerWindowWidth';
    psViewHeight = 'ViewerWindowHeight';

 Const
  { formats }
    Formats : array [TFormat] of string [ExtLen]
            = ('.jpg', '.bmp' {, '.gif', '.tif', '.pcx', '.png'});

  { sort order }
    Orders : array [TOrder] of string
           = ('by file name',
              'by file size',
              'by file time',
              'by image width',
              'by image height',
              'by (width * height)',
              'by (width / height)',
              'by random');

  { align }
    HAnchors : array [TAnchor] of string = ('Left','Center','Right');
    VAnchors : array [TAnchor] of string = ('Top','Middle','Bottom');

 Const
   { autorun flag }
     RunAuto : boolean = false;
   { self dir }
     ExePath : string = '';
   { work dir }
     Catalog : string = '';
   { ini-file }
     IniFile : string = '';
   { buffer }
     Params : TStringList = nil;

{ font }
 procedure ParmsToFont (Font: TFont);
 procedure FontToParms (Font: TFont);
{ load\save parameters }
 function LoadParameters (Path, Colors: TStrings): boolean;
 procedure SaveParameters  (Path, Colors: TStrings);

(*************************************************************************)
(*                               formats support                         *)
(*************************************************************************)
 function LoadImage (Bmp: TBitMap; const FileName: string): integer;
 function SaveImage (Bmp: TBitMap; Compression: integer; const FileName: string): boolean;
 function ImageSize (const FileName: string; var Width, Height : integer): boolean;

(*************************************************************************)
(*                                image list                             *)
(*************************************************************************)
 Type
    TDataFile = File of TMatrix;

    PImageInfo = ^TImageInfo;
    TImageInfo = packed record
    { work }
      Thumbnail : PImageInfo;
      Temp : integer;
      Data : PMatrix;
    { image parms }
      Width  : integer;
      Height : integer;
    { file parms }
      Size : integer;
      Attr : integer;
      Time : TFileTime;
      Name : string;
    end; { TImageInfo }

    TImageList = Class (TList)
    private
      ViewCount : integer;
      SortOrder : integer;
      Decrease  : boolean;
      HaveSize  : boolean;
      HaveData  : boolean;
    { support }
      procedure Drop;
      procedure DisposeItem (var P: PImageInfo);
      procedure InitInfo (var Find : TSearchRec; Info: PImageInfo);
      function NewData (P: PImageInfo): boolean;
      function Search (const Name: string; var Index: integer): boolean;
      function isCancel : boolean;
      procedure Start (const Mssg: string);
      procedure Stop;
      procedure SetTemp (Mode: integer);
      function LoadSize: boolean;
    { test }
      function Pack: boolean;
    { create thumbnails }
      function CreateThumbnails: boolean;
    { rename }
      function RenameImage (P: PImageInfo; const Name: string): boolean;
      function Rename: boolean;
    { update }
      function SetReadOnly (P: PImageInfo; ReadOnly: boolean): boolean;
      function UpdateTime (P: PImageInfo; const Time: TSystemTime): boolean;
      function Update: boolean;
    { create description }
      function CreateDescription: boolean;
    { find duplicates }
      function LoadData: boolean;
      function FindDups: boolean;
    public
      constructor Create;
      procedure Clear; override;
      function Scan: boolean;
      function Sort (Odr: TOrder; Dcs: boolean): boolean;
      function Run: boolean;
      procedure MarkChange;
      property ThumbnailCount: integer read ViewCount;
    end; { TImageList }

 Var
    Images : TImageList;
    Cancel : boolean;

 Implementation

(*************************************************************************)
(*                          report\error handlers                        *)
(*************************************************************************)
 procedure Alarm (const Mssg: string; Pfx: TMsgDlgType);
 begin
     With CreateMessageDialog (Mssg, Pfx, [mbOK]) do begin
          Position := poMainFormCenter;
          ShowModal;
          Free;
     end; { With }
 end; { Alarm }

 function Confirm (const Wrn, Qst: string): boolean;
 begin
     With CreateMessageDialog (Wrn + #13#13 + Qst + '?', mtConfirmation, [mbYes, mbNo])
     do begin
        Position := poMainFormCenter;
        Result := ShowModal = mrYes;
        Free;
     end; { With }
 end; { Confirm }

 procedure Error (const Name, Mssg: string);
 var
     S : string;
 begin
     Inc (Errors);
     if Name > '' then S := '"' + Name + '". ' else S := '';
     Report (ErrPrefix + AnyPrefix + 'Error: ' + S + Mssg, mtError)
 end; { Error }

 procedure SysError (const Name: string; RC: Dword);
 begin
     Error (Name, SysErrorMessage (RC));
 end; { SysError }

 procedure Warning (const Name, Mssg: string);
 var
     S : string;
 begin
     if Name > '' then S := '"' + Name + '". ' else S := '';
     Report (ErrPrefix + AnyPrefix + 'Warning: ' + S + Mssg, mtWarning)
 end; { Warning }

 procedure Inform (const Mssg: string);
 begin
     Report (Mssg, mtInformation);
 end; { Inform }

(*************************************************************************)
(*                               support                                 *)
(*************************************************************************)
 function StrToInt (const S : string; var I: integer): boolean;
 var
     c, n : integer;
 begin
      {$R-}
        Val (S, n, c);
        if c = 0 then begin
           Result := true;
           I := n;
        end { if }
        else Result := false;
 end; { StrToInt }

 function StrToDateTime (const S: string; var DT: TDateTime): boolean;
 begin
     Try
       DT := SysUtils.StrToDateTime (S);
       Result := true;
     Except
       Result := false;
     end;
 end; { StrToDateTime }

 function PathDelimiter (const Path: string; Del: boolean = false): string;
 var
     l : integer;
 begin
     l := Length (Path);
     Result := Path;
     if l > 0 then begin
        if IsPathDelimiter (Path, Length (Path)) then begin
           if Del then SetLength (Result, Pred (l))
        end { if }
        else if not Del then Result := Result + '\';
     end; { if }
 end; { PathDelimiter }

 function SetDigits (Num: integer): string;
 var
     k : integer;
 begin
     Result := IntToStr (Num);
     if Digits > 0 then begin
        k := Digits - Length (Result);
        if k > 0 then Result := StringOfChar ('0', k) + Result;
     end; { if }
 end; { SetDigits }

 function isThumbnail (const FileName: string): boolean;
 var
     k : integer;
 begin
     k := Length (Mark);
     Result := (k > 0) and (AnsiCompareText (Copy (FileName, Length (FileName) - k - Pred (ExtLen), k), Mark) = 0);
 end; { isThumbnail }

 procedure DecodeName (const FileName: string; var Pfx, Num, Ptx: string);
 var
     i, j, k, n : integer;
 begin
   { len }
     n := Length (FileName) - ExtLen;
   { find digit }
     j := Succ (n);
     k := j;
     for i := 1 to n do begin
         if FileName [i] in Numerics then begin
            j := i;
            Break;
         end; { if }
     end; { for }
   { find char }
     for i := Succ (j) to n do begin
         if not (FileName [i] in Numerics) then begin
            k := i;
            Break;
         end; { if }
     end; { for }
   { result }
     Pfx := Copy (FileName, 1, Pred (j));
     Ptx := Copy (FileName, k, n - k + 1);
     Num := Copy (FileName, j, k - j);
 end; { DecodeName }

 function EncodeName (Number: integer): string;
 begin
     Result := Prefix + SetDigits (Number) + Postfix + Formats [Files];
 end; { EncodeName }

 function ThumbnailName (const FileName: string): string;
 var
     n : integer;
 begin
     n := Length (FileName);
     Result := Copy (FileName, 1, n - ExtLen) + Mark +
               Copy (FileName, n - Pred (ExtLen), ExtLen);
 end; { ThumbnailName }

 function SizeStr (W, H : integer): string;
 begin
     Result := IntToStr (W) + 'x' + IntToStr (H);
 end; { SizeStr }

 function FileSizeStr (Z: longword): string;
 var
     k : integer;
 begin
     k := Round (Z / 1024);
     if k = 0 then k := 1;
     Result := IntToStr (k) + 'k';
 end; { FileSizeStr }

 function TrackToQuality (Track: integer): integer;
 begin
     Result := 20 + (Track * 8);
 end; { JpgeQuality }

 function TrackToLikeness (Track: integer): integer;
 begin
     Result := Track + 75;
 end; { TrackToLikeness }

 function isPathExist (const Name: string): boolean;
 var
     A : integer;
 begin
     A := FileGetAttr (Name);
     Result := (A > 0) and ((A and faDirectory) > 0);
 end; { isPathExist }

 function isValid: boolean;
 begin
     Result := (fRename or fThumbnail or fCollection) and
               (Images <> nil) and (Images.Count > 0);
 end; { isValid }

 procedure AppTitle;
 begin
     Inform (AppName + ' ' + Version + '. Freeware. (c) [e-mail]');
 end; { AppTitle }

 function CatalogTime (var Time: TFileTime): boolean;
 var
     Find : TSearchRec;
 begin
     Result := false;
     if Catalog > '' then begin
        if SysUtils.FindFirst (PathDelimiter (Catalog, true), faAnyFile, Find) = 0
        then With Find.FindData do begin
             if CompareFileTime (ftLastWriteTime, ftCreationTime) > 0
                then Time := ftLastWriteTime
                else Time := ftCreationTime;
             Result := true;
        end; { if }
      { close }
        SysUtils.FindClose (Find);
     end; { if }
 end; { CatalogTime }

 function OpenText (var Txt: Text; const Name: string; Mode: boolean): boolean;
 begin
     AssignFile (Txt, Name);
     if Mode then begin
        FileMode := 1;
        Rewrite (Txt)
     end { if }
     else begin
          FileMode := 0;
          Reset (Txt);
     end; { else }
     Result := IOresult = 0;
 end; { OpenTxt }

 function SetFileAttr (const FileName: string; Attr: integer): boolean;
 begin
     if FileSetAttr (FileName, Attr) <> 0 then begin
        SysError (FileName, GetLastError);
        Result := false;
     end { if }
     else Result := true;
 end; { if }

 function FileTimeToDateTime (var Time: TFileTime): TDateTime;
 var
     F : TFileTime;
     U : TSystemTime;
 begin
     FileTimeToLocalFileTime (Time, F);
     FileTimeToSystemTime (F, U);
     Result := SystemTimeToDateTime (U);
 end; { FileTimeToDateTime }

(*************************************************************************)
(*                              formats support                          *)
(*************************************************************************)
 function LoadImage (Bmp: TBitMap; const FileName: string): integer;
 var
    Jpg : TJpegImage;
 begin
     Result := -1;
     Try
       Case Files of
        { jpg }
          0: begin
             Jpg := TJpegImage.Create;
             Jpg.LoadFromFile (Catalog + FileName);
             if Jpg.PixelFormat = jf8bit then Bmp.PixelFormat := pf8bit
                else Bmp.PixelFormat := pf24bit;
             Bmp.Width := Jpg.Width;
             Bmp.Height := Jpg.Height;
             Bmp.Canvas.Draw (0, 0, Jpg);
             Result := Jpg.CompressionQuality;
             Jpg.Free;
          end; { 0 }
        { bmp }
          1: begin
             Bmp.LoadFromFile (Catalog + FileName);
             Result := 0;
          end; { 1 }
        { unsupported }
          else Error (FileName, 'Unsupported format')
       end; { Case }
     Except
       on E: Exception do Error (Catalog + FileName, E.Message);
     end; { try }
 end; { LoadImage }

 function SaveImage (Bmp: TBitMap; Compression: integer; const FileName: string): boolean;
 var
    Jpg : TJpegImage;
 begin
     Try
       Case Files of
        { jpg }
          0: begin
             Jpg := TJpegImage.Create;
             Jpg.CompressionQuality := Compression;
             if Bmp.PixelFormat > pf8bit then Jpg.PixelFormat := jf24bit
                else Jpg.PixelFormat := jf8bit;
             Jpg.Assign (Bmp);
             Jpg.SaveToFile (Catalog + FileName);
             Jpg.Free;
          end; { 0 }
        { bmp }
          1: begin
             Bmp.SaveToFile (Catalog + FileName);
          end; { 1 }
        { unsupported }
          else Error (FileName, 'Unsupported format')
       end; { Case }
       Result := true;
     Except
       on E: Exception do begin
          Error (FileName, E.Message);
          Result := false;
       end;
     end; { try }
 end; { SaveImage }

 function ImageSize (const FileName: string; var Width, Height : integer): boolean;
 const
     BufSize = 24;
     BufHalf = 12;
     BufTerm = 6;
     BufOffs = 16;
 type
     TByteBuffer = packed array [0..Pred (BufSize)] of Byte;
     TWordBuffer = packed array [0..Pred (BufHalf)] of Word;
     TLongBuffer = packed array [0..Pred (BufTerm)] of integer;
 var
     Bytes : TByteBuffer;
     Words : TWordBuffer absolute Bytes;
     Longs : TLongBuffer absolute Bytes;
     Image : THandle;
     E, F  : boolean;
     w, h  : word;
     x     : word;
     i     : integer;

     function SwapBytes (const Pos: integer): word;
     var
         R : TByteBuffer absolute Result;
     begin
         R [1] := Bytes [Pos];
         R [0] := Bytes [Succ (Pos)];
     end; { SwapBytes }

     function Swap32 (const Value: integer): integer;
     var
         P : TWordBuffer absolute Value;
         R : TWordBuffer absolute Result;
     begin
         R [0] := Swap (P [1]);
         R [1] := Swap (P [0]);
     end; { Swap32 }

 begin
   { init }
     Result := false;
   { open }
     Image := FileOpen (Catalog + FileName, fmOpenRead);
     if Image <= 0 then Exit;
   { read buffer }
     if FileRead (Image, Bytes, BufSize) = BufSize then begin
      { by format }
        Case Files of
         { JPEG }
           0: begin
              E := false;
              F := false;
              Repeat
                 i := 0;
               { find markers }
                 While i < BufSize do begin
                   { ok }
                     if Bytes [i] = $FF then begin
                      { next }
                        Inc (i);
                      { shift }
                        if i > BufOffs then begin
                         { move }
                           Longs [0] := Longs [4];
                           Longs [1] := Longs [5];
                         { add }
                           E := FileRead (Image, Longs [2], BufOffs) <> BufOffs;
                         { pos }
                           Dec (i, BufOffs);
                        end; { if }
                      { segment marker }
                        if F and (not E) then begin
                           if Bytes [i] in [$C0, $C1, $C2, $C3] then begin
                              Inc (i, 4);
                              Height := SwapBytes (i);
                              Inc (i, 2);
                              Width := SwapBytes (i);
                            { ok }
                              E := true;
                              Break;
                           end { else }
                           else if not (Bytes [i] in [$01, $D0..$D7, $FF]) then begin
                            { length }
                              w := SwapBytes (Succ (i));
                            { skip }
                              E := FileSeek (Image, w - Succ (BufSize) + i, 1) <= 0;
                            { reset buffer }
                              i := BufSize;
                           end; { else if }
                        end { if }
                      { start marker }
                        else F := (Bytes [i] = $D8);
                     end { if }
                   { next }
                     else Inc (i);
                 end; { While }
            { exit or read }
              Until E or (FileRead (Image, Bytes, BufSize) <> BufSize);
           end; { 0 }
         { BMP }
           1: begin
              Width := Words [9];
              Height := Words [11];
           end; { 1 }
         { GIF }
           2: begin
              Width := Words [3];
              Height := Words [4];
           end; { 2 }
         { TIFF }
           3: begin
            { swap tif }
              E := Bytes[0] = 77;
            { entry pos }
              if E then i := Swap32 (Longs [1])
                 else i := Longs [1];
            { number of entries }
              if (FileSeek (Image, i, 0) > 0) and (FileRead (Image, h, 2) = 2) then begin
                 if E then h := Swap (h);
               { each entry }
                 i := 0;
                 While (i < h) and ((Width = 0) or (Height = 0)) and
                       (FileRead (Image, Bytes, BufHalf) = BufHalf)
                 do begin
                    if E then begin
                       w := Swap(Words [0]);
                       x := Swap(Words [1]);
                    end { if }
                    else begin
                       w := Words [0];
                       x := Words [1];
                    end; { else }
                  { width entry }
                    if w = 256 then begin
                       Case x of
                          1: Width := Bytes [8];
                          3: if E then Width := Swap(Words [4]) else Width := Words [4];
                          4: if E then Width := Swap32(Longs [2]) else Width := Longs [2];
                       end; { Case }
                    end { if }
                  { height entry }
                    else if w = 257 then begin
                       Case x of
                          1: Height := Bytes [8];
                          3: if E then Height := Swap(Words [4]) else Height := Words [4];
                          4: if E then Height := Swap32(Longs [2]) else Height := Longs [2];
                       end; { Case }
                    end; { if }
                    Inc (i);
                 end; { While }
              end; { if }
           end; { 3 }
         { PCX }
           4: begin
              Width := Succ (Words[4] - Words [2]);
              Height := Succ (Words[5] - Words[3]);
           end; { 4 }
         { PNG }
           5: begin
              Width := Swap(Words [9]);
              Height := Swap(Words [11]);
           end; { 5 }
         { unsupported }
           else Error (FileName, 'Unsupported format')
        end; { Case }
     end; { if }
   { close }
     FileClose (Image);
   { result }
     if (Width <= 0) or (Height <= 0) or  (Width > MAXSHORT) or (Height > MAXSHORT)
     then begin
        Error (FileName, 'Image format is not correct');
        Result := false;
     end { if }
     else Result := true;
 end; { ImageSize }

(*************************************************************************)
(*                         operations support                            *)
(*************************************************************************)
 function ResizeBmp (Bmp: TBitMap; const Name: string): boolean;
 var
     S     : single;
     w, h  : integer;
 begin
  { custom size }
    if fCustom then begin
       if not ThumbnailBmp (Bmp, CtmWidth, CtmHeight, AnchorX, AnchorY, CtmMode, FillColor)
       then begin
          Error (Name, 'Cannot create thumbnail because image is too small');
          Result := false;
       end { if }
       else Result := true;
    end { if }
  { scale }
    else begin
       w := Bmp.Width;
       h := Bmp.Height;
       S := ((w * h) / (h + w)) / (30 + (Scale * 2.5));
       Result := ThumbnailBmp (Bmp, nil, S, S);
    end; { else }
 end; { ResizeBmp }

 function Include (Bmp: TBitMap; const Name: string; W, H, Z: longword): boolean;
 var
     S : string;
     R : TRect;
     q : integer;

     procedure Plus (const A: string);
     begin
         if S > '' then S := S + ' ' + A else S := A;
     end; { Plus }

 begin
     S := '';
   { comment }
     if Comment > '' then Plus (Comment);
   { image size }
     if fImgSize then Plus (SizeStr (W, H));
   { file size }
     if fFilSize then Plus (FileSizeStr (Z));
   { font }
     ParmsToFont (Bmp.Canvas.Font);
   { width }
     q := Bmp.Canvas.TextWidth (S);
   { test }
     if Bmp.Width >= Pred (q) then With Bmp do begin
      { resize }
        R.Left := 0;
        R.Right := Width;
        R.Top := Height;
        Height := R.Top + Canvas.TextHeight ('X0');
        R.Bottom := Height;
      { bground }
        Canvas.Brush.Color := BGround;
        Canvas.FillRect (R);
      { text }
        R.Left := (Width - q) div 2;
        Canvas.TextOut (R.Left, R.Top, S);
      { ok }
        Result := true;
     end { if With }
   { error }
     else begin
          Error (Name, 'Cannot include in the thumbnail because it is too small');
          Result := false;
     end; { else }
 end; { Include }

(*************************************************************************)
(*                           load\save parameters                        *)
(*************************************************************************)
 procedure ParmsToFont (Font: TFont);
 begin
     With Font do begin
          Name := FontName;
          Size := FontSize;
          Color := FontColor;
          if FontBold then Style := Style + [fsBold];
          if FontItalic then Style := Style + [fsItalic];
          if FontUnderline then Style := Style + [fsUnderline];
          if FontStrikeOut then Style := Style + [fsStrikeOut];
     end; { With }
 end; { ParmsToFont }

 procedure FontToParms (Font: TFont);
 begin
     With Font do begin
          FontName := Name;
          FontSize := Size;
          FontColor := Color;
          FontBold := fsBold in Style;
          FontItalic := fsItalic in Style;
          FontUnderline := fsUnderline in Style;
          FontStrikeOut := fsStrikeOut in Style;
     end; { With }
 end; { FontToParms }

 procedure SaveParameters (Path, Colors: TStrings);

   procedure AddStr (const Name, Value: string);
   begin
       Params.Add (Name + '=' + Value);
   end; { AddStr }

   procedure AddInt (const Name: string; Value: integer);
   begin
       AddStr (Name, IntToStr (Value));
   end; { AddInt }

 var
     i : integer;
 begin
     Params.Clear;
     Try
     { main }
       if Path = nil then begin
          AddStr (psPath + '0', Catalog);
          PathIndex := 0;
       end { if }
       else begin
            for i := 0 to Pred (Path.Count) do AddStr (psPath + IntToStr (i), Path [i]);
            if PathIndex < 0 then PathIndex := 0;
       end; { else }
       AddInt (psPathIndex, PathIndex);
       AddInt (psFiles, Files);
       AddInt (psPanelIndex, PanelIndex);
       AddInt (psSortList, Byte (fSortList));
     { numerate }
       AddInt (psRename, Byte(fRename));
       AddInt (psOrder, Order);
       AddInt (psDecs, Byte(fDecs));
       AddInt (psFirstNum, FirstNum);
       AddInt (psNextFirst, Byte (NextFirst));
       AddInt (psDigits, Digits);
       AddInt (psStepCount, StepCount);
       AddStr (psPrefix, Prefix);
       AddStr (psPostfix, Postfix);
       AddInt (psAttribute, Byte(fAttribute));
       AddInt (psFileTime, Byte(fFileTime));
     { thumbnails }
       AddInt (psThumbnail, Byte(fThumbnail));
       AddStr (psMark, Mark);
       AddInt (psScale, Scale);
       AddInt (psThumbnailQuality, ThumbnailQuality);
     { custom }
       AddInt (psCustom, Byte(fCustom));
       AddInt (psCtmWidth, CtmWidth);
       AddInt (psCtmHeight, CtmHeight);
       AddInt (psCtmMode, Byte(CtmMode));
       AddInt (psAnchorX, AnchorX);
       AddInt (psAnchorY, AnchorY);
       AddInt (psFillColor, FillColor);
     { include }
       AddInt (psInclude, Byte (fInclude));
       AddStr (psComment, Comment);
       AddInt (psImgSize, Byte (fImgSize));
       AddInt (psFilSize, Byte (fFilSize));
       AddStr (psFontName, FontName);
       AddInt (psFontColor, FontColor);
       AddInt (psFontSize, FontSize);
       AddInt (psBGround, BGround);
     { font style }
       AddInt (psFontBold, Byte (FontBold));
       AddInt (psFontItalic, Byte (FontItalic));
       AddInt (psFontUnderline, Byte (FontUnderline));
       AddInt (psFontStrikeOut, Byte (FontStrikeOut));
     { collection }
       AddInt (psCollection, Byte (fCollection));
       AddInt (psDuplicate, Byte (fDuplicate));
       AddInt (psLikeness, Likeness);
       AddInt (psDescription, Byte (fDescription));
     { autosave }
       AddInt (psAutoSave, Byte(AutoSave));
     { colors }
       if Colors <> nil then Params.AddStrings (Colors);
     { forms }
       AddInt (psMainLeft, MainLeft);
       AddInt (psMainTop, MainTop);
       AddInt (psMainWidth, MainWidth);
       AddInt (psMainHeight, MainHeight);
       AddInt (psViewWidth, ViewWidth);
       AddInt (psViewHeight, ViewHeight);
       AddInt (psViewLeft, ViewLeft);
       AddInt (psViewTop, ViewTop);
     { save }
       Params.SaveToFile (IniFile);
     Except
          on E: Exception do Error (IniFile, E.Message);
     end; { try }
 end; { SaveParameters }

 function LoadParameters (Path, Colors: TStrings): boolean;
 var
     Value : integer;
     Line  : string;

   procedure Alert (const Name: string);
   begin
       Error (IniFile, 'The parameter "' + Name + '" is incorrect');
       Result := false;
   end; { Alert }

   function GetStr (const Name: string; Min, Max: integer): boolean;
   var
       i, j : integer;
   begin
       Result := false;
       for i := 0 to Pred (Params.Count) do begin
           Line := Params [i];
           j := AnsiPos ('=', Line);
           if (j > 0) and (AnsiCompareText (Trim (Copy (Line, 1, j - 1)), Name) = 0)
           then begin
              Line := Trim (Copy (Line, j + 1, Length (Line) - j));
              j := Length (Line);
              if (j >= Min) and (j <= Max) then Result := true
                 else Alert (Name);
              Params.Delete (i);
              Exit;
           end; { if }
       end; { for }
   end; { GetStr }

   function GetInt (const Name: string; Min, Max: integer): boolean;
   begin
       Result := false;
       if GetStr (Name, 1, 10) then begin
          if StrToInt (Line, Value) and (Value >= Min) and (Value <= Max) then Result := true
             else Alert (Name);
       end; { if }
   end; { GetInt }

 var
     S    : string;
     i, j : integer;
 begin
     Result := true;
     Try
        Params.LoadFromFile (IniFile);
      { path }
        if GetInt (psPathIndex, 0, Pred (MaxHistory)) then PathIndex := Value;
        j := 0;
        for i := 0 to Pred (MaxHistory) do begin
            if GetStr (psPath + IntToStr (i), 1, MAX_PATH) then begin
               Line := PathDelimiter (AnsiUpperCase (Line));
               if i = PathIndex then Catalog := Line;
               if Path <> nil then Path.Add (Line);
               Inc (j);
            end; { if }
        end; { for }
      { test }
        if PathIndex >= j then begin
           Alert (psPathIndex);
           PathIndex := -1;
        end; { if }
        if GetInt (psFiles, MinFormat, MaxFormat) then Files := Value;
        if GetInt (psPanelIndex, 0, MaxPanel) then PanelIndex := Value;
        if GetInt (psSortList, 0, 1) then fSortList := Boolean (Value);
      { numerate }
        if GetInt (psRename, 0, 1) then fRename := Boolean (Value);
        if GetInt (psOrder, MinOrder, MaxOrder) then Order := Value;
        if GetInt (psDecs, 0, 1) then fDecs := Boolean (Value);
        if GetInt (psFirstNum, MinFirst, MaxFirst) then FirstNum := Value;
        if GetInt (psNextFirst, 0, 1) then NextFirst := Boolean (Value);
        if GetInt (psDigits, MinDigits, MaxDigits) then Digits := Value;
        if GetInt (psStepCount, MinStep, MaxStep) then StepCount := Value;
        if GetStr (psPrefix, 0, LenNamePart) then Prefix := Line;
        if GetStr (psPostfix, 0, LenNamePart) then Postfix := Line;
        if GetInt (psAttribute, 0, 1) then fAttribute := Boolean (Value);
        if GetInt (psFileTime, 0, 1) then fFileTime := Boolean (Value);
      { thumbnails }
        if GetInt (psThumbnail, 0, 1) then fThumbnail := Boolean (Value);
        if GetStr (psMark, 1, LenNamePart) then Mark := Line;
        if GetInt (psScale, MinScale, MaxScale) then Scale := Value;
        if GetInt (psThumbnailQuality, MinQuality, MaxQuality) then ThumbnailQuality := Value;
      { custom }
        if GetInt (psCustom, 0, 1) then fCustom := Boolean (Value);
        if GetInt (psCtmWidth, MinCustom, MaxCustom) then CtmWidth := Value;
        if GetInt (psCtmHeight, MinCustom, MaxCustom) then CtmHeight := Value;
        if GetInt (psCtmMode, 0, 1) then CtmMode := Boolean (Value);
        if GetInt (psAnchorX, MinAnchor, MaxAnchor) then AnchorX := Value;
        if GetInt (psAnchorY, MinAnchor, MaxAnchor) then AnchorY := Value;
        if GetInt (psFillColor, MinColor, MaxColor) then FillColor := Value;
      { include }
        if GetInt (psInclude, 0, 1) then fInclude := Boolean (Value);
        if GetStr (psComment, 0, LenComment) then Comment := Line;
        if GetInt (psImgSize, 0, 1) then fImgSize := Boolean (Value);
        if GetInt (psFilSize, 0, 1) then fFilSize := Boolean (Value);
        if GetStr (psFontName, 0, 128) then FontName := Line;
        if GetInt (psFontColor, MinColor, MaxColor) then FontColor := Value;
        if GetInt (psFontSize, MinFont, MaxFont) then FontSize := Value;
        if GetInt (psBGround, MinColor, MaxColor) then BGround := Value;
      { font style }
        if GetInt (psFontBold, 0, 1) then FontBold := Boolean (Value);
        if GetInt (psFontItalic, 0, 1) then FontItalic := Boolean (Value);
        if GetInt (psFontUnderline, 0, 1) then FontUnderline := Boolean (Value);
        if GetInt (psFontStrikeOut, 0, 1) then FontStrikeOut := Boolean (Value);
      { collection }
        if GetInt (psCollection, 0, 1) then fCollection := Boolean (Value);
        if GetInt (psDuplicate, 0, 1) then fDuplicate := Boolean (Value);
        if GetInt (psLikeness, MinLike, MaxLike) then Likeness := Value;
        if GetInt (psDescription, 0, 1) then fDescription := Boolean (Value);
      { autosave }
        if GetInt (psAutoSave, 0, 1) then AutoSave := Boolean (Value);
      { colors }
        if Colors <> nil then begin
           for i := 0 to 15 do begin
               S := psColors + Chr (i + Ord ('A'));
               if GetStr (S, 0, MaxColor) then Colors.Add (S + '=' + Line);
           end; { for }
        end; { if }
      { forms }
        i := Screen.DesktopWidth - MinLeft;
        j := Screen.DesktopHeight - MinTop;
        if GetInt (psMainLeft, MinLeft, i) then MainLeft := Value;
        if GetInt (psMainTop, MinTop, j) then MainTop := Value;
        if GetInt (psMainWidth, MinWidth, i) then MainWidth := Value;
        if GetInt (psMainHeight, MinHeight, j) then MainHeight := Value;
        if GetInt (psViewWidth, MinView, i) then ViewWidth := Value;
        if GetInt (psViewHeight, MinView, j) then ViewHeight := Value;
        if GetInt (psViewLeft, MinLeft, i) then ViewLeft := Value;
        if GetInt (psViewTop, MinTop, j) then ViewTop := Value;
      { test }
        if Params.Count > 0 then Alert (Params [0]);
      Except
        on E: Exception do begin
           Error (IniFile, E.Message);
           Result := false;
        end; { on }
      end; { try }
 end; { LoadParameters }

(*************************************************************************)
(*                             compare                                   *)
(*************************************************************************)
 function CmpNumber (F, S: pointer): integer;
 var
     A, B : string;
     C, D : string;
     X, Y : string;
     n, k : integer;
 begin
     DecodeName (PImageInfo (F)^.Name, A, C, X);
     DecodeName (PImageInfo (S)^.Name, B, D, Y);
     Result := AnsiCompareText (A, B);
     if (Result = 0) and StrToInt (C, n) and StrToInt (D, k) then Result := n - k;
     if Result = 0 then Result := AnsiCompareText (C, D);
     if Result = 0 then Result := AnsiCompareText (X, Y);
     if fDecs then Result := - Result;
 end; { CmpNumber }

 function CmpSize (F, S: pointer): integer;
 begin
     Result := PImageInfo (F)^.Size - PImageInfo (S)^.Size;
     if fDecs then Result := - Result;
 end; { CmpSize }

 function CmpTime (F, S: pointer): integer;
 begin
     Result := CompareFileTime (PImageInfo (F)^.Time, PImageInfo (S)^.Time);
     if Result = 0 then Result := PImageInfo (F)^.Size - PImageInfo (S)^.Size;
     if fDecs then Result := - Result;
 end; { CmpTime }

 function CmpHeight (F, S: pointer): integer;
 begin
     Result := PImageInfo (F)^.Height - PImageInfo (S)^.Height;
     if Result = 0 then Result := PImageInfo (F)^.Width - PImageInfo (S)^.Width;
     if Result = 0 then Result := PImageInfo (F)^.Size - PImageInfo (S)^.Size;
     if fDecs then Result := - Result;
 end; { CmpHeight }

 function CmpWidth (F, S: pointer): integer;
 begin
     Result := PImageInfo (F)^.Width - PImageInfo (S)^.Width;
     if Result = 0 then Result := PImageInfo (F)^.Height - PImageInfo (S)^.Height;
     if Result = 0 then Result := PImageInfo (F)^.Size - PImageInfo (S)^.Size;
     if fDecs then Result := - Result;
 end; { CmpWidth }

 function CmpTemp (F, S: pointer): integer;
 begin
     Result := PImageInfo (F)^.Temp - PImageInfo (S)^.Temp;
     if Result = 0 then Result := PImageInfo (F)^.Size - PImageInfo (S)^.Size;
     if fDecs then Result := - Result;
 end; { CmpTemp }

(*************************************************************************)
(*                                image list                             *)
(*************************************************************************)
 Const
     faUse = faAnyFile and (not faVolumeID) and (not faDirectory);

 constructor TImageList.Create;
 begin
     inherited Create;
     Capacity := 512;
     Drop;
 end; { Create }

 procedure TImageList.Drop;
 begin
     SortOrder := -1;
     Decrease  := false;
     HaveSize  := false;
     HaveData  := false;
     ViewCount := 0;
 end; { Drop }

 procedure TImageList.DisposeItem (var P: PImageInfo);
 begin
     if P <> nil then begin
        SetLength (P^.Name, 0);
        if P^.Data <> nil then FreeMem (P^.Data);
        Dispose (P);
        P := nil;
     end; { if }
 end; { DisposeItem }

 procedure TImageList.Clear;
 var
     i : integer;
 begin
     for i := 0 to Pred (Count) do begin
         if List [i] <> nil then begin
            DisposeItem (PImageInfo (List [i])^.Thumbnail);
            DisposeItem (PImageInfo (List [i]));
         end; { if }
     end; { for }
     Drop;
     inherited Clear;
 end; { Clear }

 procedure TImageList.InitInfo (var Find : TSearchRec; Info: PImageInfo);
 begin
     With Info^ do begin
        { file parm }
          Time := Find.FindData.ftLastWriteTime;
          Size := Find.Size;
          Attr := Find.Attr;
          Name := Find.Name;
        { image parm }
          Height := 0;
          Width := 0;
        { work }
          Thumbnail := nil;
          Temp := 0;
          Data := nil;
          if isThumbnail (Name) then Inc (ViewCount);
     end; { With }
 end; { InitInfo }

 function TImageList.NewData (P: PImageInfo): boolean;
 begin
     if P^.Data = nil then begin
        GetMem (P^.Data, SizeOf (TMatrix));
        Result := true;
     end { if }
     else Result := false;
 end; { NewData }

 function TImageList.Scan: boolean;
 var
     Find : TSearchRec;
     Info : PImageInfo;
 begin
   { init }
     Clear;
   { test path }
     if isPathExist (Catalog) then begin
        Result := true;
      { scan }
        if SysUtils.FindFirst (Catalog + '*' + Formats [Files], faUse, Find) = 0 then begin
           Repeat
                New (Info);
                InitInfo (Find, Info);
                Add (Info);
           Until (SysUtils.FindNext (Find) <> 0);
        end; { if }
        SysUtils.FindClose (Find);
     end { if }
     else begin
          SysError (Catalog, ERROR_PATH_NOT_FOUND);
          Result := false;
     end; { else }
 end; { Scan }

 procedure TImageList.Start (const Mssg: string);
 begin
     Inform (BegPrefix + AnyPrefix + Mssg);
 end; { Start }

 procedure TImageList.Stop;
 begin
     Inform (EndPrefix + AnyPrefix + 'Done');
 end; { Stop }

 procedure TImageList.MarkChange;
 var
     i : integer;
 begin
     ViewCount := 0;
     for i := 0 to Pred (Count)
      do if isThumbnail (PImageInfo (List[i])^.Name) then Inc (ViewCount);
 end; { MarkChange }

 procedure TImageList.SetTemp;
 var
     i : integer;
 begin
     for i := 0 to Pred (Count) do begin
         With PImageInfo (List[i])^ do begin
            Case Mode of
             { order }
               0: Temp := i;
             { image size }
               1: Temp := Width * Height;
             { image size }
               2: begin
                  if Height > 0 then Temp := Round ((Width / Height) * 1000)
                     else Temp := 0;
               end; { 2 }
             { random }
               3: Temp := Random (MaxInt);
             { clear }
               else Temp := 0;
            end; { Case }
         end; { With }
     end; { for }
 end; { SetTemp }

 function TImageList.LoadSize : boolean;
 var
     i : integer;
 begin
     Result := true;
   { test }
     if HaveSize then Exit;
   { mssg }
     Start ('Loading sizes of images');
   { load }
     for i := 0 to Pred (Count) do begin
         With PImageInfo (List[i])^ do begin
            if (Width = 0) or (Height = 0) then ImageSize (Name, Width, Height);
         end; { With }
       { abort }
         if isCancel then begin
            Result := false;
            Exit;
         end; { if }
     end; { for }
     if Result then begin
        HaveSize := true;
        Stop;
     end; { if }
 end; { LoadSize }

 function TImageList.Sort (Odr: TOrder; Dcs: boolean): boolean;
 var
     Cmp : TListSortCompare;
 begin
     Result := true;
     if (Odr = SortOrder) and (Decrease = Dcs) then Exit;
   { init }
     Case Odr of
        1: Cmp := @CmpSize;
        2: Cmp := @CmpTime;
        3: begin
           Result := LoadSize;
           Cmp := @CmpWidth;
        end; { 3 }
        4: begin
           Result := LoadSize;
           Cmp := @CmpHeight;
        end { 4 };
        5: begin
           Result := LoadSize;
           SetTemp (1);
           Cmp := @CmpTemp;
        end; { 5 }
        6: begin
           Result := LoadSize;
           SetTemp (2);
           Cmp := @CmpTemp;
        end; { 6 }
        7: begin
           SetTemp (3);
           Cmp := @CmpTemp;
        end; { 7 }
        else Cmp := @CmpNumber;
     end; { Case }
   { ok }
     if Result then begin
      { order }
        SortOrder := Odr;
      { exchange }
        Decrease := fDecs;
        fDecs := Dcs;
      { sort }
        inherited Sort (Cmp);
      { restore }
        fDecs := Decrease;
        Decrease := Dcs;
     end; { if }
 end; { Sort }

 function TImageList.Search (const Name: string; var Index: integer): boolean;
 var
     i : integer;
 begin
     for i := 0 to Pred (Count) do begin
         if (List[i] <> nil) and
            (AnsiCompareText (PImageInfo (List[i])^.Name, Name) = 0)
         then begin
            Index := i;
            Result := true;
            Exit;
         end; { if }
     end; { for }
     Result := false;
 end; { Search }

 function TImageList.isCancel : boolean;
 begin
     Application.ProcessMessages;
     if Cancel then Support.Error ('', 'Job was cancelled');
     Result := Cancel;
 end; { isCancel }

 function TImageList.SetReadOnly (P: PImageInfo; ReadOnly: boolean): boolean;
 var
     A : integer;
 begin
     if ReadOnly then A := P^.Attr or faReadOnly
        else A := P^.Attr and (not faReadOnly);
     Result := true;
   { change }
     if A <> P^.Attr then begin
        if not SetFileAttr (Catalog + P^.Name, A) then Result := false
           else P^.Attr := A;
     end; { if }
 end; { SetReadOnly }

 function TImageList.Pack: boolean;
 var
     P    : PImageInfo;
     i, j : integer;
 begin
     Result := true;
     Start ('Conformity test');
   { have thumbnails }
     if ViewCount > 0 then begin
      { find thumbnails }
        for i := 0 to Pred (Count) do begin
            P := PImageInfo (List [i]);
            if (P <> nil) and (not isThumbnail (P^.Name)) and
               Search (ThumbnailName (P^.Name), j)
            then begin
                 P^.Thumbnail := List [j];
                 List [j] := nil;
            end; { if }
        end; { for }
      { pack and test }
        for i := Pred (Count) downto 0 do begin
            P := PImageInfo (List [i]);
            if P <> nil then begin
              { invalid thumnail }
               if P^.Thumbnail = nil then begin
                  if isThumbnail (P^.Name) then begin
                     Support.Error (P^.Name, 'The program cannot find the image for the thumbnail');
                     Result := false;
                  end { if }
                  else if not fThumbnail then begin
                     Warning (P^.Name, 'The program cannot find the thumbnail for the image');
                  end; { if }
               end; { if }
            end { if }
            else Delete (i);
          { cancel }
            if isCancel then begin
               Result := false;
               Exit;
            end; { if }
        end; { for }
     end; { if }
     Stop;
 end; { Pack }

 function TImageList.CreateThumbnails: boolean;
 var
     P    : PImageInfo;
     Bmp  : TBitMap;
     Find : TSearchRec;
     E    : boolean;
     i    : integer;
 begin
     Start ('Creating thumbnails');
   { init }
     Bmp := TBitMap.Create;
   { create }
     for i := 0 to Pred (Count) do begin
         P := List [i];
       { open & convert }
         if LoadImage (Bmp, P^.Name) >= 0 then begin
          { parms }
            P^.Height := Bmp.Height;
            P^.Width := Bmp.Width;
          { data }
            if fDuplicate and NewData (P) then BmpMatrix (Bmp, P^.Data^);
          { resize }
            if ResizeBmp (Bmp, P^.Name) then begin
             { new }
               if P^.Thumbnail = nil then begin
                  New (P^.Thumbnail);
                  FillChar (P^.Thumbnail^, SizeOf (TImageInfo), #0);
                  P^.Thumbnail^.Name := ThumbnailName (P^.Name);
                  E := true;
               end { if }
               else E := false;
             { write comment }
               if fInclude then With P^ do Include (Bmp, Thumbnail^.Name, Width, Height, Size);
             { clear readonly & save }
               if (E or SetReadOnly (P^.Thumbnail, false)) and
                   SaveImage (Bmp, TrackToQuality (ThumbnailQuality), P^.Thumbnail^.Name)
               then begin
                { init }
                  SysUtils.FindFirst (Catalog + P^.Thumbnail^.Name, faUse, Find);
                  InitInfo (Find, P^.Thumbnail);
                  SysUtils.FindClose (Find);
                { thumbnail size }
                  With P^.Thumbnail^ do begin
                     Height := Bmp.Height;
                     Width := Bmp.Width;
                  end; { With }
                { report }
                  With P^.Thumbnail^ do Inform (Name + ' ' + SizeStr (Width, Height) + ' ' + IntToStr (Size));
               end { if }
             { free }
               else if E then DisposeItem (P^.Thumbnail);
            end; { if }
         end; { if }
       { abort }
         if isCancel then Break;
     end; { for }
   { ok }
     if not Cancel then begin
        HaveData := fDuplicate;
        HaveSize := true;
        Result := true;
        Stop;
     end { if }
     else Result := false;
   { free }
     Bmp.Free;
 end; { Thumbnails }

 function TImageList.RenameImage (P: PImageInfo; const Name: string): boolean;

  function RenameFile (var Dst: string; const Src: string): boolean;
  begin
      Inform (Dst + ' ' + Src);
      Result := SysUtils.RenameFile (Catalog + Dst, Catalog + Src);
      if Result then Dst := Src
         else SysError (Dst, GetLastError);
  end; { RenameFile }

 begin
     Result := RenameFile (P^.Name, Name) and
         ((P^.Thumbnail = nil) or RenameFile (P^.Thumbnail^.Name, ThumbnailName (Name)));
 end; { RenameImage }

 function TImageList.Rename: boolean;

 var
     Img : PImageInfo;
     Tmp : string;
     i   : integer;

   function CircleRename (P: PImageInfo): boolean;
   var
       Cur : string;
       j   : integer;
   begin
     { end of circle }
       if P^.Temp < 0  then begin
          Result := RenameImage (P, Tmp);
          Exit;
       end; { if }
     { new name }
       j := P^.Temp * StepCount + FirstNum;
       Cur := EncodeName  (j);
     { validate }
       if not isThumbnail (Cur) then begin
       { init }
         Result := true;
       { reset }
         P^.Temp := -1;
       { test }
         if P^.Name <> Cur then begin
          { test for exist }
            if AnsiCompareText (P^.Name, Cur) <> 0 then begin
               if Search (Cur, j) then Result := CircleRename (List [j]);
            end; { if }
         { rename }
            if Result then Result := RenameImage (P, Cur);
         end; { if }
       end { if }
     { error }
       else begin
          Support.Error (Cur, 'The filename ending is equal to the thumbnail mark');
          Result := false;
       end; { else }
   end; { CircleRename }

 begin
   { sort by order }
     if not Sort (Order, fDecs) then begin
        Result := false;
        Exit;
     end { if }
     else Result := true;
   { set order }
     SetTemp (0);
   { temp name }
     Repeat
          Tmp := AppName + IntToStr (Random (MaxInt)) + Formats [Files];
     Until not (isThumbnail (Tmp) or FileExists (Catalog + Tmp));
   { rename all }
     Start ('Renaming files');
     for i := 0 to Pred (Count) do begin
       { item }
         Img := List [i];
       { rename }
         if Img^.Temp >= 0 then begin
            Result := (not isCancel) and CircleRename (Img);
          { abort }
            if not Result then Exit;
         end; { if }
     end; { for }
     Stop;
   { set new first }
     if NextFirst then FirstNum := (Pred (Count) * StepCount + FirstNum) + StepCount;
 end; { Rename }

 function TImageList.UpdateTime (P: PImageInfo; const Time: TSystemTime): boolean;
 var
     H : THandle;
     T : TFileTime;
 begin
     Result := false;
   { drop redonly }
     if SetReadOnly (P, false) then begin
      { open }
        H := FileOpen (Catalog + P^.Name, fmOpenWrite);
        if H > 0 then begin
         { update }
           Result := SystemTimeToFileTime (Time, T) and SetFileTime (H, nil, nil, @T);
         { close }
           FileClose (H);
        end; { if }
      { error }
        if not Result then SysError (P^.Name, GetLastError)
           else P^.Time := T;
     end; { if }
 end; { UpdateTime }

 function TImageList.Update: boolean;
 const
     OneMSec : TDateTime = 1 / (1000 * 60 * 60 * 24);
 var
     P : PImageInfo;
     U : TSystemTime;
     T : TDateTime;
     i : integer;
 begin
     Result := true;
   { update time }
     if fFileTime then begin
      { init }
        Start ('Updating file time');
        GetSystemTime (U);
        T := SystemTimeToDateTime (U);
      { update }
         for i := 0 to Pred (Count) do begin
             P := List [i];
           { time }
             T := T + OneMSec;
             DateTimeToSystemTime (T, U);
           { image }
             Result := (not isCancel) and UpdateTime (P, U) and
                       ((P^.Thumbnail = nil) or UpdateTime (P^.Thumbnail, U));
           { abort }
             if not Result then Exit;
         end; { for }
         Stop;
     end; { if }
   { read only }
     if fAttribute then Start ('Setting readonly attribute')
        else Start ('Clearing readonly attribute');
     for i := 0 to Pred (Count) do begin
         P := List [i];
         Result := (not isCancel) and SetReadOnly (P, fAttribute) and
                   ((P^.Thumbnail = nil) or SetReadOnly (P^.Thumbnail, fAttribute));
       { abort }
         if not Result then Exit;
     end; { for }
     Stop;
 end; { Update }

 function TImageList.CreateDescription: boolean;
 var
     Line : string;
     Name : string;
     Data : Text;
     P    : PImageInfo;
     T    : TDateTime;
     i    : integer;
 begin
   { get size }
     if not LoadSize then begin
        Result := false;
        Exit;
     end; { if }
   { init }
     Name := Catalog + ScvName;
     Start ('Creating description file ' + Name);
   { open }
     if OpenText (Data, Name, true) then begin
        Result := true;
      { output }
        for i := 0 to Pred (Count) do begin
            P := List [i];
          { name }
            Line := P^.Name + TextBreak;
          { size }
            Line := Line + IntToStr (P^.Size) + TextBreak;
          { time }
            T := FileTimeToDateTime (P^.Time);
            Line := Line + DateTimeToStr (T) + TextBreak;
          { width & height }
            if (P^.Width > 0) and (P^.Height > 0) then begin
                Line := Line + IntToStr (P^.Width) + TextBreak;
                Line := Line + IntToStr (P^.Height);
            end; { if }
          { write }
            Writeln (Data, Line);
          { test }
            if IOResult <> 0 then begin
               SysError (Name, GetLastError);
               Result := false;
               Break;
            end; { if }
          { abort }
            if isCancel then begin
               Result := false;
               Break;
            end; { if }
        end; { for }
      { close }
        Close (Data);
        if Result then Stop;
     end { if }
     else begin
          SysError (Name, GetLastError);
          Result := false;
     end; { else }
 end; { CreateDescription }

 function TImageList.LoadData: boolean;
 var
     Bmp  : TBitMap;
     P    : PImageInfo;
     i    : integer;
 begin
     Result := true;
   { test }
     if HaveData then Exit;
   { init }
     Start ('Loading parameters of images');
     Bmp := TBitMap.Create;
   { get }
     for i := 0 to Pred (Count) do begin
         P := List [i];
       { matrix }
         if P^.Data = nil then begin
            if LoadImage (Bmp, P^.Name) >= 0 then begin
               P^.Width := Bmp.Width;
               P^.Height := Bmp.Height;
               NewData (P);
               BmpMatrix (Bmp, P^.Data^);
            end; { if }
         end; { if }
       { abort }
         if isCancel then begin
            Result := false;
            Break;
         end; { if }
     end; { for }
   { free }
     Bmp.Free;
   { flags }
     if Result then begin
        HaveData := true;
        HaveSize := true;
        Stop;
     end; { if }
 end; { LoadData }

 function TImageList.FindDups: boolean;
 var
     P, S : PImageInfo;
     i, j : integer;
 begin
   { init database }
     if not LoadData then begin
        Result := false;
        Exit;
     end { if }
     else Result := true;
   { init }
     Start ('Finding duplicate images');
     SetTemp (0);
   { scasn }
     for i := 0 to Pred (Count) do begin
         P := List [i];
         if (P <> nil) and (P^.Data <> nil) and (P^.Temp >= 0) then begin
            for j := Succ (i) to Pred (Count) do begin
                S := List [j];
                if (S <> nil) and (S^.Data <> nil) and (S^.Temp >= 0) and
                   EquMatrix (P^.Data, S^.Data, TrackToLikeness (Likeness))
                then begin
                     Warning (P^.Name, 'The file maybe equal to "' + S^.Name + '"');
                     S^.Temp := -1;
                end; { if }
            end; { for }
         end; { if }
       { abort }
         if isCancel then begin
             Result := false;
             Break;
         end; { if }
     end; { for }
     if Result then Stop;
 end; { FindDups }

 function TImageList.Run: boolean;
 begin
     AppTitle;
   { init }
     Inform ('START ' + DateTimeToStr (Now) + ' ' + Catalog);
     Cancel := false;
   { pack and test }
     if Pack then begin
      { thumbnails }
        if fThumbnail then Result := CreateThumbnails
           else Result := true;
      { rename }
        if Result and fRename then Result := Rename and Update;
      { create description }
        if Result and fCollection then begin
           if fDuplicate then Result := FindDups;
           if Result and fDescription then Result := CreateDescription;
        end; { if }
     end { if }
     else Result := false;
     Inform ('STOP ' + DateTimeToStr (Now));
 end; { Run }

(*************************************************************************)
(*                                  init                                 *)
(*************************************************************************)
 initialization
   { self path }
     ExePath := PathDelimiter (ExtractFilePath (ParamStr (0)));
     Catalog := ExePath;
   { ini-file name }
     IniFile := ParamStr (1);
     if IniFile = '' then IniFile := ExePath + IniName;
   { autorun }
     RunAuto := AnsiCompareText (ParamStr (2), ParmAuto) = 0;
   { lists }
     Params := TStringList.Create;
   { init }
     Randomize;
   { image list }
     Images := TImageList.Create;

  finalization
     Images.Free;
     Params.Free;

 End.