unit mainUnit;

interface

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

type
  TForm1 = class(TForm)
    SavePictureDialog1: TSavePictureDialog;
    OpenPictureDialog1: TOpenPictureDialog;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    ToolBar1: TToolBar;
    OpenBtn: TToolButton;
    SaveBtn: TToolButton;
    Panel2: TPanel;
    ProgressBar1: TProgressBar;
    ImageList1: TImageList;
    procedure SavePictureDialog1TypeChange(Sender: TObject);
    procedure Image1Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
      const Msg: string);
    procedure SavePictureDialog1Close(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure OpenBitBtnClick(Sender: TObject);
    procedure SaveBitBtnClick(Sender: TObject);
    procedure ToolBar1Resize(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
uses jpeg;
const DeltaH: Integer = 80;
var Quality: TJpegQualityRange;
  ProgressiveEnc: Boolean;

procedure TForm1.FormCreate(Sender: TObject);
var s: string;
begin
  s := GraphicFilter(TBitmap) + '|' + GraphicFilter(TJpegImage);
  OpenPictureDialog1.Filter := s;
  SavePictureDialog1.Filter := s;
end;

procedure TForm1.OpenBitBtnClick(Sender: TObject);
begin
  if OpenPictureDialog1.Execute
    then
  begin
    Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName);
    SaveBtn.Enabled := True;
  end;
end;

procedure TForm1.SaveBitBtnClick(Sender: TObject);
var ji: TJpegImage;
begin
  with SavePictureDialog1 do
  begin
    FilterIndex := 1;
    FileName := '';
    if not Execute then Exit;

    if Pos('.', FileName) = 0 then
      if (FilterIndex = 1) then
        FileName := FileName + '.bmp'
      else
        FileName := FileName + '.jpg';

    if (FilterIndex = 1) then
      Image1.Picture.Bitmap.SaveToFile(FileName)
    else
    begin
      ji := TJpegImage.Create;
      ji.CompressionQuality := Quality;
      ji.ProgressiveEncoding := ProgressiveEnc;
      ji.OnProgress := Image1Progress;
      ji.Assign(Image1.Picture.Bitmap);
      ji.SaveToFile(FileName);
      ji.Free;
    end;
  end;

end;

procedure TForm1.SavePictureDialog1TypeChange(Sender: TObject);
var ParentHandle: THandle; wRect: TRect;
  PicPanel, PaintPanel: TPanel; QEdit: TEdit;
begin
  with Sender as TSavePictureDialog do
  begin
//родительская панель
    PicPanel := (FindComponent('PicturePanel') as TPanel);
    if not Assigned(PicPanel) then Exit;
    ParentHandle := GetParent(Handle);

//панель-сосед сверху
    PaintPanel := (FindComponent('PaintPanel') as TPanel);
    PaintPanel.Align := alNone;
    if FilterIndex > 1 then
    begin
      GetWindowRect(ParentHandle, WRect);
      SetWindowPos(ParentHandle, 0, 0, 0, WRect.Right - WRect.Left,
        WRect.Bottom - WRect.Top + DeltaH, SWP_NOMOVE + SWP_NOZORDER);
      GetWindowRect(Handle, WRect);
      SetWindowPos(handle, 0, 0, 0, WRect.Right - WRect.Left,
        WRect.Bottom - WRect.Top + DeltaH, SWP_NOMOVE + SWP_NOZORDER);
      PicPanel.Height := PicPanel.Height + DeltaH;

      if FindComponent('JLabel') = nil then
        with TLabel.Create(Sender as TSavePictureDialog) do
        begin
          Parent := PicPanel;
          Name := 'JLabel';
          Caption := 'Quality';
          Left := 5; //Width := PicPanel.Width - 10;
          Height := 25;
          Top := PaintPanel.Top + PaintPanel.Height + 5;
        end;

      if FindComponent('JEdit') = nil then
      begin
        QEdit := TEdit.Create(Sender as TSavePictureDialog);
        with QEdit do
        begin
          Parent := PicPanel;
          Name := 'JEdit';
          Text := '75';
          Left := 50; Width := 50;
          Height := 25;
          Top := PaintPanel.Top + PaintPanel.Height + 5;
        end;
      end;

      if FindComponent('JUpDown') = nil then
        with TUpDown.Create(Sender as TSavePictureDialog) do
        begin
          Parent := PicPanel;
          Name := 'JUpDown';
          Associate := QEdit;
          Increment := 5;
          Min := 1; Max := 100;
          Position := 75;
        end;

      if FindComponent('JCheck') = nil then
        with TCheckBox.Create(Sender as TSavePictureDialog) do
        begin
          Name := 'JCheck';
          Caption := 'Progressive Encoding';
          Parent := PicPanel;
          Left := 5; Width := PicPanel.Width - 10;
          Height := 25;
          Top := PaintPanel.Top + PaintPanel.Height + 35;
        end;
    end
    else
      SavePictureDialog1Close(Sender);
  end;
end;

procedure TForm1.Image1Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
  const Msg: string);
begin
  case Stage of
    psStarting: begin
        Progressbar1.Position := 0;
        Progressbar1.Max := 100;
      end;
    psEnding: begin
        Progressbar1.Position := 0;
      end;
    psRunning: begin
        Progressbar1.Position := PercentDone;
      end;
  end;
end;

procedure TForm1.SavePictureDialog1Close(Sender: TObject);
var PicPanel: TPanel; ParentHandle: THandle; WRect: TRect;
begin

  with Sender as TSavePictureDialog do
  begin
    PicPanel := (FindComponent('PicturePanel') as TPanel);
    if not Assigned(PicPanel) then Exit;
    ParentHandle := GetParent(Handle);
    if ParentHandle = 0 then Exit;
    if FindComponent('JLabel') <> nil then
    try
      FindComponent('JLabel').Free;
      FindComponent('JEdit').Free;
      ProgressiveEnc := (FindComponent('JCheck') as TCheckBox).Checked;
      FindComponent('JCheck').Free;
      Quality := (FindComponent('JUpDown') as TUpDown).Position;
      FindComponent('JUpDown').Free;

      PicPanel.Height := PicPanel.Height - DeltaH;
      GetWindowRect(Handle, WRect);
      SetWindowPos(Handle, 0, 0, 0, WRect.Right - WRect.Left,
        WRect.Bottom - WRect.Top - DeltaH, SWP_NOMOVE + SWP_NOZORDER);
      GetWindowRect(ParentHandle, WRect);
      SetWindowPos(ParentHandle, 0, 0, 0, WRect.Right - WRect.Left,
        WRect.Bottom - WRect.Top - DeltaH, SWP_NOMOVE + SWP_NOZORDER);
      FilterIndex := 1;
    except
      ShowMessage('Dialog resizing error');
    end;
  end;
end;

procedure TForm1.ToolBar1Resize(Sender: TObject);
begin
  Panel2.Width := ToolBar1.Width - Panel2.Left;
end;

end.

Скачать весь проект