home *** CD-ROM | disk | FTP | other *** search
/ PC World Plus! (NZ) 2001 June / HDC50.iso / Info / Extras / Jpeg / TEST / TEST1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  4.8 KB  |  179 lines
  1. unit test1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, jpeg, ExtCtrls, FileCtrl, ComCtrls, Menus, printers;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     Panel1: TPanel;
  12.     DirectoryListBox1: TDirectoryListBox;
  13.     FileListBox1: TFileListBox;
  14.     Panel3: TPanel;
  15.     DriveComboBox1: TDriveComboBox;
  16.     Scale: TComboBox;
  17.     PixelFormat: TComboBox;
  18.     ColorSpace: TComboBox;
  19.     Performance: TComboBox;
  20.     ProgressiveDisplay: TCheckBox;
  21.     IncrementalDisplay: TCheckBox;
  22.     MainMenu1: TMainMenu;
  23.     File1: TMenuItem;
  24.     Open1: TMenuItem;
  25.     N1: TMenuItem;
  26.     Print1: TMenuItem;
  27.     PrinterSetup1: TMenuItem;
  28.     N2: TMenuItem;
  29.     Exit1: TMenuItem;
  30.     OpenDialog1: TOpenDialog;
  31.     PrinterSetupDialog1: TPrinterSetupDialog;
  32.     PrintDialog1: TPrintDialog;
  33.     ScrollBox1: TScrollBox;
  34.     Image1: TImage;
  35.     procedure FileListBox1DblClick(Sender: TObject);
  36.     procedure SetJPEGOptions(Sender: TObject);
  37.     procedure FormCreate(Sender: TObject);
  38.     procedure ProgressUpdate(Sender: TObject; Stage: TProgressStage;
  39.       PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  40.     procedure Open1Click(Sender: TObject);
  41.     procedure Print1Click(Sender: TObject);
  42.     procedure PrinterSetup1Click(Sender: TObject);
  43.     procedure Exit1Click(Sender: TObject);
  44.   private
  45.     { Private declarations }
  46.   public
  47.     { Public declarations }
  48.     procedure OpenFile(const Filename: string);
  49.   end;
  50.  
  51. var
  52.   Form1: TForm1;
  53.  
  54. implementation
  55.  
  56. {$R *.DFM}
  57.  
  58. procedure TForm1.OpenFile(const Filename: string);
  59. begin
  60.   try
  61.     Image1.Picture.LoadFromFile(Filename);
  62.   except
  63.     on EInvalidGraphic do
  64.       Image1.Picture.Graphic := nil;
  65.   end;
  66.   SetJPEGOptions(self);
  67. end;
  68.  
  69. procedure TForm1.FileListBox1DblClick(Sender: TObject);
  70. begin
  71.   OpenFile(FileListbox1.Filename);
  72. end;
  73.  
  74. procedure TForm1.SetJPEGOptions(Sender: TObject);
  75. var
  76.   Temp: Boolean;
  77. begin
  78.   Temp := Image1.Picture.Graphic is TJPEGImage;
  79.   if Temp then
  80.     with TJPEGImage(Image1.Picture.Graphic) do
  81.     begin
  82.       PixelFormat := TJPEGPixelFormat(Self.PixelFormat.ItemIndex);
  83.       Scale := TJPEGScale(Self.Scale.ItemIndex);
  84.       Grayscale := Boolean(Colorspace.ItemIndex);
  85.       Performance := TJPEGPerformance(Self.Performance.ItemIndex);
  86.       ProgressiveDisplay := Self.ProgressiveDisplay.Checked;
  87.     end;
  88.   Scale.Enabled := Temp;
  89.   PixelFormat.Enabled := Temp;
  90.   Colorspace.Enabled := Temp;
  91.   Performance.Enabled := Temp;
  92.   ProgressiveDisplay.Enabled := Temp
  93.     and TJPEGImage(Image1.Picture.Graphic).ProgressiveEncoding;
  94.   Image1.IncrementalDisplay := IncrementalDisplay.Checked;
  95. end;
  96.  
  97. procedure TForm1.FormCreate(Sender: TObject);
  98. begin
  99.   Scale.ItemIndex := 0;
  100.   PixelFormat.ItemIndex := 0;
  101.   Colorspace.ItemIndex := 0;
  102.   Performance.ItemIndex := 0;
  103.   OpenDialog1.Filter := GraphicFilter(TGraphic);
  104.   FileListbox1.Mask := GraphicFileMask(TGraphic);
  105.   Image1.OnProgress := ProgressUpdate;
  106. end;
  107.  
  108. procedure TForm1.ProgressUpdate(Sender: TObject; Stage: TProgressStage;
  109.   PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
  110. begin
  111.   if Stage = psRunning then
  112.     Caption := Format('%d%%',[PercentDone])
  113.   else
  114.     Caption := 'Form1';
  115. end;
  116.  
  117.  
  118. procedure TForm1.Open1Click(Sender: TObject);
  119. begin
  120.   if OpenDialog1.Execute then
  121.     OpenFile(OpenDialog1.FileName);
  122. end;
  123.  
  124. procedure TForm1.Print1Click(Sender: TObject);
  125. var
  126.   AspectRatio: Single;
  127.   OutputWidth, OutputHeight: Single;
  128. begin
  129.   if not PrintDialog1.Execute then Exit;
  130.   Printer.BeginDoc;
  131.   try
  132.     OutputWidth := Image1.Picture.Width;
  133.     OutputHeight := Image1.Picture.Height;
  134.     AspectRatio := OutputWidth / OutputHeight;
  135.     if (OutputWidth < Printer.PageWidth) and
  136.       (OutputHeight < Printer.PageHeight) then
  137.     begin
  138.       if OutputWidth < OutputHeight then
  139.       begin
  140.         OutputHeight := Printer.PageHeight;
  141.         OutputWidth := OutputHeight * AspectRatio;
  142.       end
  143.       else
  144.       begin
  145.         OutputWidth := Printer.PageWidth;
  146.         OutputHeight := OutputWidth / AspectRatio;
  147.       end
  148.     end;
  149.     if OutputWidth > Printer.PageWidth then
  150.     begin
  151.       OutputWidth := Printer.PageWidth;
  152.       OutputHeight := OutputWidth / AspectRatio;
  153.     end;
  154.     if OutputHeight > Printer.PageHeight then
  155.     begin
  156.       OutputHeight := Printer.PageHeight;
  157.       OutputWidth := OutputHeight * AspectRatio;
  158.     end;
  159.     Printer.Canvas.StretchDraw(Rect(0,0,
  160.       Integer(Trunc(OutputWidth)), Integer(Trunc(OutputHeight))),
  161.       Image1.Picture.Graphic);
  162.   finally
  163.     Printer.EndDoc;
  164.   end;
  165. end;
  166.  
  167. procedure TForm1.PrinterSetup1Click(Sender: TObject);
  168. begin
  169.   PrinterSetupDialog1.Execute;
  170. end;
  171.  
  172. procedure TForm1.Exit1Click(Sender: TObject);
  173. begin
  174.   Close;
  175. end;
  176.  
  177. end.
  178.  
  179.