Unicode対応ファイル保存ダイアログ

unit mySaveFileDialog;

interface
uses
  Windows;

function gfnbSaveFileDialog(var sFile: WideString; sDir: WideString; hHandle: HWND; iOpt: Integer): Boolean; overload;
function gfnbSaveFileDialog(var sFile: WideString; sDir: WideString): Boolean; overload;
function gfnbSaveFileDialog(var sFile: WideString): Boolean; overload;

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


// File ------------------------------------------------------------------------
function gfnsFileNameGet(sFile: WideString): WideString;
{
パスを除いたファイル名を返す
拡張子はつく
\ はつかない
}
var
  i, li_Len, li_Pos: Integer;
begin
  Result := '';
  if (sFile <> '') then begin
    li_Len := Length(sFile);
    li_Pos := li_Len + 1;  //sFileの最後が'\'であった場合への対策
    for i := li_Len downto 1 do begin
      if (sFile[i] = '\') or (sFile[i] = '/') or(sFile[i] = ':') then begin
        Break;
      end;
      li_Pos := i;
    end;
    Result := Copy(sFile, li_Pos, MaxInt);
  end;
end;

function gfnbFolderExists(sFolder: WideString): Boolean;
//DirectoryExitsのWideString対応版
var
  lh_Handle: THandle;
  lr_Info:   TWin32FindDataW;
  li_Len:    Integer;
begin
  Result  := False;

  if (sFolder <> '') then begin
    li_Len := Length(sFolder);
    if (sFolder[li_Len] = '\') then begin
      SetLength(sFolder, li_Len -1);
    end;
  end;

  FillChar(lr_Info, SizeOf(TWin32FindDataW), 0);
  lh_Handle:= FindFirstFileW(PWideChar(sFolder), lr_Info);
  try
    if (lh_Handle<> INVALID_HANDLE_VALUE) then begin
      repeat
        if  (WideString(lr_Info.cFileName) <> '.')
        and (WideString(lr_Info.cFileName) <> '..')
        and ((lr_Info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0)
        then begin
          Result := True;
          Break;
        end;
      until not(FindNextFileW(lh_Handle, lr_Info));
    end;
  finally
    Windows.FindClose(lh_Handle);
  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;
//ウィンドウのあるモニターのワークエリアを返す。
var
  lr_Info: TMonitorInfo;
begin
  lr_Info.cbSize := SizeOf(lr_Info);
  GetMonitorInfo(MultiMon.MonitorFromWindow(hHandle, MONITOR_DEFAULTTONEAREST), @lr_Info);
  Result := lr_Info.rcWork;
end;


//コールバック関数
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;
//SaveDialog
function gfnbSaveFileDialog(var sFile: WideString; sDir: WideString; hHandle: HWND; iOpt: Integer): Boolean;
//SaveFileDialogだけども実際はファイル名取得のためだけにも使える。
var
  lr_Info: TOpenFilenameW;
  ls_Str: WideString;
begin
  FillChar(lr_Info, SizeOf(lr_Info), 0);  //0で初期化
  with lr_Info do begin
    lStructSize := SizeOf(lr_Info);
    hWndOwner   := hHandle;
    hInstance   := 0;
    lpstrTitle  := '';
    lpstrFilter := '';
    lpstrDefExt := '';
    if (sDir <> '') and (gfnbFolderExists(sDir)) then begin
      lpstrInitialDir := PWideChar(sDir);
    end else begin
      lpstrInitialDir := nil;
    end;
    FlagsEx := 0;
    Flags   := iOpt or OFN_EXPLORER;
    if ((Flags and OFN_ALLOWMULTISELECT) <> 0) then begin
      Flags := Flags - OFN_ALLOWMULTISELECT;
    end;
    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;  //ファイルは一つだけなのでとりあえずこれくらいで充分かなと。
    lpstrFile := AllocMem((nMaxFile + 2) * 2);
    lstrcpyW(lpstrFile,  PWideChar(gfnsFileNameGet(sFile)));
    try
      Result := GetSaveFileNameW(lr_Info);
      if (Result) then begin
        sFile := WideString(lr_Info.lpstrFile);
      end else begin
        sFile := '';
      end;
    finally
      FreeMem(lpstrFile);
    end;
  end;
end;

function gfnbSaveFileDialog(var sFile: WideString; sDir: WideString): Boolean;
begin
  Result := gfnbSaveFileDialog(sFile, sDir, Application.Handle, 0);
end;

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


end.

procedure TForm1.Button3Click(Sender: TObject);
var
  ls_File: WideString;
begin
  if (gfnbSaveFileDialog(ls_File)) then begin
    //ls_Fileを利用した処理
    gpcFileWriteText(ls_File, Memo1.Text, cdAuto);
  end;
end;