Plancia/Console/uImageLib.pas

unit uImageLib;

{
  Libreria delle immagini usabili sulla plancia.

  Non e' una TImageList: quella impone a tutte le immagini la stessa
  dimensione e serve per icone di toolbar. Qui invece le immagini hanno misure
  qualsiasi (un LED da 32 px e un logo da 600 px stanno nella stessa libreria),
  quindi si tiene una lista di TPicture indicizzata per nome.

  Nell'XML si salvano nome e percorso, non i pixel: le immagini restano file
  sul disco, sostituibili senza toccare la configurazione. I percorsi sono
  relativi alla cartella del file di configurazione quando possibile, cosi'
  l'intera plancia si sposta copiando una cartella.
}

interface

uses
  System.SysUtils, System.Classes, System.IOUtils,
  System.Generics.Collections,
  Vcl.Graphics, Vcl.Imaging.pngimage, Vcl.Imaging.jpeg;

type
  TImageEntry = class
  public
    Name: string;
    /// Percorso come scritto nell'XML (di norma relativo alla sua cartella).
    FileName: string;
    Picture: TPicture;
    /// Messaggio dell'eventuale errore di caricamento; '' se tutto bene.
    Error: string;
    destructor Destroy; override;
    function Loaded: Boolean;
  end;

  TImageLibrary = class
  private
    FItems: TObjectList<TImageEntry>;
    FBaseDir: string;
    procedure LoadEntry(AEntry: TImageEntry);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    /// Cartella di riferimento per i percorsi relativi (quella dell'XML).
    procedure SetBaseDir(const ADir: string);
    function Find(const AName: string): TImageEntry;
    function Picture(const AName: string): TPicture;
    /// Aggiunge un file alla libreria; il nome e' reso univoco.
    function AddFile(const AFileName: string): TImageEntry;
    /// Usata dal caricamento XML: nome e percorso arrivano dal file.
    function AddEntry(const AName, AFileName: string): TImageEntry;
    procedure Delete(const AName: string);
    /// Ricalcola i percorsi rispetto a una nuova cartella di riferimento,
    /// senza spostare i file: serve al "Salva con nome" in un'altra cartella.
    procedure Rebase(const ANewDir: string);
    procedure ReloadAll;
    procedure FillNames(AStrings: TStrings; AIncludeEmpty: Boolean);
    function AbsolutePath(const AFileName: string): string;
    function Count: Integer;
    function Item(AIndex: Integer): TImageEntry;
    property BaseDir: string read FBaseDir;
  end;

implementation

{ TImageEntry }

destructor TImageEntry.Destroy;
begin
  Picture.Free;
  inherited;
end;

function TImageEntry.Loaded: Boolean;
begin
  Result := (Picture <> nil) and (Picture.Graphic <> nil) and
    not Picture.Graphic.Empty;
end;

{ TImageLibrary }

constructor TImageLibrary.Create;
begin
  inherited Create;
  FItems := TObjectList<TImageEntry>.Create(True);
end;

destructor TImageLibrary.Destroy;
begin
  FItems.Free;
  inherited;
end;

procedure TImageLibrary.Clear;
begin
  FItems.Clear;
end;

function TImageLibrary.Count: Integer;
begin
  Result := FItems.Count;
end;

function TImageLibrary.Item(AIndex: Integer): TImageEntry;
begin
  Result := FItems[AIndex];
end;

procedure TImageLibrary.SetBaseDir(const ADir: string);
begin
  FBaseDir := IncludeTrailingPathDelimiter(ADir);
  ReloadAll;
end;

function TImageLibrary.AbsolutePath(const AFileName: string): string;
begin
  if AFileName = '' then
    Exit('');
  if TPath.IsPathRooted(AFileName) then
    Exit(AFileName);
  Result := FBaseDir + AFileName;
end;

procedure TImageLibrary.LoadEntry(AEntry: TImageEntry);
var
  Full: string;
begin
  FreeAndNil(AEntry.Picture);
  AEntry.Error := '';
  Full := AbsolutePath(AEntry.FileName);
  if not FileExists(Full) then
  begin
    AEntry.Error := 'file non trovato: ' + Full;
    Exit;
  end;
  AEntry.Picture := TPicture.Create;
  try
    AEntry.Picture.LoadFromFile(Full);
  except
    on E: Exception do
    begin
      FreeAndNil(AEntry.Picture);
      AEntry.Error := E.Message;
    end;
  end;
end;

procedure TImageLibrary.ReloadAll;
var
  E: TImageEntry;
begin
  for E in FItems do
    LoadEntry(E);
end;

function TImageLibrary.Find(const AName: string): TImageEntry;
var
  E: TImageEntry;
begin
  if AName <> '' then
    for E in FItems do
      if SameText(E.Name, AName) then
        Exit(E);
  Result := nil;
end;

function TImageLibrary.Picture(const AName: string): TPicture;
var
  E: TImageEntry;
begin
  E := Find(AName);
  if (E <> nil) and E.Loaded then
    Result := E.Picture
  else
    Result := nil;
end;

function TImageLibrary.AddEntry(const AName, AFileName: string): TImageEntry;
begin
  Result := TImageEntry.Create;
  Result.Name := AName;
  Result.FileName := AFileName;
  FItems.Add(Result);
  LoadEntry(Result);
end;

function TImageLibrary.AddFile(const AFileName: string): TImageEntry;
var
  Base, Nome, Rel: string;
  N: Integer;
begin
  Base := ChangeFileExt(ExtractFileName(AFileName), '');
  Nome := Base;
  N := 1;
  while Find(Nome) <> nil do
  begin
    Inc(N);
    Nome := Format('%s %d', [Base, N]);
  end;

  // Percorso relativo se il file sta sotto la cartella della configurazione:
  // cosi' la plancia resta trasportabile copiando la cartella.
  Rel := AFileName;
  if (FBaseDir <> '') and AFileName.StartsWith(FBaseDir, True) then
    Rel := Copy(AFileName, Length(FBaseDir) + 1, MaxInt);

  Result := AddEntry(Nome, Rel);
end;

procedure TImageLibrary.Delete(const AName: string);
var
  E: TImageEntry;
begin
  E := Find(AName);
  if E <> nil then
    FItems.Remove(E);
end;

procedure TImageLibrary.Rebase(const ANewDir: string);
var
  E: TImageEntry;
  Full, NewBase: string;
begin
  NewBase := IncludeTrailingPathDelimiter(ANewDir);
  if SameText(NewBase, FBaseDir) then
    Exit;
  for E in FItems do
  begin
    // AbsolutePath usa ancora la vecchia base: e' il punto della manovra.
    Full := AbsolutePath(E.FileName);
    if Full = '' then
      Continue;
    if Full.StartsWith(NewBase, True) then
      E.FileName := Copy(Full, Length(NewBase) + 1, MaxInt)
    else
      E.FileName := Full;
  end;
  FBaseDir := NewBase;
end;

procedure TImageLibrary.FillNames(AStrings: TStrings; AIncludeEmpty: Boolean);
var
  E: TImageEntry;
begin
  AStrings.BeginUpdate;
  try
    AStrings.Clear;
    if AIncludeEmpty then
      AStrings.Add('');
    for E in FItems do
      AStrings.Add(E.Name);
  finally
    AStrings.EndUpdate;
  end;
end;

end.