unit FRarList;
  {        совмещенный модуль:
    1) выбор файла из списка, заданного маской (объект TFilesList)
    2) выбор файлов из Rar-файла (объект TRarList)
    Оба объекта используют форму FListFrm  }
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls, Buttons, ImgList, ExtCtrls;

type
  TFileInfo = record
    FSize: integer;
    //  FAttr: integer;   это нужно, если включать папки
    DTime: cardinal;
    Flags: byte; // для Rar
    Name: string
  end;
  PFileInfo = ^TFileInfo;
    // функции для сортировок
  TCompareFunc = function(P:PFileInfo; s:string):integer;
  TGetString = function(P:PFileInfo):string;

    // форма для списков файлов - вызывается из TFilesList/TRarList
  TFListFrm = class(TForm)
    ListView1: TListView;
    BtnOK: TBitBtn;
    ImageList1: TImageList;
    Panel1: TPanel;
    BtnAll: TBitBtn;
    StatusBar1: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure ListView1ColumnClick(Sender: TObject; Column: TListColumn);
    procedure ListView1SelectItem(Sender: TObject; Item: TListItem;
      Selected: Boolean);
    procedure BtnAllClick(Sender: TObject);
    procedure ListView1DblClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FList: TList;  // список файлов (массив TFileInfo) - общий с FRarList указатель
    procedure SetFIList(List: TList);
    procedure LoadListView;
    procedure QSortFList(iLo, iHi: Integer; GetStr: TGetString;
        FCompare: TCompareFunc);
  public
    property FIList: TList write SetFIList;
    function GetFileName(i:integer):string;
  end;

       // главные функции для применения модуля
function SelectFile(FNames,FrmCap: string; var FN: string): boolean;
function SelectInRar(RarFile: string; var FN: string): boolean;

implementation

{$R *.dfm}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_CAST OFF}

type
     // список файлов, заданных маской FNames
  TFilesList = class(TObject)
    constructor Create(FNames:string); virtual;
    destructor Destroy; override;
  private
    Multi: boolean;
    FAllSel: boolean;  // выделены все файлы
    FormCaption: string;
    FBtnCaption: string;
    FName: string; // выбранный файл (в RarList - строка файлов)
    procedure Clear;
    procedure SetFCaption(Tit:string);
    function GetFCaption:string;
    procedure SetBtnCaption(Cap:string);
    procedure SetMulti(MultiSelect:boolean);
    function GetCount: integer;
    function GetAllSel: boolean;
    function GetFName: string;
  protected
    FList: TList;  // список файлов (массив TFileInfo)
  public
    property Title: string read GetFCaption write SetFCaption;
    property BtnCaption: string write SetBtnCaption;
    property MultiSelect: boolean write SetMulti;
    property Count: integer read GetCount;
    property AllSel: boolean read GetAllSel;
    property FileName: string read GetFName;
    function Execute: boolean;
  end;
     // список файлов в Rar-файле
  TRarList = class(TFilesList)
    constructor Create(RarFName:string); override;
  end;

var
  MRes: byte;

 { ----- Подсчет ширины i-го столбца в ListView ----- }
 { для того чтобы подогнать все столбцы на всю ширину ListView
   предполагается, что ширина всех остальных столбцов уже задана }
   { процедура - из модуля SVAProcLib }
procedure CalcWidthLV(i:integer; ListView: TListView); // in FormActivate
var
  j,n,n0:integer;
begin
  with ListView do begin
    n:= ClientWidth;
    n0:= n;
    for j:= 0 to Columns.Count - 1 do
      if j<>i then dec(n, Columns[j].Width);
    if n < 4 then exit;  // critical error
    Columns[i].Width:= n;
    Application.ProcessMessages;
    { В основном здесь и всё, но можно и проверить ScrollBar -
      например, до пересчета Columns[i].Width был HorScroll,
      а после - он исчез, появилась в конце строка, и затем исчез VertScroll.
      Тогда можно и увеличить Columns[i].Width }
    if ClientWidth <> n0 then
      Columns[i].Width:= n + ClientWidth - n0;
  end;
end;  { CalcWidthLV }

   { -- Размер файла (с разделителями) -- }
   { функция - из модуля SVAProcLib }
function StrFileSize(FSize:integer):string;
begin
  Result:= FloatToStrF(FSize, ffNumber, 9, 0); // SysUtils
end;

 { --- Дата и время файла в виде <dd.mm.yyyy hh:mm> --- }
   { функция - из модуля SVAProcLib }
function StrFDateTime(DT:integer):string;
  // Dates: 01.01.1980 - 31.12.2107 (128 years)
  // сутки 65536 и более - не знаю закономерности
var D: tDateTime; FormatSettings: TFormatSettings;
begin
  D:= FileDateToDateTime(DT);
  with FormatSettings do begin
    ShortDateFormat:= 'dd/mm/yyyy';
    DateSeparator:= '.';
    TimeSeparator:= ':';
    LongTimeFormat:= 'hh:mm';
  end;
  Result:= DateToStr(D, FormatSettings) + '  ' + TimeToStr(D, FormatSettings);
  { если с одним пробелом, то можно и короче:
  Result:= DateTimeToStr(D, FormatSettings); }
end;

  { --- Для сортировки по названию --- }
function GetName(P:PFileInfo):string;
begin
  Result:=
//    chr(P.FAttr + 49) +   // начало от '1' (если вкл. папки)
    AnsiUpperCase(P.Name);
end;

function CompareName(P:PFileInfo; s:string):integer;
var a: string;
begin
  a:= GetName(P);
  if a < s then Result:= -1
  else if a = s then Result:= 0
  else Result:= 1
end;

  { --- Для сортировки по размеру --- }
function GetFSize(P:PFileInfo):string;

  function ObStr(s:string):string;
  var i:integer;  // "обратная" строка
  begin
    Result:= AnsiUpperCase(s);
    for i:= 1 to length(s) do
      Result[i]:= chr(255 - ord(Result[i]))
  end;

begin
{  if P.FAttr = $10 then Result:= 'A' + ObStr(P.Name) // для папки
  else }
    Result:= format('%.10d',[P.FSize]) + ObStr(P.Name);
end;

function CompareSize(P:PFileInfo; s:string):integer;
var a: string;
begin
  a:= GetFSize(P);
  if a > s then Result:= -1
  else if a = s then Result:= 0
  else Result:= 1
end;

  { --- Для сортировки по дате --- }
function GetFDate(P:PFileInfo):string;
begin
  Result:=
//    chr(128 - P.FAttr) +
    format('%.10d',[P.DTime shr 1]);
   // cardinal -> integer
end;

function CompareDate(P:PFileInfo; s:string):integer;
var a: string;
begin
  a:= GetFDate(P);
  if a > s then Result:= -1
  else if a = s then Result:= 0
  else Result:= 1
end;

  { =========  Ф О Р М А ======== }

       { ----- FormCreate ----- }

procedure TFListFrm.FormCreate(Sender: TObject);
var i: integer;
begin
  AlphaBlendValue:= 0; // чтобы скрыть работу с ListView (CalcWidthLV и пр.)
  AlphaBlend:= true;
  ListView1.Tag:= 0; // без сортировки
  for i:= 0 to 2 do
    ListView1.Columns[0].ImageIndex:= -1; // подстраховка
end;

       { ----- FormActivate ----- }

procedure TFListFrm.FormActivate(Sender: TObject);
var C: byte; i,n,k: integer;
begin
   // До этого момента получить:
   // FList, ListView1.MultiSelect, Caption
  MRes:=0;
  C:= ListView1.Tag;
  if C = 0 then C:= 1;
  ListView1.Tag:= 0;
  ListView1ColumnClick(nil, ListView1.Columns[C-1]);
  n:=0;
    // оценим макс. длину названий (приблизительно)
  for i:= 0 to ListView1.Items.Count - 1 do begin
    k:= length(ListView1.Items[i].Caption);
    if k > n then n:=k
  end;
  if n > 20 then begin
    k:= 416 + (15*(n-20)) div 2;  // ширина формы  (1 char = 7,5 pxl)
    if k > 800 then k:= 800;
    Width:= k
  end;
  CalcWidthLV(0, ListView1);

  if ListView1.MultiSelect then
    ListView1.OnSelectItem:= ListView1SelectItem
  else ListView1.OnSelectItem:= nil;
  BtnAll.Visible:= ListView1.MultiSelect;
  Left:= (Screen.Width - Width) div 2;
  Top:= (Screen.Height - Height) div 2;
  AlphaBlendValue:= 255; // Теперь открываемся
  AlphaBlend:= false;
end;

  { -- Передача FList от объекта FilesList форме FListFrm -- }

procedure TFListFrm.SetFIList(List: TList);
begin
  FList:= List;
end;

function TFListFrm.GetFileName(i:integer):string;
begin
  Result:= PFileInfo(FList.Items[i]).Name
end;

      { --- Обновление ListView1 --- }

procedure TFListFrm.LoadListView;
var
  PtrFileInfo: PFileInfo;
  LI: TListItem;
  s: string; i: integer;
begin
  ListView1.Clear;
  for i:= 0 to FList.Count - 1 do begin
    PtrFileInfo:= FList.Items[i];
    LI:= ListView1.Items.Add;
    if UpperCase(ExtractFileExt(PtrFileInfo.Name)) = '.RAR' then begin
      LI.ImageIndex:= 1;
      LI.Caption:= ChangeFileExt(PtrFileInfo.Name,'');
    end
    else begin
      LI.ImageIndex:= -1;
      LI.Caption:= PtrFileInfo.Name;
    end;
    if PtrFileInfo.Flags > 0 then begin   // для Rar
      s:= '';
      if (PtrFileInfo.Flags and 4) = 4 then
        s:= ' *';   // файл зашифрован паролем
      if (PtrFileInfo.Flags and 1) = 1 then
        s:= s + ' <--';  // файл продолжается из предыдущего тома
      if (PtrFileInfo.Flags and 2) = 2 then
        s:= s + ' -->';  // файл продолжается в следующем томе
      LI.Caption:= LI.Caption + s
    end;
    LI.SubItems.Add(StrFileSize(PtrFileInfo.FSize));
    LI.SubItems.Add(StrFDateTime(PtrFileInfo.DTime));
  end;
  StatusBar1.Panels[0].Text:= ' Всего файлов - ' + IntToStr(FList.Count);
end; { LoadListView }

    { --- Сортировка по названию и проч. --- }
         // рабочая часть
procedure TFListFrm.QSortFList(iLo, iHi: Integer; GetStr: TGetString;
  FCompare: TCompareFunc);
var
  Lo, Hi: Integer; s: string; T: PFileInfo;

begin
  if iLo >= iHi then exit;
  repeat
    Lo:= iLo;
    Hi:= iHi;
    s:= GetStr(FList.Items[(Lo + Hi) shr 1]);
    repeat
      while FCompare(FList.Items[Lo], s) < 0 do inc(Lo);
      while FCompare(FList.Items[Hi], s) > 0 do dec(Hi);
      if (Lo <= Hi) then begin
        T:= FList.Items[Lo];
        FList.Items[Lo]:= FList.Items[Hi];
        FList.Items[Hi]:= T;
        inc(Lo);
        dec(Hi);
      end;
    until (Lo > Hi);
    if (iLo < Hi) then
      QSortFList(iLo, Hi, GetStr, FCompare);
    iLo:= Lo;
  until (Lo >= iHi);
end;

      { ---  Сортировки: запуск  --- }

procedure TFListFrm.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
var
  P: Pointer; Y,i,C: integer;
begin
  if ListView1.ItemIndex >= 0 then
    P:= FList.Items[ListView1.ItemIndex]
  else P:= nil;
  C:= 1;
  if Column = ListView1.Columns[1] then C:= 2
  else if Column = ListView1.Columns[2] then C:= 3;
  if C = ListView1.Tag then exit;
  if ListView1.Tag > 0 then  // уберем значок сортировки
    ListView1.Columns[ListView1.Tag - 1].ImageIndex:= -1;
  ListView1.Tag:= C; // вариант сортировки
  case C of
    1: QSortFList(0, FList.Count - 1, GetName, CompareName);
    2: QSortFList(0, FList.Count - 1, GetFSize, CompareSize);
    3: QSortFList(0, FList.Count - 1, GetFDate, CompareDate);
  end;
  Column.ImageIndex:= 0; // покажем значок сорт-ки
  LoadListView;  // перезагрузка ListView
  for i:= 0 to ListView1.Items.Count - 1 do
    if FList.Items[i] = P then begin
      ListView1.ItemIndex:= i;
      break
    end;
  if self.Visible and (ListView1.ItemIndex >= 0) then begin
    Y:= (ListView1.ItemIndex + 2) * 17; // если строка за пределами
    if Y > ListView1.ClientHeight then  // ClientHeight, то поднимем строки
      ListView1.Scroll(0, Y - ListView1.ClientHeight + 8);
    ListView1.SetFocus;
    if ListView1.ItemIndex >= 0 then    // вернем курсор на свою строку
      ListView1.ItemFocused:= ListView1.Items[ListView1.ItemIndex]
  end;
end; { ListView1ColumnClick }

  { ---- Информация о количестве выбранных файлов ---- }

procedure TFListFrm.ListView1SelectItem(Sender: TObject; Item: TListItem;
  Selected: Boolean);
begin
  StatusBar1.Panels[1].Text:=
    ' Выбрано файлов - ' + IntToStr(ListView1.SelCount)
end;

    { ----- BtnAll ----- }

procedure TFListFrm.BtnAllClick(Sender: TObject);
begin
  ListView1.SetFocus;
  ListView1.SelectAll;
end;

    { ----- DblClick ----- }

procedure TFListFrm.ListView1DblClick(Sender: TObject);
begin
  MRes:=1;
  Close;
end;
       { ----- FormClose ----- }

procedure TFListFrm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if MRes = 1 then ModalResult:= 1
end;

  { ============  For 2 Objects: TFilesList and TRarList  =============== }

  { ============  1. TFilesList ========= }

constructor TFilesList.Create(FNames:string);
  // папки исключаются - только файлы
var
  SR: TSearchRec;  PtrFileInfo: PFileInfo;
begin
  FName:= '';
  FAllSel:= false;
  FList:= TList.Create;
  FList.Clear;
  Multi:= false;      // default
  FormCaption:= ' Загрузить файл'; // ***
  FBtnCaption:= 'OK';
  if FindFirst(FNames, faAnyFile, SR) <> 0 then begin
    FindClose(SR); exit;
  end;
  repeat
    if SR.Attr and $10 = 0 then begin // only for files
      new(PtrFileInfo);
      PtrFileInfo.Name:= SR.Name;
      PtrFileInfo.FSize:= SR.Size;
      move(SR.Time, PtrFileInfo.DTime, 4);
      PtrFileInfo.Flags:= 0;  // это исп-ся только в Rar
  {
    if SR.Attr and $10 = $10 then PtrFileInfo.FAttr:= $10
    else if SR.Attr and $20 = $20 then PtrFileInfo.FAttr:= $20;
  }
      FList.Add(PtrFileInfo);
    end
  until FindNext(SR) <> 0;
  FindClose(SR);
end; { TFilesList.Create }


procedure TFilesList.Clear;
var
  i: integer; PtrFileInfo: PFileInfo;
begin
  if FList.Count = 0 then exit;
  for i:= 0 to FList.Count - 1 do begin
    PtrFileInfo:= FList.Items[i];
    dispose(PtrFileInfo);
  end;
  FList.Clear
end;

  { ---- Запуск выбора через форму ---- }

function TFilesList.Execute: boolean;
var
  FListFrm: TFListFrm;
  k,m: integer;
begin
  Result:= false;
  FName:= '';
  FAllSel:= false;
  if FList.Count = 0 then exit;
  FListFrm:= TFListFrm.Create(nil);
     // передача данных до FListFrm.Activate
  FListFrm.Caption:= FormCaption;
  FListFrm.BtnOK.Caption:= FBtnCaption;
  if FBtnCaption <> 'OK' then FListFrm.BtnOK.Glyph:= nil;
  FListFrm.ListView1.MultiSelect:= Multi;
  FListFrm.FIList:= FList;  // передается адрес объекта
  m:= FListFrm.ShowModal;
  Application.ProcessMessages;
  if m = 1 then
    with FListFrm.ListView1 do
      if MultiSelect then begin
        for k:= 0 to Items.Count - 1 do
          if Items[k].Selected then
            FName:= FName + ' "' + PFileInfo(FList.Items[k]).Name + '"';
        FName:= Trim(FName);
        FAllSel:= Items.Count = SelCount;
      end
      else
        for k:= 0 to Items.Count - 1 do
          if Items[k].Selected then begin
            FName:= PFileInfo(FList.Items[k]).Name;
            break
          end;
  FListFrm.Free;
  Result:= FName <> ''
end; { TFilesList.Execute }

procedure TFilesList.SetFCaption(Tit:string);
begin
  FormCaption:= Tit
end;

function TFilesList.GetFCaption:string;
begin
  Result:= FormCaption
end;

procedure TFilesList.SetBtnCaption(Cap:string);
begin
  FBtnCaption:= Cap
end;

procedure TFilesList.SetMulti(MultiSelect:boolean);
begin
  Multi:= MultiSelect
end;

function TFilesList.GetCount: integer;
begin
  Result:= FList.Count
end;

function TFilesList.GetAllSel:boolean;
begin
  Result:= FAllSel
end;

function TFilesList.GetFName: string;
begin
  Result:= FName
end;

destructor TFilesList.Destroy;
begin
  inherited;
  Clear;
  FList.Free;
end;

  { =========  2. TRarList ======== }

constructor TRarList.Create(RarFName:string);
  { реально структура Rar-файла несколько сложнее,
    но данного упрощения хватает на 99,9%,
    а если процедуры сжатия использовать только у себя, то это 100%}
const
  MARKER = 'Rar!'#26#7#0;
type
  { В начале Rar-файла 20 байт - его заголовок и т.п. }
  // после этого ...
  RarHeader = packed record   // 32 bytes
    HeadCRC : word;
    HeadType: byte;   // $74 - normal
    Flags   : word;
    HeadSize: word;
    PackSize: Cardinal;
    FSize   : Cardinal;
    HostOS  : byte;
    FileCRC : Cardinal;
    FTime   : Cardinal; // при Type = $7A и Name=RR- не исп-ся
    UnpVer  : byte;
    Method  : byte;
    NameSize: word;
    FAttr   : Cardinal;
  end; // далее имя файла, его содержимое
   // вариант для  HeadType = $79  (эл.подпись и т.п.)
  EHeader = packed record  // 15 bytes
    HeadCRC : word;
    HeadType: byte;   // $79
    Reserve : cardinal;
    FTime   : Cardinal;
    FNameSz : word;
    FAutorSz: word;
  end; // далее имя Rar-файла, его автор и проч.

var
  s: string;
  T: TFileStream;  // uses Classes
  RHead: RarHeader;
//  EHead: EHeader; M,C: word;
  FSize: int64;
  GoodRecord: boolean;
  PtrFileInfo: PFileInfo;

    { - Перевод кодировки из MS-DOS в Windows - }
  procedure DOStoWin(var s:string);
  var p: PAnsiChar;
  begin
    if s = '' then exit;
    p:= PAnsiChar(s);
    OEMToChar(p, p);
    s:= p
  end;

begin { TRarList.Create }
     // будем использовать только файлы
  FName:= '';
  FAllSel:= false;
  Multi:= true;  // default
  FormCaption:= ' Извлечь файлы из "' + ExtractFileName(RarFName) + '"';
  FBtnCaption:= 'OK';
  FList:= TList.Create;
  FList.Clear;
  T:= TFileStream.Create(RarFName, fmOpenRead);
  FSize:= T.Size;
  setlength(s,7);
  T.Read(s[1],7);
  if s <> MARKER then begin
    T.Free;    // не Rar-файл
    exit
  end;
  T.Seek(13, soCurrent);  // TSeekOrigin = (soBeginning, soCurrent, soEnd);
  PtrFileInfo:= nil;  // формальности Delphi
  while T.Position + 32 < FSize do begin
    try
      GoodRecord:= false;
      T.Read(RHead, 32);
      with RHead do begin
        case HeadType of
          $74: if FAttr and $30 = $20 then
               begin  // файл, но не папка ($20 - file, $10 - folder)
                 GoodRecord:= true;
                 new(PtrFileInfo);
                 PtrFileInfo.FSize:= FSize;
                 PtrFileInfo.DTime:= FTime;
               end;
          $7A: begin
                 // CMT - рассм. как файл, но не вкл. в список
                 // там Attr = 1
                {  это не используем - для кругозора:
                  AV - эл. подпись, RR - резерв для восстановления
                  там бывает RHead.FTime = 0
                  AV и RR - в конце файла  }
               end;
          $79: begin
                // на этом конец
              {  это тоже не используем
                move(RHead, EHead, SizeOf(EHead));
                T.Seek(SizeOf(EHead) - SizeOf(RHead), soCurrent);
                   // имя файла
                Setlength(s, EHead.FNameSz);
                T.Read(s[1], EHead.FNameSz);
                   // автор
                Setlength(s, EHead.FAutorSz);
                T.Read(s[1], EHead.FAutorSz);
                 }
                 break
               end;
        end; { case }
        SetLength(s, RHead.NameSize);
        T.Read(s[1], RHead.NameSize);
        DOSToWin(s);
        // здесь же и CMT, AV, RR - но их не записываем
        if GoodRecord then begin
          // окончание заполнения PtrFileInfo
          PtrFileInfo.Flags:= Flags and 7;  // нужны только 1, 2 или 4
          PtrFileInfo.Name:= s;
          FList.Add(PtrFileInfo);
        end;
        if (HeadType = $7A) and (s = 'AV') then begin
          {  это тоже не используем
          T.Read(M, 2); // размер имени файла
          SetLength(s, M);
          T.Read(s[1], M);
          DOSToWin(s); // имя файла

          T.Seek(2, soCurrent); // пропуск 2 байт
          T.Read(C, 2);         // размер строки автора
          SetLength(s, C);
          T.Read(s[1], C);
          DOSToWin(s); // автор
          T.Seek(-M-C-6, soCurrent);
          }
        end;
        T.Seek(PackSize + HeadSize - 32 - NameSize, soCurrent);
      end; { with RHead }
    except
      break
    end;
  end; { while T.Position + 32 < FSize }
  T.Free;
end; { TRarList.Create }

 { =============  Применение модуля ============== }

function SelectFile(FNames,FrmCap: string; var FN: string): boolean;
var FilesList: TFilesList;
begin
  Result:= false;
  FilesList:= TFilesList.Create(FNames);
  FilesList.Title:= FrmCap;
  if FilesList.Count = 0 then
    Application.MessageBox('Файлов нет!', PChar(FrmCap), MB_ICONWARNING)
  else if FilesList.Execute then begin
    FN:= FilesList.FileName;
    Result:= true;
  end;
  FilesList.Free
end; { SelectFile }

 { ---- Выбор имени файла из Rar-файла ---- }

function SelectInRar(RarFile: string; var FN: string): boolean;
var RarList: TRarList;
begin
  Result:= false;
  RarList:= TRarList.Create(RarFile);
  if RarList.Count = 0 then
    Application.MessageBox('Файлов нет!',
      ' Восстановление данных из архива', MB_ICONWARNING)
  else if RarList.Execute then begin
    FN:= RarList.FileName;
    Result:= true;
  end;
  RarList.Free
end;

end.