home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / IMAGPRVW.PAS < prev    next >
Pascal/Delphi Source File  |  1999-10-12  |  8KB  |  292 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Delphi VCL Extensions (RX)                      }
  4. {                                                       }
  5. {       Copyright (c) 1995 Borland International        }
  6. {       Copyright (c) 1997 Master-Bank                  }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ImagPrvw;
  11.  
  12. interface
  13.  
  14. {$I RX.INC}
  15.  
  16. uses SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  17.   Classes, Graphics, Forms, Controls, FileCtrl, StdCtrls, ExtCtrls, Buttons,
  18.   RxCtrls, PicClip, Placemnt, ObjStr;
  19.  
  20. type
  21.   TImageForm = class(TForm)
  22.     DirectoryList: TDirectoryListBox;
  23.     DriveCombo: TDriveComboBox;
  24.     PathLabel: TLabel;
  25.     FileEdit: TEdit;
  26.     ImagePanel: TPanel;
  27.     Image: TImage;
  28.     FileListBox: TFileListBox;
  29.     ImageName: TLabel;
  30.     FilterCombo: TFilterComboBox;
  31.     StretchCheck: TCheckBox;
  32.     FilePics: TPicClip;
  33.     FormStorage: TFormStorage;
  34.     OkBtn: TButton;
  35.     CancelBtn: TButton;
  36.     Label2: TLabel;
  37.     Label3: TLabel;
  38.     Label4: TLabel;
  39.     Label5: TLabel;
  40.     PreviewBtn: TRxSpeedButton;
  41.     procedure FileListBoxClick(Sender: TObject);
  42.     procedure StretchCheckClick(Sender: TObject);
  43.     procedure FormCreate(Sender: TObject);
  44.     procedure FileListBoxChange(Sender: TObject);
  45.     procedure FileListBoxDblClick(Sender: TObject);
  46.     procedure FormDestroy(Sender: TObject);
  47.     procedure PreviewBtnClick(Sender: TObject);
  48.     procedure OkBtnClick(Sender: TObject);
  49.   private
  50.     FormCaption: string;
  51.     FBmpImage: TBitmap;
  52.     procedure ZoomImage;
  53.     function GetFileName: string;
  54.     procedure SetFileName(const Value: string);
  55.     procedure PreviewKeyPress(Sender: TObject; var Key: Char);
  56.   public
  57.     property FileName: string read GetFileName write SetFileName;
  58.   end;
  59.  
  60. function SelectImage(var AFileName: string; const Extensions,
  61.   Filter: string): Boolean;
  62.  
  63. implementation
  64.  
  65. uses Consts, MaxMin, RxConst, VCLUtils, RxGraph;
  66.  
  67. {$R *.DFM}
  68.  
  69. {$I+}
  70. {$IFDEF WIN32}
  71.  {$D-}
  72. {$ENDIF}
  73.  
  74. const
  75.   SAllFiles = 'All files';
  76.   SPreview = 'Preview';
  77.  
  78. function SelectImage(var AFileName: string; const Extensions,
  79.   Filter: string): Boolean;
  80. var
  81.   ErrMode: Cardinal;
  82. begin
  83.   with TImageForm.Create(Application) do
  84.   try
  85.     FileListBox.Mask := Extensions;
  86.     FilterCombo.Filter := Filter;
  87.     if Pos('*.*', Filter) = 0 then begin
  88.       if Length(Filter) > 0 then FilterCombo.Filter := Filter + '|';
  89.       FilterCombo.Filter := FilterCombo.Filter + SAllFiles + ' (*.*)|*.*';
  90.     end;
  91.     ErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS);
  92.     try
  93.       if AFileName <> '' then FileName := AFileName;
  94.       Result := ShowModal = mrOk;
  95.     finally
  96.       SetErrorMode(ErrMode);
  97.     end;
  98.     if Result then AFileName := FileName;
  99.   finally
  100.     Free;
  101.   end;
  102. end;
  103.  
  104. type
  105.   TDirList = class(TDirectoryListBox);
  106.   TFileList = class(TFileListBox);
  107.   TDriveCombo = class(TDriveComboBox);
  108.  
  109. function ValidPicture(Pict: TPicture): Boolean;
  110. begin
  111.   Result := (Pict.Graphic <> nil) and not (Pict.Graphic.Empty) and
  112.     (Pict.Width > 0) and (Pict.Height > 0);
  113. end;
  114.  
  115. { TImageForm }
  116.  
  117. function TImageForm.GetFileName: string;
  118. begin
  119.   Result := FileListBox.FileName;
  120. end;
  121.  
  122. procedure TImageForm.SetFileName(const Value: string);
  123. begin
  124.   FileListBox.FileName := Value;
  125. end;
  126.  
  127. procedure TImageForm.ZoomImage;
  128. begin
  129.   if ValidPicture(Image.Picture) then begin
  130.     with RxGraph.ZoomImage(Image.Picture.Width, Image.Picture.Height,
  131.       ImagePanel.ClientWidth - 4, ImagePanel.ClientHeight - 4,
  132.       StretchCheck.Checked) do
  133.     begin
  134.       Image.Width := X;
  135.       Image.Height := Y;
  136.     end;
  137.     CenterControl(Image);
  138.   end;
  139. end;
  140.  
  141. procedure TImageForm.FileListBoxClick(Sender: TObject);
  142. var
  143.   FileExt: string;
  144. begin
  145.   FileExt := UpperCase(ExtractFileExt(FileListBox.Filename));
  146.   try
  147.     StartWait;
  148.     try
  149.       Image.Picture.LoadFromFile(FileListBox.Filename);
  150.     finally
  151.       StopWait;
  152.     end;
  153.     ImageName.Caption := Format('%s (%d x %d)',
  154.       [AnsiLowerCase(ExtractFilename(FileListBox.Filename)),
  155.       Image.Picture.Width, Image.Picture.Height]);
  156.   except
  157.     Image.Picture.Assign(nil);
  158.     ImageName.Caption := '';
  159.   end;
  160.   ZoomImage;
  161.   FileExt := AnsiLowerCase(FileName);
  162.   if FileExt <> '' then
  163.     Caption := FormCaption + ' - ' + MinimizeName(FileExt, PathLabel.Canvas,
  164.       PathLabel.Width)
  165.   else Caption := FormCaption;
  166.   PreviewBtn.Enabled := ValidPicture(Image.Picture);
  167. end;
  168.  
  169. procedure TImageForm.StretchCheckClick(Sender: TObject);
  170. begin
  171.   ZoomImage;
  172.   Image.Stretch := StretchCheck.Checked;
  173. end;
  174.  
  175. procedure TImageForm.FormCreate(Sender: TObject);
  176. begin
  177.   FormCaption := Caption;
  178.   Image.Align := alNone;
  179.   FBmpImage := TBitmap.Create;
  180.   FBmpImage.Assign(FilePics.GraphicCell[5]);
  181.   if not NewStyleControls then Font.Style := [fsBold];
  182. {$IFDEF WIN32}
  183.   with FormStorage do begin
  184.     UseRegistry := True;
  185.     IniFileName := SDelphiKey;
  186.   end;
  187. {$ENDIF}
  188.   with TDirList(DirectoryList) do begin
  189.     ClosedBmp.Assign(FilePics.GraphicCell[0]);
  190.     OpenedBmp.Assign(FilePics.GraphicCell[1]);
  191.     CurrentBmp.Assign(FilePics.GraphicCell[2]);
  192.   end;
  193.   with TFileList(FileListBox) do begin
  194.     DirBmp.Assign(FilePics.GraphicCell[0]);
  195.     ExeBmp.Assign(FilePics.GraphicCell[3]);
  196.     UnknownBmp.Assign(FilePics.GraphicCell[4]);
  197.   end;
  198.   with TDriveCombo(DriveCombo) do begin
  199.     FloppyBMP.Assign(FilePics.GraphicCell[6]);
  200.     FixedBMP.Assign(FilePics.GraphicCell[7]);
  201.     CDROMBMP.Assign(FilePics.GraphicCell[8]);
  202.     NetworkBMP.Assign(FilePics.GraphicCell[9]);
  203.     RAMBMP.Assign(FilePics.GraphicCell[10]);
  204.   end;
  205.   FileListBoxChange(nil);
  206.   TComboBox(FilterCombo).ItemHeight := Max(TComboBox(FilterCombo).ItemHeight,
  207.     FilePics.Height);
  208.   TComboBox(DriveCombo).ItemHeight := Max(TComboBox(FilterCombo).ItemHeight,
  209.     FilePics.Height);
  210.   TFileList(FileListBox).ItemHeight := Max(TFileList(FileListBox).ItemHeight,
  211.     FilePics.Height + 1);
  212.   TFileList(FileListBox).ItemHeight := Max(TFileList(FileListBox).ItemHeight,
  213.     FilePics.Height + 1);
  214.   DirectoryList.Height := FileListBox.Height;
  215. end;
  216.  
  217. procedure TImageForm.FileListBoxChange(Sender: TObject);
  218. var
  219.   I: Integer;
  220.   FileExt: string;
  221. begin
  222.   for I := 0 to TFileList(FileListBox).Items.Count - 1 do begin
  223.     FileExt := ExtractFileExt(TFileList(FileListBox).Items[I]);
  224.     if (TFileList(FileListBox).Items[I][1] <> '[') and
  225.       (CompareText(FileExt, '.bmp') = 0) then
  226.       TFileList(FileListBox).Items.Objects[I] := FBmpImage;
  227.   end;
  228. end;
  229.  
  230. procedure TImageForm.FileListBoxDblClick(Sender: TObject);
  231. begin
  232.   if ValidPicture(Image.Picture) then ModalResult := mrOk;
  233. end;
  234.  
  235. procedure TImageForm.FormDestroy(Sender: TObject);
  236. begin
  237.   FBmpImage.Free;
  238.   FBmpImage := nil;
  239. end;
  240.  
  241. procedure TImageForm.PreviewKeyPress(Sender: TObject; var Key: Char);
  242. begin
  243.   if Key = #27 then TForm(Sender).Close;
  244. end;
  245.  
  246. procedure TImageForm.PreviewBtnClick(Sender: TObject);
  247. var
  248.   PreviewForm: TForm;
  249. begin
  250.   if not ValidPicture(Image.Picture) then Exit;
  251. {$IFDEF CBUILDER}
  252.   PreviewForm := TForm.CreateNew(Self, 0);
  253. {$ELSE}
  254.   PreviewForm := TForm.CreateNew(Self);
  255. {$ENDIF}
  256.   with PreviewForm do
  257.   try
  258.     Caption := SPreview;
  259. {$IFDEF WIN32}
  260.     BorderStyle := bsSizeToolWin;
  261. {$ELSE}
  262.     BorderIcons := [biSystemMenu];
  263. {$ENDIF}
  264.     Icon := Self.Icon;
  265.     KeyPreview := True;
  266.     Position := poScreenCenter;
  267.     OnKeyPress := PreviewKeyPress;
  268.     with TImage.Create(PreviewForm) do begin
  269.       Left := 0; Top := 0;
  270.       Stretch := False;
  271.       AutoSize := True;
  272.       Picture.Assign(Image.Picture);
  273.       Parent := PreviewForm;
  274.     end;
  275.     if Image.Picture.Width > 0 then begin
  276.       ClientWidth := Image.Picture.Width;
  277.       ClientHeight := Image.Picture.Height;
  278.     end;
  279.     ShowModal;
  280.   finally
  281.     Free;
  282.   end;
  283. end;
  284.  
  285. procedure TImageForm.OkBtnClick(Sender: TObject);
  286. begin
  287.   if (ActiveControl = FileEdit) then FileListBox.ApplyFilePath(FileEdit.Text)
  288.   else if ValidPicture(Image.Picture) then ModalResult := mrOk
  289.   else Beep;
  290. end;
  291.  
  292. end.