Unicode対応のTSaveDialog

interface
uses
  Classes,
  Controls,
  Dialogs,
  Messages,
  Windows,
  myWStrings;  //Unicode対応のTStringsのようなクラス

{ファイル選択}
type
  { TMyOpenFileDialog }
  TMyOpenFileDialog = class(TOpenDialog)
  private
    F_hHandle:    HWND;
    F_bPosCenter: Boolean;
    F_sDefaultExt, F_sFileName, F_sInitialDir, F_sTitle: WideString;
    F_slFiles:    TMyWStrings;
    F_Owner:      TWinControl;

    function  F_GetCount: Integer;
  protected
    procedure DoShow; override;
    procedure DoClose; override;
    function  GetStaticRect: TRect; override;
    function  F_GetFiles(pBuff: PWideChar; iLen: DWORD; slFiles: TMyWStrings): WideString;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function Execute: Boolean; override;
    function ShortFileName: WideString;
    function ShortFileNames(iIndex: Integer): WideString;

    property Count:  Integer     read F_GetCount;
    property Files:  TMyWStrings read F_slFiles;
    property Handle: HWND        read F_hHandle;
  published
    property DefaultExt: WideString  read F_sDefaultExt write F_sDefaultExt;
    property FileName:   WideString  read F_sFileName   write F_sFileName;
    property InitialDir: WideString  read F_sInitialDir write F_sInitialDir;
    property PosCenter:  Boolean     read F_bPosCenter  write F_bPosCenter default True;
    property Owner:      TWinControl read F_Owner       write F_Owner;
    property Title:      WideString  read F_sTitle      write F_sTitle;
  end;

implementation
uses
  CommDlg,
  Dlgs,
  Forms,
  MultiMon,
  SysUtils,
  myCommon;  //汎用ルーチン集


//------------------------------------------------------------------------------
//汎用だけれどもmyCommon.pasに入れるほどではないルーチン群

function gfnsShortFileNameGet(sFile: WideString): WideString;
//Unicode対応の短いファイル名を返す。
var
  lp_Buff: PWideChar;
begin
  lp_Buff := AllocMem((MAX_PATH +1) *2);
  try
    if (GetShortPathNameW(PWideChar(sFile), lp_Buff, (MAX_PATH + 1) * 2) > 0) then begin
      Result := WideString(lp_Buff);
    end else begin
      Result := sFile;
    end;
  finally
    FreeMem(lp_Buff);
  end;
end;

function gfnrcMonitorWorkAreaRectGet(ptPos: TPoint): TRect;
//ptPos上のモニターのワークエリアを返す。
var
  lr_Info:   TMonitorInfo;
  lh_Handle: HMONITOR;
  lrc_Rect:  TRect;
begin
  lrc_Rect  := Rect(ptPos.X, ptPos.Y, ptPos.X, ptPos.Y);
  lh_Handle := MultiMon.MonitorFromRect(@lrc_Rect, MONITOR_DEFAULTTONEAREST);

  lr_Info.cbSize := SizeOf(lr_Info);
  GetMonitorInfo(lh_Handle, @lr_Info);
  Result := lr_Info.rcWork;
end;

//------------------------------------------------------------------------------
//ファイル選択ダイアログ
{ TMyOpenFileDialog }
var
  My_Dialog: TMyOpenFileDialog = nil; //メッセージのフックのために必要

constructor TMyOpenFileDialog.Create(AOwner: TComponent);
begin
  inherited;

  F_slFiles     := TMyWStrings.Create;
  F_sFileName   := '';
  F_sInitialDir := '';
  F_sTitle      := '';
  F_bPosCenter  := True;
  if (AOwner is TWinControl) then begin
    F_Owner := (AOwner as TWinControl);
  end else begin
    F_Owner := nil;
  end;
end;

destructor TMyOpenFileDialog.Destroy;
begin
  F_slFiles.Free;
  inherited;
end;

function TMyOpenFileDialog.F_GetCount: Integer;
begin
  Result := F_slFiles.Count;
end;

function TMyOpenFileDialog.GetStaticRect: TRect;
//カスタムダイアログのために必要。
//カスタムダイアログを使用しなければ削除OK。
begin
  if (Handle <> 0) then begin
    //http://www.vbstation.net/spec/S3_1.htm
    GetWindowRect(GetDlgItem(Handle, stc32), Result);
    Result := Rect(0, 0, gfniRectWidth(Result), gfniRectHeight(Result));
  end else begin
    Result := Rect(0,0,0,0);
  end;
end;

procedure TMyOpenFileDialog.DoShow;
var
  lh_Handle: HWND;
  lrc_Rect:  TRect;
  lpt_Pos:   TPoint;
begin
  if Assigned(@OnShow) then begin
    OnShow(Self);
  end;

  if (F_bPosCenter) then begin
    //ダイアログをモニターの真ん中に
    lh_Handle := GetParent(Handle);
    GetWindowRect(lh_Handle, lrc_Rect);
    GetCursorPos(lpt_Pos);
    lrc_Rect := gfnrcRectCenter(gfnrcMonitorWorkAreaRectGet(lpt_Pos), lrc_Rect);
    SetWindowPos(lh_Handle, HWND_TOP, lrc_Rect.Left, lrc_Rect.Top, 0, 0, SWP_NOSIZE);
  end;
//  inherited DoShow; いらない。
end;

procedure TMyOpenFileDialog.DoClose;
begin
  My_Dialog := nil;
  inherited DoClose;
end;

function TMyOpenFileDialog.F_GetFiles(pBuff: PWideChar; iLen: DWORD; slFiles: TMyWStrings): WideString;
const
  lcs_SEP = #0;
var
  ls_Path, ls_Item: WideString;
  i, li_Start: DWORD;
begin
  slFiles.Clear;
  if not(ofAllowMultiSelect in Options) then begin
    //一つだけ選択
    slFiles.Add(WideString(pBuff));
  end else begin
    //複数ファイル選択
    //分解
    ls_Path  := '';
    li_Start := 0;
    for i := 0 to iLen -1 do begin
      if (pBuff[i] = lcs_SEP) then begin
        ls_Item := Copy(WideString(@pBuff[li_Start]), 1, i - li_Start);
        if (ls_Path = '') then begin
          ls_Path := ls_Item;
        end else begin
          slFiles.Add(ls_Path + '\' + ls_Item);
        end;
        if (i < iLen) and (pBuff[i +1] = lcs_SEP) then begin
          //#0が二つ続くので終了
          Break;
        end;
        li_Start := i +1; //区切りの次のインデックス
      end;
    end;
    if (slFiles.Count = 0) then begin
      slFiles.Add(ls_Path);
    end;
  end;

  if (slFiles.Count > 0) then begin
    Result := slFiles[0];
  end else begin
    Result := '';
  end;
end;

{
TOpenFilename(OpenFilename構造体)については↓に詳しい
http://mrxray.on.coocan.jp/Halbow/Chap18.html
http://yokohama.cool.ne.jp/chokuto/urawaza/struct/OPENFILENAME.html
コールバック関数について
http://www.vbstation.net/spec/S3_1.htm
}
//コールバック関数
function l_fniCallbackFileDialog(hHandle: HWND; iMsg: UINT; iWParam: WPARAM; iLParam: LPARAM): UINT stdcall;
var
  lp_Info:  POpenFilenameW;
  Msg: TMessage;
begin
  Result := 0;
  if (iMsg = WM_INITDIALOG) then begin
    lp_Info := POpenFilenameW(iLParam);  //WM_INITDIALOGの時にはiLParamにはTOpenFilenameW構造体のアドレスが入っている
    My_Dialog := TMyOpenFileDialog(lp_Info^.lCustData);
    My_Dialog.F_hHandle := hHandle;
  end else if (My_Dialog <> nil) then begin
    //unit内グローバル変数を使用。
    Msg.Msg    := iMsg;
    Msg.WParam := iWParam;
    Msg.LParam := iLParam;
    My_Dialog.WndProc(Msg); //WndProcへメッセージを横流し。
  end;
end;

function TMyOpenFileDialog.Execute: Boolean;
var
  lr_Info: TOpenFilenameW;
begin
  FillChar(lr_Info, SizeOf(lr_Info), 0);  //0で初期化
  with lr_Info do begin
    lStructSize := SizeOf(lr_Info);
    //オーナーウィンドウ
    if (F_Owner = nil) then begin
      hwndOwner := Application.Handle;
    end else begin
      hwndOwner := F_Owner.Handle;
    end;
    hInstance  := SysInit.HInstance; //カスタムダイアログで必要。
    //タイトル
    lpstrTitle := PWideChar(F_sTitle);
    //フィルタ
    if (Filter <> '') then begin
      lpstrFilter := PWideChar(WideString(StringReplace(Filter, '|', #0, [rfReplaceAll])));
    end;
    nFilterIndex := FilterIndex;
    //デフォルト拡張子
    if (F_sDefaultExt <> '') then begin
      lpstrDefExt  := PWideChar(F_sDefaultExt);
    end else begin
      lpstrDefExt := nil;
    end;
    //デフォルトフォルダ
    if (F_sInitialDir <> '') and (gfnbFolderExists(F_sInitialDir)) then begin
      lpstrInitialDir := PWideChar(F_sInitialDir);
    end else begin
      lpstrInitialDir := nil;
    end;
    //フラグ
    if (ofReadOnly            in Options) then Flags := Flags or OFN_READONLY;
    if (ofOverwritePrompt     in Options) then Flags := Flags or OFN_OVERWRITEPROMPT;
    if (ofHideReadOnly        in Options) then Flags := Flags or OFN_HIDEREADONLY;
    if (ofNoChangeDir         in Options) then Flags := Flags or OFN_NOCHANGEDIR;
    if (ofShowHelp            in Options) then Flags := Flags or OFN_SHOWHELP;
    if (ofNoValidate          in Options) then Flags := Flags or OFN_NOVALIDATE;
    if (ofAllowMultiSelect    in Options) then Flags := Flags or OFN_ALLOWMULTISELECT;
    if (ofExtensionDifferent  in Options) then Flags := Flags or OFN_EXTENSIONDIFFERENT;
    if (ofPathMustExist       in Options) then Flags := Flags or OFN_PATHMUSTEXIST;
    if (ofFileMustExist       in Options) then Flags := Flags or OFN_FILEMUSTEXIST;
    if (ofCreatePrompt        in Options) then Flags := Flags or OFN_CREATEPROMPT;
    if (ofShareAware          in Options) then Flags := Flags or OFN_SHAREAWARE;
    if (ofNoReadOnlyReturn    in Options) then Flags := Flags or OFN_NOREADONLYRETURN;
    if (ofNoTestFileCreate    in Options) then Flags := Flags or OFN_NOTESTFILECREATE;
//古いタイプは無効
//    if (ofNoNetworkButton     in Options) then Flags := Flags or OFN_NONETWORKBUTTON;
//    if (ofNoLongNames         in Options) then Flags := Flags or OFN_NOLONGNAMES;
//    if (ofOldStyleDialog      in Options) then Flags := Flags or OFN_EXPLORER;
    if (ofNoDereferenceLinks  in Options) then Flags := Flags or OFN_NODEREFERENCELINKS;
    if (ofEnableIncludeNotify in Options) then Flags := Flags or OFN_ENABLEINCLUDENOTIFY;
    if (ofEnableSizing        in Options) then Flags := Flags or OFN_ENABLESIZING;
    if (ofDontAddToRecent     in Options) then Flags := Flags or OFN_DONTADDTORECENT;
    if (ofForceShowHidden     in Options) then Flags := Flags or OFN_FORCESHOWHIDDEN;
    //エクスプローラ風は必須(古いタイプのとでは区切りが違うので)
    Flags := Flags or OFN_EXPLORER;

    //コールバック
    //メッセージフックのためコールバック関数を使う
    Flags     := Flags or OFN_ENABLEHOOK;
    lpfnHook  := l_fniCallbackFileDialog;
    lCustData := LPARAM(Self); //自身のアドレスを代入

    if (ofExNoPlacesBar in OptionsEx) then FlagsEx := FlagsEx or OFN_EX_NOPLACESBAR;

    //カスタムダイアログ。
    if (Template <> nil) then begin
      Flags := Flags or OFN_ENABLETEMPLATE;
      lpTemplateName := PWideChar(WideString(AnsiString(Template)));
    end;

    //ファイル名
//    nMaxFile := 1024 * 64 -1;  //一応この数値が限界のよう。これ以上だと一つだけ選択のときにエラーになることがあった
    nMaxFile  := 1024 * 32;
    lpstrFile := AllocMem((nMaxFile +2) * 2);
    try
      //存在しないファイルを指定するとエラーが返る
      if (F_sFileName <> '') and (gfnbFileExists(F_sFileName)) then begin
        lstrcpyW(lpstrFile, PWideChar(F_sFileName));
      end;

      Result := GetOpenFileNameW(lr_Info);
      if (Result) then begin
        if ((Flags and OFN_READONLY) <> 0) then begin
          //読み取り専用を選択
          if not(ofReadOnly in Options) then Options := Options + [ofReadOnly];
        end else begin
          //読み取り専用は非選択
          if (ofReadOnly in Options) then Options := Options - [ofReadOnly];
        end;
        F_sFileName := F_GetFiles(lpstrFile, nMaxFile, F_slFiles);
      end;
    finally
      FreeMem(lpstrFile);
    end;
  end;
end;

//短いファイル名
function TMyOpenFileDialog.ShortFileName: WideString;
begin
  Result := gfnsShortFileNameGet(Self.F_sFileName);
end;

function TMyOpenFileDialog.ShortFileNames(iIndex: Integer): WideString;
begin
  Result := gfnsShortFileNameGet(F_slFiles[iIndex]);
end;

{ OpenFileDialog }
function gfnbOpenFileDialog(slFiles: TMyWStrings; sDir: WideString; Opt: TOpenOptions): Boolean; overload;
var
  ldlg_OpenFile: TMyOpenFileDialog;
begin
  ldlg_OpenFile := TMyOpenFileDialog.Create(nil);
  with ldlg_OpenFile do begin
    try
      if (slFiles.Count > 0) then FileName := slFiles[0];
      InitialDir := sDir;
      Options    := Opt;
      Result     := Execute;
      if (Result) then begin
        slFiles.Assign(Files);
      end;
    finally
      Free;
    end;
  end;
end;