Распаковщик псевдо архивов

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, DB, DBTables, ExtDlgs, ComCtrls, FileCtrl;
//  Dialogs, StdCtrls, ExtCtrls, TeEngine, Series, TeeProcs, Chart;
 
type
  TForm1 = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    ProgressBar1: TProgressBar;
    Button4: TButton;
    Label1: TLabel;
    Memo1: TMemo;
    TabSheet3: TTabSheet;
    OpenDialog1: TOpenDialog;
    OpenDialog2: TOpenDialog;
    SaveDialog1: TSaveDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
     Edit1.Text:=OpenDialog1.FileName;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
  if OpenDialog2.Execute then
    Edit2.Text:=OpenDialog2.FileName;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
path_dir: string;
begin
if SelectDirectory('Путь к папке ','C:\', path_dir) then
Edit3.Text:= (path_dir);
end;
procedure TForm1.Button4Click(Sender: TObject);
Var
    f, OutF : File;         //Нетипизированный файл
    StrList : TStringList;  // Работа со списком строк.
  i, IL, II : Integer;      //Переменные смещения
     BegPos : Integer;     // Начало позиции
     EndPos : Integer;     // Конец позиции
 s, OutFile : String;      //Выходной фаил
  Buf : Array[0..65535] Of Byte;
  Buf1 : WideString;
begin
  StrList:= TStringList.Create;
 
  //Читаем таблицу (Юникод)...
  AssignFile(f,OpenDialog2.FileName);
  Reset(f,SizeOf(WideChar));
  IL:=FileSize(f);
  //Устанавливаем длину Buf1 такую,
  //чтобы в неё поместились данные из файла.
  SetLength(Buf1,IL);
  BlockRead(f,PWideChar(Buf1)^,IL,II); //Читаем файл...
  StrList.Text:=WideCharLenToString(PWideChar(Buf1),II);
  CloseFile(f); //Закрываем файл таблицы
 
  //Само разрезание...
  AssignFile(f,OpenDialog1.FileName);
  Reset(f,1);
  //Настроим ProgressBar...
  ProgressBar1.Min:=0;
  ProgressBar1.Max:=StrList.Count-1;
  For i:=0 To StrList.Count-1 Do
  Begin
    ProgressBar1.Position:=i; //Отображение в ProgressBar
 
    s:=StrList.Strings[i];
//    While s[1]='0' Do Delete(s,1,1);
    BegPos:=StrToInt('$'+Copy(s,1,Pos('#',s)-1));  //Начальная позиция в исходном файле
    Delete(s,1,Pos('#',s));
//    While s[1]='0' Do Delete(s,1,1);
    EndPos:=StrToInt('$'+Copy(s,1,Pos('#',s)-1));  //Конечная позиция в исходном файле
    OutFile:=Copy(s,Pos('#',s)+1,Length(s)-Pos('#',s)); //Имя выходного файла
    AssignFile(OutF,Edit3.Text+'\'+OutFile);
    Rewrite(OutF,1);                //Создаём результирующий файл в указанной директории
    Seek(f,BegPos);                //Указатель на начальную позицию
    While BegPos<=EndPos Do
    Begin
    If (EndPos-BegPos)>65535 Then IL:=65536 Else IL:=EndPos-BegPos+1;
      BlockRead(f,Buf,IL,II);     //Читаем блок из исходного файла
      BlockWrite(OutF,Buf,II);    //Пишем блок в новый файл
      BegPos:=BegPos+II;
    End;
    CloseFile(OutF); //Закрываем выходной файл
  End;
  CloseFile(f); //Закрываем входной файл
StrList.Free 
end;
end.

procedure TForm1.Button3Click(Sender: TObject);
var
path_dir: string;
begin
if SelectDirectory('Путь к папке','C:\', path_dir) then
Edit3.Text:= (path_dir);
end;

   if not FileExists(OpenDialog1.FileName) then begin
    MessageDlg('Не указан файл.', mtError, [mbYes], 0);
    Exit;
   end;

If DirectoryExists('имя директории') Then

MkDir('путь и имя директории');

Type
  Zap = Record
             NameF : Array[0..11] Of Byte;
             LengFile : Integer;
             BegPos : Integer;
           End;

procedure TForm1.Button1Click(Sender: TObject);
Var
  f : File;
  s : String;
  Buf : Pointer;
begin
  GetMem(Buf,10); //Резервируем память для буфера
 
  AssignFile(f,'Файл.ttt'); //Связываем файловую переменную с файлом
  Reset(f,1);               //Открываем файл для чтения
  s:='0123456789';          //Резервируем поле строки
 
  While ((Not Eof(f)) And (FilePos(f)<=200)) Do
  //Обработка, пока не конец файла и позиция в файле до 200
  Begin
    BlockRead(f,Buf^,10,II); //Читаем 10 байт из файла в буфер Buf
    Move(Buf^,s[1],10); //Переносим данные из буфера в строку
    Memo1.Lines.Add(s); //Добавляем строку в Memo
  End;
 
  FreeMem(Buf,10); //Освобождаем память буфера
end;

Type
  Zap = Record
             NameF : String[12];
             LengFile : Integer;
             BegPos : Integer;
           End;
Var
  VarZap : Zap; //Объявили переменную нашего типа
 
.....
 
  While ((Not Eof(fTable)) And Busy) Do
  Begin
    BlockRead(fTable,Zap,SizeOf(Zap),II); //Читаем прямо в нашу переменную
    OutFile:=Zap.NameF;                       //и с ней работаем, а не с буфером
 
    //Само разрезание...
 
    BegPos:=Zap.BegPos; //Начальная позиция в исходном файле
    EndPos:=BegPos+Zap.LengFile;  //Конечная позиция в исходном файле
 
    //Запишем строку в файл отчёта
    s:=IntToHex(BegPos,8)+':'+IntToHex(Zap.LengFile,8)+':'+OutFile;
......

Program idxndat;
{$APPTYPE CONSOLE}
Uses SysUtils;
Var
    Sz, TF, I, FOffs, FSize: LongInt;
             Fidx, Fdat, Fl: File;
                          P: Pointer;
                          S: String;
Begin
  WriteLn('Rome: Total War .IDX + .DAT file extractor (music, voices and sound ONLY!)');
  WriteLn('You can find it in: \Rome - Total War\Data\sounds');
  WriteLn('T#i$ PR0GR@M bY -=CHE@TER=-');
  WriteLn;
  If ParamCount<>1 Then
    Begin
      WriteLn('Usage: idxndat filename.<idx|dat>');
      WriteLn;
      Exit;
    End;
 
  S:=Copy(ParamStr(1), 1, Length(ParamStr(1)) - 3) + 'idx';
  If Not FileExists(S) Then
    Begin
      WriteLn('Error: index file "', S, '" not exists!');
      Exit;
    End;
  AssignFile(Fidx, S);
  Reset(Fidx, 1);
 
  S:=Copy(ParamStr(1), 1, Length(ParamStr(1)) - 3) + 'dat';
  If Not FileExists(S) Then
    Begin
      WriteLn('Error: data file "', S, '" not exists!');
      CloseFile(Fidx);
      Exit;
    End;
  AssignFile(Fdat, S);
  Reset(Fdat, 1);
 
  SetLength(S, 8);
  BlockRead(Fidx, S[1], 8);
  BlockRead(Fdat, S[1], 8);
  If S<>'SND.PACK' Then
    Begin
      WriteLn('Sorry, this program can extract ONLY "SND.PACK" signatured files.');
      WriteLn('Because "ENV.PACK" archives don''t have file names at all.');
      CloseFile(Fidx);
      CloseFile(Fdat);
      Exit;
    End;
  BlockRead(Fidx, Sz, 4); { $04 }
  BlockRead(Fdat, Sz, 4); { $04 }
  BlockRead(Fidx, TF, 4); { Total Files }
  BlockRead(Fdat, Sz, 4); { Total Files }
  If TF<>Sz Then
    Begin
      WriteLn('Different file counter in data and index file!');
      CloseFile(Fidx);
      CloseFile(Fdat);
      Exit; { Must be equal! }
    End;
  BlockRead(Fidx, Sz, 4); { File start in .dat file?.. }
  BlockRead(Fdat, I, 4); { File start in .dat file?.. }
  If I<>Sz Then { Must be equal! }
    Begin
      WriteLn('Different start offset in data and index file!');
      CloseFile(Fidx);
      CloseFile(Fdat);
      Exit; { Must be equal! }
    End;
  BlockRead(Fidx, Sz, 4); { Key?.. }
  BlockRead(Fdat, I, 4); { Key?.. }
  If I<>Sz Then { Must be equal! }
    Begin
      WriteLn('Different key in data and index file!');
      CloseFile(Fidx);
      CloseFile(Fdat);
      Exit; { Must be equal! }
    End;
  For I:=1 To TF Do
    Begin
      BlockRead(Fidx, FOffs, 4); { File offset }
      BlockRead(Fidx, FSize, 4); { File size }
      Seek(Fidx, FilePos(Fidx) + 12);
      BlockRead(Fidx, Sz, 4); { $0D --- ? }
      SetLength(S, 0);
      Repeat
        Sz:=Length(S) + 1;
        SetLength(S, Sz);
        BlockRead(Fidx, S[Sz], 1);
      Until S[Sz] = #0;
      SetLength(S, Sz - 1);
      WriteLn(S);
      GetMem(P, FSize);
      Seek(Fdat, FOffs);
      BlockRead(Fdat, P^, FSize);
      While Pos('/', S)<>0 Do
        Begin
          Sz:=Pos('/', S);
          If Sz <> 0 Then S[Sz]:=#0;
          If Not DirectoryExists('.\' + PChar(S)) Then MkDir('.\' + PChar(S));
          If Sz <> 0 Then S[Sz]:='\';
        End;
      AssignFile(Fl, '.\' + S);
      ReWrite(Fl, 1);
      BlockWrite(Fl, P^, FSize);
      CloseFile(Fl);
      FreeMem(P, FSize);
 
      SetLength(S, 3);
      BlockRead(Fidx, S[1], 3); { $CD CD CD --- ? }
    End;
  CloseFile(Fdat);
  CloseFile(Fidx);
  WriteLn('Total files: ', TF);
  WriteLn('Done.');
End.

var
  dirName : String;
 
begin
  // Создание нового каталога
  dirName := 'Test Folder';
  CreateDir(dirName);
 
  // Теперь проверяем существует ли каталог
  if DirectoryExists(dirName)
  then ShowMessage(dirName+' существует')
  else ShowMessage(dirName+' не существует');
 
  // Удаление каталога и просмотр снова
  RemoveDir(dirName);
  if DirectoryExists(dirName)
  then ShowMessage(dirName+' всё ещё существует!')
  else ShowMessage(dirName+' больше не существует');
end;

procedure TForm1.Button3Click(Sender: TObject);
var
path_dir: string;
begin
if SelectDirectory('выбор ','C:\', path_dir) then
Edit3.Text:= (path_dir);
 
end;

var
  Patch_dir : String;
 
begin
  // Теперь проверяем существует ли каталог
  if DirectoryExists(Patch_dir)
  then ShowMessage(Patch_dir+' существует')
  else ShowMessage(Patch_dir+' не существует');
exit;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
path_dir: string;
begin
  if SelectDirectory('выбор ','C:\', path_dir) then
  Edit3.Text:= (path_dir);
 
  // Теперь проверяем существует ли каталог
  if DirectoryExists(dirName) Then
  //Не существует...
  If MessageDlg('Такая папка не существует!'+#13+#10+'Создать?',mtWarning,mbOKCancel,0)=mbOK Then
  CreateDir(dirName) Else
  Edit3.Text:=''; //Если отказались - пустая строка
  //Дальше при запуске распаковки проверять если Edit3.Text='' - сразу выходить без обработки
end;

If MessageDlg('Такая папка не существует!'+#13+#10+'Создать?',mtWarning,mbOKCancel,0)=mbOK Then