Запись нескольких файлов изображений в один

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ExtDlgs;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button6: TButton;
    Button5: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Memo1: TMemo;
    ListBox1: TListBox;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    OpenPictureDialog1: TOpenPictureDialog;
    SavePictureDialog1: TSavePictureDialog;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    Image1: TImage;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure ListBox1DblClick(Sender: TObject);
    procedure ListBox1KeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure CloseDb;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
uses
  JPeg, Math;
 
type
  //Заголовок ресурса в файле БД.
  TResTitle = packed record
    SName : String[30]; //Имя ресурса.
    SType : String[10]; //Тип основных данных ресурса.
    Size : Integer;     //Размер основных данных ресурса.
  end;
  //Сведения о ресурсе.
  TResInfo = record
    SName, SType : String; //Имя ресурса и тип его основных данных.
    Position, Size : Integer; //Позиция ресурса и размер его основных данных.
  end;
  //Массив сведений о ресурсах.
  TArrResInfo = array of TResInfo;
 
var
  gFs : TFileStream; //Файловый поток, связанный с файлом БД.
  gDbFileName : String; //Имя файла БД.
  gArrResInfo : TArrResInfo; //Массив сведений о ресурсах.
  gInd : Integer = -1; //Индекс выбранного ресурса.
 
//--------------------------------------------------
//API для работы с БД. Начало.
//--------------------------------------------------
 
//Прочитать список сведений о ресурсах, расположенных в потоке aStm.
function ReadResList(aStm : TStream; var aArr : TArrResInfo) : Boolean;
const
  SelfName = 'GetResList()'; //Имя функции.
  Capacity = 10; //Величина приращения длины динамического массива.
var
  ResTitle : TResTitle;
  i, Len, RPos : Integer;
begin
  Result := False;
  if aStm = nil then Exit;
 
  try
    aStm.Position := 0;
    i := -1;
    while aStm.Position < aStm.Size do begin
      RPos := aStm.Position; //Позиция, начиная с которой расположен ресурс.
      Len := SizeOf(ResTitle); //Размер заголовка ресурса.
      if aStm.Read(ResTitle, Len) < Len then //Попытка прочитать заголовок ресурса.
        raise Exception.Create(SelfName + '. Неверный формат данных.');
      Inc(i); //Индекс следующего элемента в массиве.
      //Если требуется увеличиваем размер массива.
      if i = Length(aArr) then SetLength(aArr, i + Capacity);
      //Добавляем в массив сведения о ресурсе.
      aArr[i].SName := ResTitle.SName;
      aArr[i].SType := ResTitle.SType;
      aArr[i].Position := RPos;
      aArr[i].Size := ResTitle.Size;
      //Перепрыгиваем через основные данные ресурса.
      RPos := aStm.Position + ResTitle.Size;
      aStm.Position := RPos;
      if aStm.Position < RPos then
        raise Exception.Create(SelfName + '. Неверный формат данных.');
    end;
  except
    aArr := nil;
    raise;
  end;
 
  if i < High(aArr) then SetLength(aArr, i + 1);
  Result := True;
end;
 
//Прочитать из потока aStmSrc ресурс, начиная с текущей позиции.
function ReadNextRes(aStmSrc : TStream; var aResTitle : TResTitle;
  aStmTrg : TStream) : Boolean;
var
  Len : Integer;
begin
  Result := False;
  if (aStmSrc = nil) or (aStmTrg = nil) then Exit;
 
  //Размер заголовка ресурса.
  Len := SizeOf(aResTitle);
  //Попытка прочитать заголовок ресурса.
  if aStmSrc.Read(aResTitle, Len) < Len then Exit;
  //Попытка прочитать основные данные ресурса.
  if aStmTrg.CopyFrom(aStmSrc, aResTitle.Size) < aResTitle.Size then Exit;
 
  Result := True;
end;
 
//Прочитать из потока aStmSrc ресурса, который расположен, начиная с позиции aRPos.
function ReadRes(aStmSrc : TStream; const aRPos : Integer;
  var aResTitle : TResTitle; aStmTrg : TStream) : Boolean;
begin
  Result := False;
  if (aStmSrc = nil) or (aStmTrg = nil) or (aRPos < 0) then Exit;
 
  //Попытка перместить указатель потока к началу ресурса.
  if aStmSrc.Seek(aRPos, 0) = aRPos then
    Result := ReadNextRes(aStmSrc, aResTitle, aStmTrg); //Попытка прочитать данные ресурса.
end;
 
//Добавить ресурс в конец потока aStmTrg. Основные данные ресурса
//берутся из потока aStmSrc.
function WriteRes(aStmTrg : TStream; var aResTitle : TResTitle; aStmSrc : TStream) : Boolean;
begin
  Result := False;
  if (aStmTrg = nil) or (aStmSrc = nil) then Exit;
 
  aStmTrg.Position := aStmTrg.Size; //Переходим в конец целевого потока.
  aResTitle.Size := aStmSrc.Size; //Размер основных данных ресурса.
  aStmTrg.Write(aResTitle, SizeOf(aResTitle)); //Записываем заголовок ресурса.
  aStmSrc.Position := 0; //Переходим в начало потока aStmSrc.
  aStmTrg.CopyFrom(aStmSrc, aStmSrc.Size); //Записываем основные данные ресурса.
 
  Result := True;
end;
 
//Удалить из потока aStm ресурс, расположенный, начиная с текущей позиции.
function DeleteNextRes(aStm : TStream) : Boolean;
const
  BuffSize = 1000000; //Размер буфера в байтах.
var
  ResTitle : TResTitle;
  Len, RPos1, RPos2 : Integer;
  Ms : TMemoryStream;
begin
  Result := False;
  if aStm = nil then Exit;
 
  //Позиция начала ресурса.
  RPos1 := aStm.Position;
  //Размер заголовка ресурса.
  Len := SizeOf(ResTitle);
  //Попытка прочитать заголовок ресурса.
  if aStm.Read(ResTitle, Len) < Len then Exit;
  //Перепрыгиваем через основные данные ресурса.
  aStm.Position := aStm.Position + ResTitle.Size;
 
  //Удаление ресурса.
  {Удаление заключается в следующем. Чать, расположенную справа от удаляемого
  ресурса, мы сдвинем на место удаляемого ресурса. А потом уменьшим размер
  потока ровно на размер удалённого ресурса.}
  Ms := TMemoryStream.Create;
  try
    while aStm.Position < aStm.Size do begin
      //ВНИМАНИЕ! Метод CopyFrom() не отслеживает выход за пределы потока!
      //Поэтому приходится вручную вычислять количество скопированных байтов.
      Len := Min(BuffSize, aStm.Size - aStm.Position);
      Len := Ms.CopyFrom(aStm, Len);
      RPos2 := aStm.Position;
      aStm.Position := RPos1;
      Ms.Position := 0;
      aStm.CopyFrom(Ms, Len);
      RPos1 := aStm.Position;
      aStm.Position := RPos2;
    end;
  finally
    FreeAndNil(Ms);
  end;
  aStm.Size := RPos1;
 
  Result := True;
end;
 
//Удалить из потока aStm ресурс, расположенный, начиная с позиции aRPos.
function DeleteRes(aStm : TStream; const aRPos : Integer) : Boolean;
begin
  Result := False;
  if (aStm = nil) or (aRPos < 0) then Exit;
 
  //Попытка перместить указатель потока к началу ресурса.
  if aStm.Seek(aRPos, 0) = aRPos then
    Result := DeleteNextRes(aStm); //Попытка удалить ресурс.
end;
 
//--------------------------------------------------
//API для работы с БД. Коенц.
//--------------------------------------------------
 
//--------------------------------------------------
//Прикладной интерфейс.
//--------------------------------------------------
 
//Закрыть БД.
procedure TForm1.CloseDb;
begin
  FreeAndNil(gFs);
  gDbFileName := '';
  gArrResInfo := nil;
  gInd := -1;
  Memo1.Clear;
  ListBox1.Clear;
  Image1.Picture := nil;
  Label2.Caption := 'Ресурс:';
end;
 
//Перед закрытием формы закрываем файл БД.
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CloseDb;
end;
 
//Открыть файл БД.
procedure TForm1.Button1Click(Sender: TObject);
var
  i : Integer;
  Od : TOpenDialog;
begin
  Od := OpenDialog1;
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Od.Execute then Exit;
 
  CloseDb;
  if FileExists(Od.FileName) then
    gFs := TFileStream.Create(Od.FileName, fmOpenReadWrite + fmShareDenyWrite)
  else
    gFs := TFileStream.Create(Od.FileName, fmCreate);
 
  gDbFileName := Od.FileName;
  Memo1.Text := gDbFileName;
 
  //Читаем из БД сведения о ресурсах.
  if not ReadResList(gFs, gArrResInfo) then begin
    MessageBox(Handle, 'Не удалось прочитать список ресурсов.'
      ,'Внимание!', MB_OK + MB_ICONWARNING + MB_APPLMODAL);
    Exit;
  end;
  //Записываем сведения о ресурсах в ListBox.
  ListBox1.Clear;
  for i := 0 to High(gArrResInfo) do
    ListBox1.Items.Add(gArrResInfo[i].SName + ' / ' + gArrResInfo[i].SType
      + ' / ' + IntToStr(gArrResInfo[i].Position)
      + ' / ' + IntToStr(gArrResInfo[i].Size));
end;
 
//Закрыть файл БД.
procedure TForm1.Button2Click(Sender: TObject);
begin
  CloseDb;
end;
 
//Удалить ресурс.
procedure TForm1.Button3Click(Sender: TObject);
var
  i, Ind : Integer;
begin
  {MessageBox(Handle, 'Функция не реализована! Действие отменено.'
    ,'Внимание!', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);}
  if gFs = nil then Exit;
  Ind := ListBox1.ItemIndex;
  if Ind = -1 then Exit;
 
  //Удаляем ресурс из БД.
  if not DeleteRes(gFs, gArrResInfo[Ind].Position) then begin
    MessageBox(Handle, 'Не удалось удалить ресурс из файла!'
      ,'Ошибка!', MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
  //Удаляем сведения о ресурсе из массива и исправляем данные
  //о ресурсах в ListBox.
  ListBox1.Items.Delete(Ind);
  for i := Ind to High(gArrResInfo) - 1 do begin
    gArrResInfo[i + 1].Position := gArrResInfo[i].Position;
    gArrResInfo[i] := gArrResInfo[i + 1];
    ListBox1.Items[i] := gArrResInfo[i].SName + ' / ' + gArrResInfo[i].SType
      + ' / ' + IntToStr(gArrResInfo[i].Position)
      + ' / ' + IntToStr(gArrResInfo[i].Size);
  end;
  SetLength(gArrResInfo, Length(gArrResInfo) - 1);
  //Если удалён тот ресурс, который показан в TImage, то очищаем TImage.
  if Ind = gInd then begin
    Image1.Picture := nil;
    gInd := -1;
  end;
end;
 
//Записать изображение в файл.
procedure TForm1.Button4Click(Sender: TObject);
var
  i : Integer;
  Spd : TSavePictureDialog;
begin
  if gInd = -1 then Exit;
 
  Spd := SavePictureDialog1;
  Spd.FileName := gArrResInfo[gInd].SName + '.' + gArrResInfo[gInd].SType;
  if Spd.InitialDir = '' then
    Spd.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Spd.Execute then Exit;
  if FileExists(Spd.FileName) then begin
    i := MessageBox(Handle, 'Файл с заданным именем уже существует. Перезаписать?'
      ,'Перезаписать?', MB_YESNO + MB_ICONQUESTION + MB_APPLMODAL);
    if i <> IDYES then Exit;
  end;
 
  Image1.Picture.SaveToFile(Spd.FileName);
end;
 
//Загрузка изображения из файла.
procedure TForm1.Button5Click(Sender: TObject);
var
  FileName, Ext : String;
  Opd : TOpenPictureDialog;
begin
  Opd := OpenPictureDialog1;
  if Opd.InitialDir = '' then
    Opd.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Opd.Execute then Exit;
 
  if not FileExists(Opd.FileName) then begin
    MessageBox(Handle, 'Файл с заданным именем не найден. Действие отменено.'
      ,'Внимание!', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
 
  //Расширение файла.
  Ext := ExtractFileExt(Opd.FileName);
  //Расширение без точки, приведённое к верхнему регистру.
  Edit2.Text := AnsiUpperCase( Copy(Ext, 2, Length(Ext) - 1) );
  //Имя файла с расширением.
  FileName := ExtractFileName(Opd.FileName);
  //Имя файла без расширения, приведённое к верхнему регистру.
  Edit1.Text := AnsiUpperCase( Copy(FileName, 1, Length(FileName) - Length(Ext)) );
 
  Image2.Picture.LoadFromFile(Opd.FileName);
end;
 
//Добавить ресурс в БД.
procedure TForm1.Button6Click(Sender: TObject);
var
  ResTitle : TResTitle;
  i, RPos : Integer;
  Ms : TMemoryStream;
begin
  //Открыт ли поток.
  if gFs = nil then begin
    MessageBox(Handle, 'База данных закрыта. Действие отменено.'
      ,'Внимание!', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
  //Имя ресруса в верхнем регистре.
  ResTitle.SName := AnsiUpperCase(Edit1.Text);
  if ResTitle.SName = '' then begin
    MessageBox(Handle, 'Имя ресурса не задано. Действие отменено.'
      ,'Внимание!', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
  //Тип ресурса.
  ResTitle.SType := AnsiUpperCase(Edit2.Text);
 
  Ms := TMemoryStream.Create;
  try
    //Переписываем данные в поток памяти.
    Image2.Picture.Graphic.SaveToStream(Ms);
    //Добавляем ресурс в БД.
    RPos := gFs.Size;
    Ms.Position := 0;
    if WriteRes(gFs, ResTitle, Ms) then begin
      //Добавляем сведения о ресурсе в массив.
      i := Length(gArrResInfo);
      SetLength(gArrResInfo, i + 1);
      gArrResInfo[i].SName := ResTitle.SName;
      gArrResInfo[i].SType := ResTitle.SType;
      gArrResInfo[i].Position := RPos;
      gArrResInfo[i].Size := Ms.Size;
      //Добавляем сведения о ресурсе в список ListBox.
      ListBox1.Items.Add(gArrResInfo[i].SName + ' / ' + gArrResInfo[i].SType
        + ' / ' + IntToStr(gArrResInfo[i].Position)
        + ' / ' + IntToStr(gArrResInfo[i].Size));
    end else
      MessageBox(Handle, 'Не удалось записать ресурс в БД.'
        ,'Ошибка!', MB_OK + MB_ICONERROR + MB_APPLMODAL);
  finally
    FreeAndNil(Ms);
  end;
end;
 
//Показать выбранный ресурс при двойном щелчке левой кнопки мыши.
procedure TForm1.ListBox1DblClick(Sender: TObject);
var
  ResTitle : TResTitle;
  Graphic : TGraphic;
  Ms : TMemoryStream;
  Lb : TListBox;
begin
  Lb := Sender as TListBox;
  gInd := Lb.ItemIndex;
  if gInd = -1 then Exit;
 
  Ms := TMemoryStream.Create;
  try
    //Попытка прочитать выбранный ресурс в поток памяти Ms.
    if not ReadRes(gFs, gArrResInfo[gInd].Position, ResTitle, Ms) then begin
      MessageBox(Handle, 'Выбранный ресурс прочитать не удалось.'
        ,'Ошибка!', MB_OK + MB_ICONERROR + MB_APPLMODAL);
      Exit;
    end;
    //Показываем сведения о ресурсе.
    Label2.Caption := 'Ресурс: ' + Lb.Items[gInd];
    //В зависимости от типа ресурса выбираем тип графического объекта.
    if (ResTitle.SType = 'JPG') or (ResTitle.SType = 'JPEG') then
      Graphic := TJPEGImage.Create
    else if ResTitle.SType = 'BMP' then
      Graphic := TBitmap.Create
    else begin
      MessageBox(Handle, 'Для данного типа ресурса нет функции просмотра.'
        ,'Отмена!', MB_OK + MB_ICONWARNING + MB_APPLMODAL);
      FreeAndNil(Ms);
      Exit;
    end;
    //Загружаем графические данные в TImage.
    try
      Ms.Position := 0;
      Graphic.LoadFromStream(Ms);
      Image1.Picture.Graphic := Graphic;
    finally
      FreeAndNil(Graphic);
    end;
  finally
    FreeAndNil(Ms);
  end;
end;
 
//Показать выбранный ресурс при нажатии клавиши Enter.
procedure TForm1.ListBox1KeyPress(Sender: TObject; var Key: Char);
begin
  if Key <> #13 then Exit;
  ListBox1DblClick(Sender);
end;
 
end.