Проект из папки Lazarus/examples - просмотр картинок .bmp,.jpg,.png и др. (без .gif)

---

Главная форма программы.

Исходный проект (Mattias Gaertner) содержится в папке Lazarus/examples (папка jpeg). Здесь представлена немного переработанная версия.
Программа просматривает графические файлы стандартных форматов (*.bmp;*.xpm;*.png;*.pbm;*.pgm;*.ppm;*.ico;*.icns; '*.cur;*.jpg;*.jpeg;*.jpe;*.jfif) (но не gif) а также сохранять картинки, преобразуя в формат jpeg.

При просмотре возможно масштабирование.

Текст главного модуля

{ Copyright (C) 2004 Mattias Gaertner

  Example for loading and saving jpeg images.
  . . . .
}

{Winni, 03.2010 - незначительные, но полезные :-) добавки
1. Добавил  FName := ExtractFileName(Filename); - укоротил имя файла
2. Вместо кнопок - меню и убрал GroupBox
3. Встроил включение/выключение св-в TImage: Stretch, Proportional 
4. Image1.BorderSpacing.Around -> 20 // Лучше смотрится
5. Проект сделал заново, руководствуясь только .pas-текстом главного 
модуля. Теперь он не показывает консольное окно, которое почему-то
было в исходном проекте.  
}

unit unmain1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,{ FileUtil,} LResources, Forms, Controls, Graphics, Dialogs,
  { StdCtrls,} ExtCtrls, ExtDlgs, Menus;

type

  { TfrmMain2 }

  TfrmMain2 = class(TForm)
    Image1: TImage;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    proporcia: TMenuItem;
    multi: TMenuItem;
    PicName: TMenuItem;
    SaveAsJPEG: TMenuItem;
    SavePicture: TMenuItem;
    quit: TMenuItem;
    OpJPEG: TMenuItem;
    OpPicture: TMenuItem;
    OPD1: TOpenPictureDialog;
    SPD1: TSavePictureDialog;
    procedure multiClick(Sender: TObject);
    procedure OpJPEGClick(Sender: TObject);
    procedure OpPictureClick(Sender: TObject);
    procedure proporciaClick(Sender: TObject);
    procedure quitClick(Sender: TObject);
    procedure SaveAsJPEGClick(Sender: TObject);
    procedure SavePictureClick(Sender: TObject);
  private
    { private declarations }
    procedure UpdateInfo(const Filename: string);
    procedure Open1;
  public
    { public declarations }
  end; 

var
  frmMain2: TfrmMain2;

implementation

{ TfrmMain2 }

procedure TfrmMain2.Open1;
begin
  OPD1.Options:=OPD1.Options+[ofFileMustExist];
  OPD1.Filter:=
'Graphic (*.bmp;*.xpm;*.png;*.pbm;*.pgm;*.ppm;*.ico;*.icns;*.cur;*.jpg;'+
'*.jpeg;*.jpe;*.jfif)|*.bmp;*.xpm;*.png;*.pbm;*.pgm;*.ppm;*.ico;*.icns;'+
'*.cur;*.jpg;*.jpeg;*.jpe;*.jfif|Bitmaps (*.bmp)|*.bmp|'+
'Pixmap (*.xpm)|*.xpm|Portable Network Graphic (*.png)|*.png|'+
'Portable PixMap (*.pbm;*.pgm;*.ppm)|*.pbm;*.pgm;*.ppm|Icon (*.ico)|'+
'*.ico|OSX Icon Resource (*.icns)|*.icns|Cursor (*.cur)|*.cur|'+
'Joint Picture Expert Group (*.jpg;*.jpeg;*.jpe;*.jfif)|'+
'*.jpg;*.jpeg;*.jpe;*.jfif|Все файлы (*.*)|*.*|';
end;

procedure TfrmMain2.OpPictureClick(Sender: TObject);
begin
  OPen1;

  if not OPD1.Execute then exit;
  try
    // Загружаем прямо в TImage. Тогда можно  грузить любой регистрированный
    // формат прямо в TImage: .bmp, .xpm, .png - стандартные LCL форматы
    // Модуль jpeg регистрирует .jpeg и .jpg.
    Image1.Picture.LoadFromFile(OPD1.Filename);

    UpdateInfo(OPD1.Filename);
  except
    on E: Exception do begin
      MessageDlg('Ошибка','Ошибка: '+E.Message,mtError,[mbOk],0);
    end;
  end;
end;

procedure TfrmMain2.proporciaClick(Sender: TObject);
begin
  Image1.Proportional:= not Image1.Proportional;
  if Image1.Proportional then
    proporcia.Caption:= 'Proportional (On) ' else
    proporcia.Caption:= 'Proportional (Off)';
end;

procedure TfrmMain2.quitClick(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TfrmMain2.SaveAsJPEGClick(Sender: TObject);
var
  JPEG: TJPEGImage;
begin
  if Image1.Picture.Graphic=nil then begin
    MessageDlg('Нет картинки','Откройте картинку прежде сохранения',mtError,
      [mbOk],0);
    exit;
  end;

  SPD1.Options:=SPD1.Options+[ofPathMustExist];
  if not SPD1.Execute then exit;
  try
    // Создаем JPEG и копируем картинку Image1.Picture.Graphic в него.
    // Затем JPEG сохраняет картинку в файле. Расширение игнорируется,
    // всегда сохраняет .jpeg

    JPEG:=TJPEGImage.Create;
    try
      // копируем картинку Image1.Picture.Graphic в JPEG
      JPEG.Assign(Image1.Picture.Graphic);
      // JPEG сохраняет картинку
      JPEG.SaveToFile(SPD1.Filename);
    finally
      JPEG.Free;
    end;

  UpdateInfo(SPD1.Filename);
  except
    on E: Exception do begin
      MessageDlg('Ошибка','Ошибка: '+E.Message,mtError,[mbOk],0);
    end;
  end;
end;

procedure TfrmMain2.SavePictureClick(Sender: TObject);
begin
  // если нет картинки Image1.Picture.Graphic
  if Image1.Picture.Graphic=nil then begin
    MessageDlg('Нет картинки','Откройте картинку прежде сохранения',mtError,
      [mbOk],0);
    exit;
  end;

  SPD1.Options:=SPD1.Options+[ofPathMustExist];
  if not SPD1.Execute then exit;
  try
    // Сохраняем прямо из TImage в файл. При этом сохранится любой
    // зарегистрированный формат. .bmp, .xpm, .png - стандартные LCL форматы
    // и .jpeg и .jpg.

    Image1.Picture.SaveToFile(SPD1.Filename);

    UpdateInfo(SPD1.Filename);
  except
    on E: Exception do begin
      MessageDlg('Ошибка','Ошибка: '+E.Message,mtError,[mbOk],0);
    end;
  end;
end;

procedure TfrmMain2.OpJPEGClick(Sender: TObject);
var
  JPEG: TJPEGImage;
begin
  OPD1.Options:=OPD1.Options+[ofFileMustExist];
  OPD1.Filter:='JPEG|*.jpg;*.jpeg;*.jpe;*.jfif|';
  if not OPD1.Execute then exit;
  try
    // Создаем TJPEGImage и загужаем файл, затем копируем в TImage.
    // TJPEGImage может загружать только jpeg - картинки.

    JPEG:=TJPEGImage.Create;
    try
      JPEG.LoadFromFile(OPD1.Filename);
      // копируем jpeg - content to a TImage
      Image1.Picture.Assign(JPEG);
      // похоже JPEG.GrayScale - readonly.
    finally
      JPEG.Free;
    end;

   UpdateInfo(OPD1.Filename);
  except
    on E: Exception do begin
      MessageDlg('Ошибка','Ошибка: '+E.Message,mtError,[mbOk],0);
    end;
  end;
end;

procedure TfrmMain2.multiClick(Sender: TObject);
begin
  Image1.Stretch:= not Image1.Stretch;
  if Image1.Stretch then
    multi.Caption:= 'Stretch (On) ' else
    multi.Caption:= 'Stretch (Off)';
end;

procedure TfrmMain2.UpdateInfo(const Filename: string);
var
  Info,Fname: String;
begin

  FName := ExtractFileName(Filename);
  if Image1.Picture.Graphic<>nil then begin
    Info:=Image1.Picture.Graphic.ClassName+':'+Fname;
  end else begin
    Info:=Fname;
  end;
  PicName.Caption:='  '+Info;
end;

initialization
  {$I unmain1.lrs}

end.

Скачать RAR-архив исходников + .exe (Pictures_Full.rar - 460 Кб)

Распакуйте архив в папку и откройте jpeg2.lpi - для работы с проектом
Проект должен открыться (если установлен Лазарус).
Или запустите jpeg2.exe (если потребует что-нибудь, сообщите, пожалуйста )