home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / INFO / EXTRAS / FIF / TEST / UNIT1.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1997-03-13  |  5.1 KB  |  197 lines
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ExtCtrls, Menus, fif, fifdlls, ComCtrls;
  8.  
  9. type
  10.   TImgViewForm = class(TForm)
  11.     MainMenu1: TMainMenu;
  12.     OpenDialog1: TOpenDialog;
  13.     Colors1: TMenuItem;
  14.     N8bitcolor1: TMenuItem;
  15.     N8bitgrayscale1: TMenuItem;
  16.     N15bitcolor1: TMenuItem;
  17.     N24bitcolor1: TMenuItem;
  18.     ScrollBox1: TScrollBox;
  19.     Image1: TImage;
  20.     StatusBar1: TStatusBar;
  21.     procedure Exit1Click(Sender: TObject);
  22.     procedure FormCreate(Sender: TObject);
  23.     procedure Open1Click(Sender: TObject);
  24.     procedure Colors1Click(Sender: TObject);
  25.     procedure ChangeColorFormat(Sender: TObject);
  26.     procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
  27.       Shift: TShiftState; X, Y: Integer);
  28.   protected
  29.     Filename: string;
  30.     Zoom: Integer;
  31.   public
  32.     procedure UpdateCaption;
  33.     procedure FitToWindow;
  34.     procedure Rescale;
  35.     procedure UpdateProgressBar(Sender: TObject; Action: TProgressAction;
  36.       PercentComplete: Longint);
  37.   end;
  38.  
  39. var
  40.   ImgViewForm: TImgViewForm;
  41.  
  42. implementation
  43.  
  44. {$R *.DFM}
  45.  
  46. procedure TImgViewForm.Exit1Click(Sender: TObject);
  47. begin
  48.   Close;
  49. end;
  50.  
  51. procedure TImgViewForm.FormCreate(Sender: TObject);
  52. begin
  53.   OpenDialog1.Filter := GraphicFilter(TGraphic);
  54.   Colors1.Enabled := Image1.Picture.Graphic is TFIFImage;
  55.   Caption := Application.Title;
  56.   if not LoadFIFDecodeLibrary(FIFDecodeDLLName, False) then
  57.     Application.MessageBox('Can''t find '+FIFDecodeDLLName+
  58.       '.  You will not be able to view FIF images until the '+
  59.       'Iterated Systems FIF decoder DLL is installed.  '+
  60.       'To install the decoder DLL, run extras\fif\FD12W32.EXE '+
  61.       'found on the Delphi CDRom.', 'FIF Not Installed', mb_OK);
  62. end;
  63.  
  64. procedure TImgViewForm.UpdateCaption;
  65. var
  66.   ZoomTop, ZoomBottom: Integer;
  67. begin
  68.   if Length(Filename) = 0 then
  69.     Caption := Application.Title
  70.   else
  71.   begin
  72.     ZoomTop := 1;
  73.     ZoomBottom := 1;
  74.     if Zoom < 0 then
  75.       ZoomBottom := Abs(Zoom)+1
  76.     else if Zoom > 0 then
  77.       ZoomTop := Zoom+1;
  78.     Caption := Format('%s - %s (%d:%d)',[Application.Title, Filename, ZoomTop,
  79.       ZoomBottom]);
  80.   end;
  81. end;
  82.  
  83. procedure TImgViewForm.Open1Click(Sender: TObject);
  84. begin
  85.   if OpenDialog1.Execute then
  86.   begin
  87.     Image1.Autosize := True;
  88.     Image1.Picture.LoadFromFile(OpenDialog1.Filename);
  89.     Colors1.Enabled := Image1.Picture.Graphic is TFIFImage;
  90.     if Image1.Picture.Graphic is TFIFImage then
  91.       TFIFImage(Image1.Picture.Graphic).OnLoading := UpdateProgressBar;
  92.     Filename := OpenDialog1.Filename;
  93.     FitToWindow;
  94.     UpdateCaption;
  95.   end;
  96. end;
  97.  
  98. procedure TImgViewForm.Colors1Click(Sender: TObject);
  99. begin
  100.   with Image1.Picture.Graphic as TFIFImage do
  101.   case ColorFormat of
  102.     RGB8 : N8bitcolor1.Checked := True;
  103.     RGB15: N15bitcolor1.Checked := True;
  104.     RGB24: N24bitcolor1.Checked := True;
  105.     GRAYSCALE8: N8bitgrayscale1.Checked := True;
  106.   end;
  107. end;
  108.  
  109. procedure TImgViewForm.ChangeColorFormat(Sender: TObject);
  110. begin
  111.   (Image1.Picture.Graphic as TFIFImage).ColorFormat :=
  112.     TColorFormat((Sender as TComponent).Tag);
  113. end;
  114.  
  115. procedure TImgViewForm.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  116.   Shift: TShiftState; X, Y: Integer);
  117. begin
  118.   case Button of
  119.     mbLeft:   Inc(Zoom);
  120.     mbRight:  Dec(Zoom);
  121.   end;
  122.   Rescale;
  123.   UpdateCaption;
  124. end;
  125.  
  126. procedure TImgViewForm.Rescale;
  127. var
  128.   Multiplier: Double;
  129. begin
  130.   if Zoom > 0 then
  131.     Multiplier := Zoom + 1
  132.   else if Zoom < 0 then
  133.     Multiplier := 1 / (Abs(Zoom) + 1)
  134.   else
  135.     Multiplier := 1;
  136.   with Image1.Picture do
  137.     if Graphic is TFIFImage then
  138.     begin
  139.       Image1.Autosize := True;
  140.       Image1.Stretch := False;
  141.       Graphic.Width := Trunc(TFIFImage(Graphic).OriginalWidth * Multiplier);
  142.       Graphic.Height := Trunc(TFIFImage(Graphic).OriginalHeight * Multiplier);
  143.     end
  144.     else
  145.     begin
  146.       Image1.AutoSize := Zoom = 0;
  147.       Image1.Stretch := Zoom <> 0;
  148.       if Zoom <> 0 then
  149.       begin
  150.         Image1.Width := Trunc(Graphic.Width * Multiplier);
  151.         Image1.Height := Trunc(Graphic.Height * Multiplier);
  152.       end;
  153.     end;
  154. end;
  155.  
  156. procedure TImgViewForm.FitToWindow;
  157. begin
  158.   Zoom := 0;
  159.   Scrollbox1.Visible := False;
  160.   try
  161.     Rescale;
  162.     if Image1.Width > Scrollbox1.Width then
  163.     begin
  164.       Zoom := -Trunc((Image1.Width / Scrollbox1.Width) + 0.5);
  165.       Rescale;
  166.     end;
  167.     if Image1.Height > Scrollbox1.Height then
  168.     begin
  169.       Zoom := Zoom - Trunc((Image1.Height / ScrollBox1.Height) + 0.5);
  170.       Rescale;
  171.     end;
  172.   finally
  173.     Scrollbox1.Visible := True;
  174.   end;
  175. end;
  176.  
  177. procedure TImgViewForm.UpdateProgressBar(Sender: TObject; Action: TProgressAction;
  178.       PercentComplete: Longint);
  179. begin
  180.   case Action of
  181.     paStart: Screen.Cursor := crHourGlass;
  182.     paRunning:
  183.       begin
  184.         StatusBar1.SimpleText :=
  185.           Format('Decompressing: %d%% complete.', [PercentComplete]);
  186.         StatusBar1.Update;
  187.       end;
  188.     paEnd:
  189.       begin
  190.         Screen.Cursor := crDefault;
  191.         StatusBar1.SimpleText := '';
  192.       end;
  193.   end;
  194. end;
  195.  
  196. end.
  197.