fsave.pas

很好的源代码

unit FSave;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, FDualImage, ExtCtrls, ComCtrls, EvBGraphics;

type
  TFrmSave = class(TForm)
    PnlTop: TPanel;
    PnlBottom: TPanel;
    FrameDualImage: TFrameDualImage;
    LblFormat: TLabel;
    CBFormat: TComboBox;
    LblQuality: TLabel;
    EditQuality: TEdit;
    UDQuality: TUpDown;
    TBQuality: TTrackBar;
    Timer: TTimer;
    BtnSave: TButton;
    BtnCancel: TButton;
    Bevel: TBevel;
    SaveDialog: TSaveDialog;
    procedure FormCreate(Sender: TObject);
    procedure PnlTopResize(Sender: TObject);
    procedure EditQualityChange(Sender: TObject);
    procedure TBQualityChange(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CBFormatChange(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure BtnSaveClick(Sender: TObject);
  private
    { Private declarations }
    FFormat: TEvBBitmapFileFormatInfo;
    FSrcBitmap, FDstBitmap: TEvBBitmap;
    FStream: TStream;
    procedure Preview;
  public
    { Public declarations }
    procedure Initialize(const Bitmap: TBitmap);
  end;

procedure SaveFileDialog(const Bitmap: TBitmap);

implementation

{$R *.dfm}

procedure SaveFileDialog(const Bitmap: TBitmap);
var
  F: TFrmSave;
begin
  F := TFrmSave.Create(Application);
  try
    F.Initialize(Bitmap);
    F.ShowModal;
  finally
    F.Release;
  end;
end;

{ TFrmSave }

procedure TFrmSave.FormCreate(Sender: TObject);
var
  I, J: Integer;
  Info: TEvBBitmapFileFormatInfo;
begin
  FSrcBitmap := TEvBBitmap.Create;
  FDstBitmap := TEvBBitmap.Create;
  FStream := TMemoryStream.Create;
  J := -1;
  for I := 0 to TEvBBitmap.RegisteredFileFormatCount - 1 do begin
    Info := TEvBBitmap.GetRegisteredFileFormat(I);
    CBFormat.Items.AddObject(Info.Description,Info);
    if Info.Extension = '.aic' then begin
      J := I;
      FFormat := Info;
    end;
  end;
  CBFormat.ItemIndex := J;
  EditQuality.Width := CBFormat.Width - UDQuality.Width - 2;
end;

procedure TFrmSave.FormDestroy(Sender: TObject);
begin
  FSrcBitmap.Free;
  FDstBitmap.Free;
  FStream.Free;
end;

procedure TFrmSave.PnlTopResize(Sender: TObject);
begin
  TBQuality.Width := PnlTop.Width - TBQuality.Left - 4;
end;

procedure TFrmSave.EditQualityChange(Sender: TObject);
begin
  TBQuality.Position := UDQuality.Position;
end;

procedure TFrmSave.TBQualityChange(Sender: TObject);
begin
  UDQuality.Position := TBQuality.Position;
  Timer.Enabled := False;
  Timer.Interval := 500;
  Timer.Enabled := True;
end;

procedure TFrmSave.CBFormatChange(Sender: TObject);
begin
  if CBFormat.ItemIndex >= 0 then begin
    FFormat := CBFormat.Items.Objects[CBFormat.ItemIndex] as TEvBBitmapFileFormatInfo;
    LblQuality.Enabled := FFormat.SupportsQualityLevels;
    EditQuality.Enabled := FFormat.SupportsQualityLevels;
    UDQuality.Enabled := FFormat.SupportsQualityLevels;
    TBQuality.Enabled := FFormat.SupportsQualityLevels;
    Preview;
  end else
    FFormat := nil;
end;

procedure TFrmSave.Initialize(const Bitmap: TBitmap);
begin
  FrameDualImage.SetOriginal(Bitmap);
  FSrcBitmap.Assign(Bitmap);
  FStream.Size := Bitmap.Width * Bitmap.Height * 3;
  Preview;
end;

procedure TFrmSave.Preview;
var
  CompressedSize: Integer;
begin
  if Assigned(FFormat) then begin
    Screen.Cursor := crHourGlass;
    try
      FStream.Position := 0;
      FSrcBitmap.Quality := TBQuality.Position;
      FSrcBitmap.SaveToStream(FStream,FFormat.Extension);
      CompressedSize := FStream.Position;

      FStream.Position := 0;
      FDstBitmap.LoadFromStream(FStream);
      FrameDualImage.SetCompressed(FDstBitmap,FFormat.Description,
        TBQuality.Position,CompressedSize);
    finally
      Screen.Cursor := crDefault;
    end;
  end;
end;

procedure TFrmSave.TimerTimer(Sender: TObject);
begin
  Timer.Enabled := False;
  Preview;
end;

procedure TFrmSave.BtnSaveClick(Sender: TObject);
begin
  if Assigned(FFormat) then begin
    SaveDialog.DefaultExt := Copy(FFormat.Extension,2,MaxInt);
    SaveDialog.Filter := Format('%s (*%s)|*%1:s',
      [FFormat.Description,FFormat.Extension]);
    if SaveDialog.Execute then begin
      Screen.Cursor := crHourglass;
      try
        FSrcBitmap.Quality := TBQuality.Position;
        FSrcBitmap.SaveToFile(SaveDialog.FileName);
      finally
        Screen.Cursor := crDefault;
      end;
      Close;
    end;
  end;
end;

end.