www.pudn.com > _JEDI_VCL__JVCL333CompleteJCL1101-Build2725.zip > StretchGraphicDemoMain.pas, change:2006-05-18,size:13281b


// 
// Robert Rossmair, 2002-09-22 
//          revised 2005-06-26 
// 
 
{$I jcl.inc} 
 
{$IFDEF RTL140_UP} 
  {$IFDEF VCL} 
    {$DEFINE HasShellCtrls} // $(Delphi)\Demos\ShellControls\ShellCtrls.pas 
  {$ENDIF VCL} 
{$ENDIF RTL140_UP} 
 
unit StretchGraphicDemoMain; 
 
interface 
 
uses 
  SysUtils, Classes, 
  {$IFDEF MSWINDOWS} 
  Windows, Messages, JPEG, ShellAPI, 
  {$ENDIF MSWINDOWS} 
  {$IFDEF VCL} 
  Graphics, Controls, Forms, 
  Dialogs, ComCtrls, StdCtrls, Menus, ExtCtrls, ExtDlgs, 
  JclGraphics, 
  {$ENDIF VCL} 
  {$IFDEF VisualCLX} 
  Qt, QGraphics, QMenus, QTypes, QExtCtrls, QComCtrls, QStdCtrls, 
  QControls, QForms, QDialogs, 
  JclQGraphics, 
  {$ENDIF VisualCLX} 
  {$IFDEF HasShellCtrls} 
    {$WARN UNIT_PLATFORM OFF}  
  ShellCtrls, 
  {$ENDIF HasShellCtrls} 
  JclFileUtils; 
 
type 
  TStretchDemoForm = class(TForm) 
    PageControl: TPageControl; 
    OriginalPage: TTabSheet; 
    StretchedPage: TTabSheet; 
    StretchedImage: TImage; 
    MainMenu: TMainMenu; 
    Fil1: TMenuItem; 
    Open1: TMenuItem; 
    N1: TMenuItem; 
    ExitItem: TMenuItem; 
    Filter1: TMenuItem; 
    Box1: TMenuItem; 
    Triangle1: TMenuItem; 
    Hermite1: TMenuItem; 
    Bell1: TMenuItem; 
    Spline1: TMenuItem; 
    Lanczos31: TMenuItem; 
    Mitchell1: TMenuItem; 
    Options1: TMenuItem; 
    PreserveAspectRatio1: TMenuItem; 
    PrevItem: TMenuItem; 
    NextItem: TMenuItem; 
    FilesPage: TTabSheet; 
    ScrollBox: TScrollBox; 
    StatusBar: TStatusBar; 
    Bevel1: TBevel; 
    OpenDialog: TOpenDialog; 
    FileListView: TListView; 
    OriginalImage: TImage; 
    procedure FormCreate(Sender: TObject); 
    {$IFDEF VCL} 
    procedure FormDestroy(Sender: TObject); 
    {$ENDIF VCL} 
    procedure OpenFile(Sender: TObject); 
    procedure SelectFilter(Sender: TObject); 
    procedure PreserveAspectRatio1Click(Sender: TObject); 
    procedure ExitApp(Sender: TObject); 
    procedure PrevFile(Sender: TObject); 
    procedure NextFile(Sender: TObject); 
    procedure FileListViewClick(Sender: TObject); 
    procedure LoadSelected; 
    procedure FormKeyDown(Sender: TObject; var Key: Word; 
      Shift: TShiftState); 
    procedure StretchedPageShow(Sender: TObject); 
    procedure StretchedPageResize(Sender: TObject); 
    procedure PageControlChanging(Sender: TObject; 
      var AllowChange: Boolean); 
    procedure FileListViewKeyDown(Sender: TObject; var Key: Word; 
      Shift: TShiftState); 
  {$IFDEF HasShellCtrls} 
    procedure ShellChange; 
  private 
    FShellChangeNotifier: TShellChangeNotifier; 
  {$ELSE} 
  private 
  {$ENDIF HasShellCtrls} 
    FLastImagePage: TTabSheet; 
    FFileName: string; 
    FDir: string; 
    FWidth: Integer; 
    FHeight: Integer; 
    FStretchTime: LongWord; 
    FPreserveAspectRatio: Boolean; 
    FResamplingFilter: TResamplingFilter; 
    procedure AddToFileList(const Directory: string; const FileInfo: TSearchRec); 
    procedure FileSearchTerminated(const ID: TFileSearchTaskID; const Aborted: Boolean); 
    function ChangeDirectory: Boolean; 
    procedure DoStretch; 
    procedure LoadFile(const AFileName: string); 
    procedure InvalidateStretched; 
    procedure UpdateCaption; 
    procedure UpdateFileList; 
    procedure UpdateNavButtons; 
    procedure UpdateStretched; 
    function GetFileListIndex: Integer; 
    procedure SetFileListIndex(const Value: Integer); 
    procedure SetFileName(const Value: string); 
    {$IFDEF VCL} 
    procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DropFiles; 
    {$ENDIF VCL} 
  protected 
    property FileListIndex: Integer read GetFileListIndex write SetFileListIndex; 
    property FileName: string read FFileName write SetFileName; 
  end; 
 
var 
  StretchDemoForm: TStretchDemoForm; 
 
implementation 
 
{$IFDEF VCL} 
{$R *.dfm} 
{$ENDIF} 
{$IFDEF VisualCLX} 
{$R *.xfm} 
{$ENDIF VisualCLX} 
 
var 
  FileMask: string; 
 
{$IFDEF MSWINDOWS} 
type 
  TWMDropFilesCallback = procedure (const FileName: string) of object; 
 
procedure ProcessWMDropFiles(var Msg: TWMDropFiles; Callback: TWMDropFilesCallback; DropPoint: PPoint = nil); overload; 
var 
  i: Integer; 
  FileName: array[0..MAX_PATH] of Char; 
begin 
  try 
    // in case DropPoint is evaluated by callback method, get it first 
    if DropPoint <> nil then 
      DragQueryPoint(Msg.Drop, DropPoint^); 
    if Assigned(Callback) then 
      for i := 0 to DragQueryFile(Msg.Drop, $FFFFFFFF, nil, 0) - 1 do 
      begin 
        DragQueryFile(Msg.Drop, i, FileName, MAX_PATH); 
        Callback(FileName); 
      end; 
    Msg.Result := 0; 
  finally 
    DragFinish(Msg.Drop); 
  end; 
end; 
 
procedure ProcessWMDropFiles(var Msg: TWMDropFiles; FileNames: TStrings; DropPoint: PPoint = nil); overload; 
begin 
  ProcessWMDropFiles(Msg, FileNames.Append, DropPoint); 
end; 
{$ENDIF MSWINDOWS} 
 
function IsGraphicFile(const FileName: string): Boolean; overload; 
var 
  Ext: string; 
begin 
  Ext := AnsiLowerCase(ExtractFileExt(FileName)); 
  Result := (Pos(Ext, FileMask) > 0); 
end; 
 
function IsGraphicFile(const Attr: Integer; const FileInfo: TSearchRec): Boolean; overload; 
begin 
  Result := IsGraphicFile(FileInfo.Name); 
end; 
 
procedure TStretchDemoForm.FormCreate(Sender: TObject); 
begin 
  StretchedPage.Brush.Color := clGray; 
  {$IFDEF VCL} 
  ScrollBox.DoubleBuffered := True; 
  StretchedPage.DoubleBuffered := True; 
  {$ENDIF VCL} 
  FileMask := GraphicFileMask(TGraphic); 
  //Format('%s;%s', [GraphicFileMask(TJPEGImage), GraphicFileMask(TBitmap)]); 
  OpenDialog.Filter := GraphicFilter(TGraphic); 
  FResamplingFilter := rfSpline; // rfLanczos3; 
  FPreserveAspectRatio := True; 
  UpdateNavButtons; 
  {$IFDEF HasShellCtrls} 
  FShellChangeNotifier := TShellChangeNotifier.Create(Self); 
  with FShellChangeNotifier do 
  begin 
    WatchSubTree := False; 
    OnChange := ShellChange; 
    NotifyFilters := [ 
        nfFileNameChange, 
        nfDirNameChange, 
        //nfSizeChange, 
        nfWriteChange, 
        nfSecurityChange]; 
  end; 
  {$ENDIF HasShellCtrls} 
  {$IFDEF VCL} 
  DragAcceptFiles(Handle, True); 
  {$ENDIF VCL} 
  if ParamCount > 0 then 
  with OpenDialog do 
  begin 
    FileName := ParamStr(1); 
    InitialDir := ExtractFileDir(FileName); 
    LoadFile(FileName); 
  end; 
end; 
 
{$IFDEF VCL} 
procedure TStretchDemoForm.FormDestroy(Sender: TObject); 
begin 
  DragAcceptFiles(Handle, False); 
end; 
{$ENDIF VCL} 
 
procedure TStretchDemoForm.ExitApp(Sender: TObject); 
begin 
  Close; 
end; 
 
function TStretchDemoForm.ChangeDirectory: Boolean; 
var 
  Dir, D: string; 
begin 
  D := ExtractFileDir(FileName); 
  Dir := PathAddSeparator(D); 
  Result := (Dir <> FDir) and (Pos(FDir, Dir) <> 1); 
  if Result then 
  begin 
    FDir := Dir; 
    FilesPage.Caption := Format('Files in %s', [D]); 
    OpenDialog.InitialDir := D; 
    {$IFDEF HasShellCtrls} 
    FShellChangeNotifier.Root := D; 
    {$ELSE} 
    UpdateFileList; 
    {$ENDIF HasShellCtrls} 
  end; 
end; 
 
procedure TStretchDemoForm.AddToFileList(const Directory: string; const FileInfo: TSearchRec); 
begin 
  with FileListView.Items.Add do 
  begin 
    Caption := Directory + FileInfo.Name; 
  end; 
end; 
 
procedure TStretchDemoForm.FileSearchTerminated(const ID: TFileSearchTaskID; const Aborted: Boolean); 
begin 
  with FileListView do 
    Selected := FindCaption(0, FileName, False, True, False); 
  StatusBar.Panels[0].Text := Format('%d files', [FileListView.Items.Count]); 
  UpdateNavButtons; 
end; 
 
procedure TStretchDemoForm.UpdateFileList; 
begin 
  FileListView.Items.Clear; 
  with FileSearch do 
  begin 
    FileMask := GraphicFileMask(TGraphic); 
    RootDirectory := FDir; 
    OnTerminateTask := FileSearchTerminated; 
    ForEach(AddToFileList); 
  end; 
end; 
 
procedure TStretchDemoForm.LoadFile(const AFileName: string); 
begin 
  if not IsGraphicFile(AFileName) then 
    Exit; 
  FileName := AFileName; 
  OriginalImage.Picture.LoadFromFile(FileName); 
  if not ChangeDirectory then 
    UpdateNavButtons; 
 
  UpdateCaption; 
  with FileListView do 
    Selected := FindCaption(0, FileName, False, True, False); 
 
  StretchedImage.Picture.Graphic := nil; 
  InvalidateStretched; 
  if PageControl.ActivePage = FilesPage then 
  begin 
    {$IFDEF VCL} 
    if OriginalImage.Picture.Graphic is TMetaFile then 
      PageControl.ActivePage := OriginalPage 
    else 
    {$ENDIF VCL} 
      PageControl.ActivePage := FLastImagePage; 
    FocusControl(PageControl); 
  end; 
end; 
 
procedure TStretchDemoForm.OpenFile(Sender: TObject); 
begin 
  if OpenDialog.Execute then 
    LoadFile(OpenDialog.FileName); 
end; 
 
procedure TStretchDemoForm.SelectFilter(Sender: TObject); 
begin 
  with Sender as TMenuItem do 
  begin 
    Checked := True; 
    FResamplingFilter := TResamplingFilter(Tag); 
    InvalidateStretched; 
  end; 
end; 
 
procedure TStretchDemoForm.DoStretch; 
var 
  W, H: Integer; 
  T: LongWord; 
begin 
  with OriginalImage.Picture do 
    if (Graphic = nil) {$IFDEF VCL} or (Graphic is TMetafile) {$ENDIF} then 
      Exit; 
  W := StretchedPage.Width-2; 
  H := StretchedPage.Height-2; 
  if FPreserveAspectRatio then 
    with OriginalImage.Picture.Graphic do 
    begin 
      if W * Height > H * Width then 
        W := H * Width div Height 
      else 
        H := W * Height div Width; 
    end; 
  if (FWidth <> W) or (FHeight <> H) then 
  begin 
    T := GetTickCount; 
    StretchedImage.Picture.Graphic := nil; 
    JclGraphics.Stretch(W, H, FResamplingFilter, 0, OriginalImage.Picture.Graphic, 
      StretchedImage.Picture.Bitmap); 
    with OriginalImage.Picture do 
      StatusBar.Panels[0].Text := Format('Original: %d x %d', [Width, Height]); 
    with StretchedImage.Picture do 
      StatusBar.Panels[1].Text := Format('Resized: %d x %d', [Width, Height]); 
    FWidth := W; 
    FHeight := H; 
    FStretchTime := GetTickCount - T; 
    with StretchedImage.Picture do 
      StatusBar.Panels[2].Text := Format('Resize time: %d msec', [FStretchTime]); 
  end; 
end; 
 
procedure TStretchDemoForm.PreserveAspectRatio1Click(Sender: TObject); 
begin 
  with Sender as TMenuItem do 
  begin 
    Checked := not Checked; 
    FPreserveAspectRatio := Checked; 
    InvalidateStretched; 
  end; 
end; 
 
procedure TStretchDemoForm.LoadSelected; 
begin 
  with FileListView do 
    if Selected <> nil then 
      LoadFile(Selected.Caption); 
end; 
 
procedure TStretchDemoForm.PrevFile(Sender: TObject); 
begin 
  if FileListIndex > 0 then 
    FileListIndex  := FileListIndex - 1; 
  LoadSelected; 
end; 
 
procedure TStretchDemoForm.NextFile(Sender: TObject); 
begin 
  if FileListIndex < FileListView.Items.Count - 1 then 
    FileListIndex  := FileListIndex + 1; 
  LoadSelected; 
end; 
 
procedure TStretchDemoForm.UpdateCaption; 
begin 
  if FileName <> '' then 
    Caption := Format('JCL Picture Viewer - %s', [FileName]); 
end; 
 
procedure TStretchDemoForm.UpdateNavButtons; 
begin 
  PrevItem.Enabled := FileListIndex > 0; 
  NextItem.Enabled := FileListIndex < FileListView.Items.Count - 1; 
  PrevItem.Enabled := FileListIndex > 0; 
  NextItem.Enabled := FileListIndex < FileListView.Items.Count - 1; 
end; 
 
procedure TStretchDemoForm.FileListViewClick(Sender: TObject); 
begin 
  LoadSelected; 
end; 
 
procedure TStretchDemoForm.FormKeyDown(Sender: TObject; var Key: Word; 
  Shift: TShiftState); 
{$IFDEF VCL} 
const 
  Key_Prior = VK_PRIOR; 
  Key_Next = VK_NEXT; 
{$ENDIF VCL} 
begin 
  case Key of 
    Key_Prior: 
      begin 
        PrevFile(Self); 
        Key := 0; 
      end; 
    Key_Next: 
      begin 
        NextFile(Self); 
        Key := 0; 
      end; 
  end; 
end; 
 
procedure TStretchDemoForm.StretchedPageShow(Sender: TObject); 
begin 
  UpdateStretched; 
end; 
 
procedure TStretchDemoForm.UpdateStretched; 
begin 
  if StretchedPage.Visible then 
    DoStretch; 
end; 
 
procedure TStretchDemoForm.StretchedPageResize(Sender: TObject); 
begin 
  UpdateStretched; 
end; 
 
procedure TStretchDemoForm.InvalidateStretched; 
begin 
  FWidth := 0; 
  FHeight := 0; 
  UpdateStretched; 
end; 
 
{$IFDEF VCL} 
procedure TStretchDemoForm.WMDropFiles(var Msg: TWMDropFiles); 
begin 
  ProcessWMDropFiles(Msg, LoadFile); 
end; 
{$ENDIF VCL} 
 
procedure TStretchDemoForm.PageControlChanging(Sender: TObject; 
  var AllowChange: Boolean); 
begin 
  if PageControl.ActivePage <> FilesPage then 
    FLastImagePage := PageControl.ActivePage; 
end; 
 
{$IFDEF HasShellCtrls} 
procedure TStretchDemoForm.ShellChange; 
begin 
  UpdateFileList; 
end; 
{$ENDIF HasShellCtrls} 
 
function TStretchDemoForm.GetFileListIndex: Integer; 
begin 
  Result := -1; 
  if FileListView.Selected <> nil then 
    Result := FileListView.Selected.Index; 
end; 
 
procedure TStretchDemoForm.SetFileListIndex(const Value: Integer); 
begin 
  if Value < 0 then 
  begin 
    if FileListView.Selected <> nil then 
    begin 
      FileListView.Selected.Selected := False; 
    end; 
  end 
  else 
    FileListView.Items[Value].Selected := True; 
end; 
 
procedure TStretchDemoForm.FileListViewKeyDown(Sender: TObject; 
  var Key: Word; Shift: TShiftState); 
begin 
  if Key = VK_RETURN then 
    LoadSelected; 
end; 
 
procedure TStretchDemoForm.SetFileName(const Value: string); 
begin 
  FFileName := PathGetLongName(Value); 
end; 
 
end.