main.pas

至于这小软件的用途

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ActnList, ComCtrls, StdCtrls;

type
  TMainForm = class(TForm)
    MainMenu1: TMainMenu;
    Browsefolder1: TMenuItem;
    Browsefile1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    ActionList1: TActionList;
    Action1: TAction;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Action1Execute(Sender: TObject);
  private
    FThumbFrame,
    FThumbOffset,
    FTextHeight: Integer;
    FFileList: TList;
    FSelectedImage,
    FThumbWidth,
    FThumbHeight,
    FLastIndex: Integer;
    FDirectory: String;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure CalculateSize;
    procedure ClearFileList;
    procedure RescaleImage(Source, Target: TBitmap; FastStretch: Boolean);
    procedure CalculateCounts(var XCount, YCount, HeightPerLine, ImageWidth: Integer);
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

//----------------------------------------------------------------------------------------------------------------------

implementation

{$R *.DFM}

uses
  FileCtrl, GraphicEx,
  ShlObj, ActiveX; // these both just for the SelectDirectory function

type
  PFileEntry = ^TFileEntry;
  TFileEntry = record
    Name: String;
    Bitmap: TBitmap;
  end;

//----------------------------------------------------------------------------------------------------------------------

function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;

// callback function used in SelectDirectory to set the status text and choose an initial dir

var
  Path: array[0..MAX_PATH] of Char;
  X, Y: Integer;
  R: TRect;

begin
  case uMsg of
    BFFM_INITIALIZED:
      begin
        // Initialization has been done, now set our initial directory which is passed in lpData
        // (and set btw. the status text too).
        // Note: There's no need to cast lpData to a PChar since the following call needs a
        //       LPARAM parameter anyway.
        SendMessage(hwnd, BFFM_SETSELECTION, 1, lpData);
        SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, lpData);

        // place the dialog screen centered
        GetWindowRect(hwnd, R);
        X := (Screen.Width - (R.Right - R.Left)) div 2;
        Y := (Screen.Height - (R.Bottom - R.Top)) div 2;
        SetWindowPos(hwnd, 0, X, Y, 0, 0, SWP_NOSIZE or SWP_NOZORDER); 
      end;
    BFFM_SELCHANGED:
      begin
        // Set the status window to the currently selected path.
        if SHGetPathFromIDList(Pointer(lParam), Path) then SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, Integer(@Path));
      end;
  end;
  Result := 0;
end;

//----------------------------------------------------------------------------------------------------------------------

function SelectDirectory(const Caption, InitialDir: String; const Root: WideString;
                         ShowStatus: Boolean; out Directory: String): Boolean;

// Another browse-for-folder function with the ability to select an intial directory
// (other SelectDirectory functions are in FileCtrl.pas).

var
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  RootItemIDList,
  ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
  Windows: Pointer;
  Path: String;

begin
  Result := False;
  Directory := '';
  Path := InitialDir;
  if (Length(Path) > 0) and (Path[Length(Path)] = '\') then Delete(Path, Length(Path), 1);
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      SHGetDesktopFolder(IDesktopFolder);
      IDesktopFolder.ParseDisplayName(Application.Handle, nil, PWideChar(Root), Eaten, RootItemIDList, Flags);
      with BrowseInfo do
      begin
        hwndOwner := Application.Handle;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS;
        if ShowStatus then ulFlags := ulFlags or BIF_STATUSTEXT;
        lParam := Integer(PChar(Path));
        lpfn := BrowseCallbackProc;
      end;

      // make the browser dialog modal
      Windows := DisableTaskWindows(Application.Handle);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        EnableTaskWindows(Windows);
      end;

      Result :=  ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TMainForm.FormCreate(Sender: TObject);

begin
  // the space to be left between the border and the content in an image (horizontally and vertically)
  FThumbFrame := 2;
  // the space to be left between two adjacent images (horizontally and vertically)
  FThumbOffset := 15;
  // height of the entire text area below each image
  FTextHeight := 15;
  // thumb size
  FThumbWidth := 100;
  FThumbHeight := 100;

  FSelectedImage := -1;
  
  FFileList := TList.Create;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TMainForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);

begin
  Message.Result := 1;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TMainForm.CalculateCounts(var XCount, YCount, HeightPerLine, ImageWidth: Integer);

begin
  // How many images per line?
  ImageWidth := FThumbWidth + 2 * (FThumbFrame + 1) + FThumbOffset;
  XCount := Trunc((ClientWidth + FThumbOffset) / ImageWidth);
  if XCount = 0 then XCount := 1;
  // How many (entire) images above the client area?
  HeightPerLine := FThumbHeight + 2 * (FThumbFrame + 1) + FThumbOffset + FTextHeight;
  YCount := Trunc(VertScrollBar.Position / HeightPerLine);
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TMainForm.FormPaint(Sender: TObject);

var
  XPos,
  YPos,
  Index,
  XCount,
  YCount,
  HeightPerLine,
  ImageWidth,
  EraseTop: Integer;
  R,
  ImageR,
  TextR: TRect;
  S: String;
  ImageData: PFileEntry;

begin
  with Canvas do
  begin
    // calculate and set initial values
    Brush.Color := clBtnHighlight;
    Pen.Width := FThumbFrame;
    Pen.Color := clBtnHighlight;

    CalculateCounts(XCount, YCount, HeightPerLine, ImageWidth);
    // vertical draw offset is then:
    YPos := 5 - VertScrollBar.Position + YCount * HeightPerLine;
    // finally we need the image index to start with
    Index := XCount * YCount;
    // from where to start erasing unfilled parts
    EraseTop := 0;

    // now loop until the client area is filled 
    if Index < FFileList.Count then 
    repeat
      XPos := (Index mod XCount) * ImageWidth;

      if (FLastIndex = -1) or (Index >= FLastIndex) then
      begin
        // get current image
        ImageData := FFileList[Index]; 
       
        // determine needed display area 
        R := Rect(XPos, YPos, XPos + FThumbWidth + 2 * (FThumbFrame + 1),
          YPos + FThumbHeight + 2 * (FThumbFrame + 1) + FTextHeight);

        S := ExtractFileName(ImageData.Name);
        TextR := R; 
        TextR.Top := TextR.Bottom - FTextHeight; 
        OffsetRect(TextR, 0, -(1 + FThumbFrame)); 
        InflateRect(TextR, -(1 + FThumbFrame), 0); 

        // skip images not shown in the client area 
        if R.Bottom > 0 then 
        begin 
          // early out if client area is filled 
          if R.Top > Height then Break; 

          // fill thumb frame area (frame only to avoid flicker)