Unicoded対応ファイル選択ダイアログ

unit myOpenFileDialog;

interface
uses
  Windows, Classes;

//複数選択
function gfnbOpenFileDialog(slFile: TStrings; sDir: WideString; hHandle: HWND; iOpt: Integer): Boolean; overload;
function gfnbOpenFileDialog(slFile: TStrings; sDir: WideString; hHandle: HWND): Boolean; overload;
function gfnbOpenFileDialog(slFile: TStrings): Boolean; overload;

//ひとつだけ選択
function gfnbOpenFileDialog(var sFile: WideString; sDir: WideString; hHandle: HWND; iOpt: Integer): Boolean; overload;
function gfnbOpenFileDialog(var sFile: WideString; sDir: WideString; hHandle: HWND): Boolean; overload;
function gfnbOpenFileDialog(var sFile: WideString; hHandle: HWND): Boolean; overload;
function gfnbOpenFileDialog(var sFile: WideString): Boolean; overload;

implementation
uses
  CommDlg,
  Dialogs,
  Forms,
  Messages,
  MultiMon,
  SysUtils;


// WideString ------------------------------------------------------------------
//UTF-16LE⇔UTF-7
function gfnsWideToUtf7(sSrc: WideString): AnsiString;
//WideStringをUTF-7にエンコードして返す
var
  li_Len:  Integer;
  lp_Buff: PAnsiChar;
begin
  //WC_COMPOSITECHECKはNG
  li_Len  := WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, nil, 0, nil, nil);
  lp_Buff := AllocMem(li_Len + 1);
  try
    WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, lp_Buff, li_Len, nil, nil);
    Result := AnsiString(lp_Buff);
  finally
    FreeMem(lp_Buff);
  end;
end;

function gfnsUtf7ToWide(sSrc: AnsiString): WideString;
//UTF-7でエンコードされている文字列をWideStringにして返す
var
  li_Len:  Integer;
  lp_Buff: PWideChar;
begin
  li_Len  := MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, nil, 0);
  lp_Buff := AllocMem((li_Len + 1) * 2);
  try
    MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len);
    Result := WideString(lp_Buff);
  finally
    FreeMem(lp_Buff);
  end;
end;

function gfnsWideCopy(pStr: PWideChar; iIndex, iCount: DWORD): WideString;
var
  i: DWORD;
begin
  SetLength(Result, iCount);
  for i := 1 to iCount do begin
    Result[i] := pStr[iIndex + i -1];
  end;
end;


// Rect ------------------------------------------------------------------------
function gfniRectWidth (rtRect: TRect): Integer;
//rtRectの幅を返す
begin
  with rtRect do begin
    Result := Right - Left;
  end;
end;

function gfniRectHeight(rtRect: TRect): Integer;
//rtRectの高さを返す
begin
  with rtRect do begin
    Result := Bottom - Top;
  end;
end;

function gfnrcRectCenter(rcParent, rcChild: TRect): TRect;
//rcChildがrcParentの真ん中にくるようなRectを返す
var
  li_Left, li_Top, li_Width, li_Height: Integer;
begin
  li_Width  := gfniRectWidth (rcChild);
  li_Height := gfniRectHeight(rcChild);
  li_Left   := rcParent.Left + (gfniRectWidth (rcParent) - li_Width)  div 2;
  li_Top    := rcParent.Top  + (gfniRectHeight(rcParent) - li_Height) div 2;

  Result := Rect(li_Left, li_Top, li_Left + li_Width, li_Top + li_Height);
end;

function gfnrcMonitorWorkAreaRectGet(hHandle: HWND): TRect; overload;
//ウィンドウのあるモニターのワークエリアを返す。
var
  lr_Info: TMonitorInfo;
begin
  lr_Info.cbSize := SizeOf(lr_Info);
  GetMonitorInfo(MultiMon.MonitorFromWindow(hHandle, MONITOR_DEFAULTTONEAREST), @lr_Info);
  Result := lr_Info.rcWork;
end;


{
Unicode対応のファイル選択ダイアログ
TOpenFilename(OpenFilename構造体)について
http://homepage2.nifty.com/Mr_XRAY/Halbow/Chap18.html
コールバック関数について
http://www.vbstation.net/spec/S3_1.htm
}
//コールバック関数
function l_fniCallbackFileDialog(hHandle: HWND; iMsg: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
var
  lh_Handle: HWND;
  lrc_Rect:  TRect;
begin
  if (iMsg = WM_INITDIALOG) then begin
    lh_Handle := GetParent(hHandle);  //ダイアログボックスのウィンドウハンドルを取得
    GetWindowRect(lh_Handle, lrc_Rect);
    //表示位置をモニターの真ん中に
    lrc_Rect := gfnrcRectCenter(gfnrcMonitorWorkAreaRectGet(lh_Handle), lrc_Rect);
    SetWindowPos(lh_Handle, HWND_TOP, lrc_Rect.Left, lrc_Rect.Top, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
  end;
  Result := 0;
end;

function gfnbOpenFileDialog(slFile: TStrings; sDir: WideString; hHandle: HWND; iOpt: Integer): Boolean;
{
Unicode対応のファイル選択ダイアログ。
http://delwiki.info/?%A5%B3%A1%BC%A5%C9%C1%D2%B8%CB%2FUnicode%C2%D0%B1%FE%B0%C6%A4%BD%A4%CE%A3%B2
上記サイトとDialogsのTOpenDialog.DoExecuteを参考。

複数選択版も一つだけ選択版も最終的にこの関数を呼び出す。
}
const
  lcs_SEP = #0;
var
  lr_Info: TOpenFilenameW;
  ls_Path, ls_Item: WideString;
  i, li_Start: DWORD;
begin
  FillChar(lr_Info, SizeOf(lr_Info), 0);  //0で初期化
  with lr_Info do begin
    lStructSize := SizeOf(lr_Info);
    hWndOwner   := hHandle;
    if (hWndOwner = 0) then hWndOwner := Application.Handle;
    lpstrInitialDir := PWideChar(sDir);
    FlagsEx := 0;
    Flags   := iOpt or OFN_EXPLORER;  //エクスプローラ風は必須(古いタイプのとでは区切りが違うので)
    if (hHandle = Application.Handle) then begin
      //Application.Handleだとダイアログが右下に表示されるのでフックを行って真ん中にする
      Flags    := Flags or OFN_ENABLEHOOK;
      lpfnHook := l_fniCallbackFileDialog;
    end else begin
      if ((Flags and OFN_ENABLEHOOK) <> 0) then begin
        Flags := Flags - OFN_ENABLEHOOK;
      end;
      lpfnHook := nil;
    end;
    nMaxFile := 1024 * 32; //とりあえずこれだけあれば大丈夫ではないかなと
    lpstrFile := AllocMem((nMaxFile + 2) * 2);  //終了マーカーの'#0#0'の分で + 2。Unicodeなのでその2倍。
    try
      Result := GetOpenFileNameW(lr_Info);
      if (Result) then begin
        slFile.Clear;
        if ((iOpt and OFN_ALLOWMULTISELECT) = 0) then begin
          //一つだけ選択
          slFile.Add(gfnsWideToUtf7(WideString(lpstrFile)));
        end else begin
          {
          lpstrFileには'Path#0File1#0File2#0..File(n)#0#0'というように#0を区切り子として
          最初にパス、次から選択ファイルのファイル名のみが格納されるので分解して取り出す。
          ただしひとつだけしか選択していないときはフルパスで格納されることに注意。
          }
          li_Start := 0;
          ls_Path  := '';
          for i := 0 to (nMaxFile -1) do begin
            if (lpstrFile[i] = lcs_SEP) then begin
              ls_Item := gfnsWideCopy(lpstrFile, li_Start, i - li_Start);
              if (ls_Path = '') then begin
                ls_Path := ls_Item;
              end else begin
                slFile.Add(gfnsWideToUtf7(ls_Path + '\' + ls_Item))
              end;
              if (i < nMaxFile) and (lpstrFile[i + 1] = lcs_SEP) then begin
                //#0が二つ続くので終了
                Break;
              end;
              li_Start := i + 1; //区切りの次のインデックス
            end;
          end;
        end;
        if (slFile.Count = 0) then begin
          slFile.Add(gfnsWideToUtf7(ls_Path));  //ひとつだけしか選択していない場合。
        end;
      end;
    finally
      FreeMem(lpstrFile);
    end;
  end;
end;

//複数選択
function gfnbOpenFileDialog(slFile: TStrings; sDir: WideString; hHandle: HWND): Boolean;
begin
  Result := gfnbOpenFileDialog(slFile, sDir, hHandle, OFN_PATHMUSTEXIST or OFN_FILEMUSTEXIST or OFN_HIDEREADONLY or OFN_ALLOWMULTISELECT or OFN_EXPLORER);
end;

function gfnbOpenFileDialog(slFile: TStrings): Boolean;
begin
  Result := gfnbOpenFileDialog(slFile, '', Application.Handle, OFN_PATHMUSTEXIST or OFN_FILEMUSTEXIST or OFN_HIDEREADONLY or OFN_ALLOWMULTISELECT or OFN_EXPLORER);
end;


//シングル選択
function gfnbOpenFileDialog(var sFile: WideString; sDir: WideString; hHandle: HWND; iOpt: Integer): Boolean;
//Unicode対応ファイル選択ダイアログのひとつだけ版。
var
  lsl_List: TStrings;
begin
  lsl_List := TStringList.Create;
  try
    //複数選択のオプションがあれば取り除く
    if Boolean(iOpt and OFN_ALLOWMULTISELECT) then Dec(iOpt, OFN_ALLOWMULTISELECT);

    Result := gfnbOpenFileDialog(lsl_List, sDir, hHandle, iOpt);
    if (lsl_List.Count > 0) then begin
      //リストにはUTF-7に変換されたWideStringが入っているので戻す
      sFile := gfnsUtf7ToWide(lsl_List.Strings[0]);
    end else begin
      sFile := '';
    end;
  finally
    lsl_List.Free;
  end;
end;

function gfnbOpenFileDialog(var sFile: WideString): Boolean;
begin
  Result := gfnbOpenFileDialog(sFile, '', Application.Handle);
end;

function gfnbOpenFileDialog(var sFile: WideString; hHandle: HWND): Boolean;
begin
  Result := gfnbOpenFileDialog(sFile, '', hHandle);
end;

function gfnbOpenFileDialog(var sFile: WideString; sDir: WideString; hHandle: HWND): Boolean;
begin
  Result := gfnbOpenFileDialog(sFile, sDir, hHandle, OFN_PATHMUSTEXIST or OFN_FILEMUSTEXIST or OFN_HIDEREADONLY);
end;


end.

//複数ファイル選択の場合
procedure TForm1.Button1Click(Sender: TObject);
var
  lsl_Files: TStrings;
  i: Integer;
begin
  lsl_Files := TStringList.Create;
  try
    if (gfnbOpenFileDialog(lsl_Files)) then begin
      for i := 0 to lsl_Files.Count-1 do begin
       //lsl_Files[i]を利用した処理
      end;
    end;
  finally
    lsl_Files.Free;
  end;
end;


//一つだけ選択の場合
procedure TForm1.Button2Click(Sender: TObject);
var
  ls_File: WideString;
begin
  if (gfnbOpenFileDialog(ls_File)) then begin
    //ls_Fileを利用した処理
  end;
end;