Unit OpenDirDialog;

Interface

Uses Windows, Messages, SysUtils, ShlObj, ActiveX, Graphics , Commctrl;

Type

  TNotifyEvent = Procedure(Sender: TObject) Of Object;
  TOnFolderChanged = Procedure(Sender: TObject; Path: String) Of Object;
  //*** Убрал Computer, т.к. он ничего не давал, а если был задан только он, то
  //вообще ничего выбрать нельзя было :( Название типа сделал похожим
  // на аналогичное по назначению из ShellTreeView со вкладки Samples
  TOpenDirObjectTypes = Set Of(otFolders, otFiles, otPrinters);
  //*** Решил разделить на два св-ва + Изменил название
  TOpenDirOptions = Set Of (odEditBox, odNewStyle);

  TOpenDirDialog = Class(TObject)
  Private
    FBrowseInfo: BROWSEINFO;
    FItemIdList: PITEMIDLIST;
    FOwner: HWND;
    FHandle: HWND;
    FShowCheckBox : Boolean; //***
    FDefaultChecked: Boolean;  //***
    FCheckedAutosave : Boolean; //***
    FChecked: Boolean;
    FPath: String;
    FCaption: String;           //***
    FObjectTypes: TOpenDirObjectTypes;
    FOptions: TOpenDirOptions;
    FOnCreate: TNotifyEvent;
    FOnChange: TOnFolderChanged;
    Procedure SetObjectTypes(Const Value: TOpenDirObjectTypes);
    Procedure SetOptions(Const Value: TOpenDirOptions);
    Procedure CreateCheckBox;
  Public
    Constructor Create (Owner:HWND); //***
    Function Execute: Boolean; Virtual;
    property ShowCheckBox: Boolean Read FShowCheckBox Write FShowCheckBox;
    Property Caption: String Read FCaption Write FCaption;
    Property Checked: Boolean Read FChecked Write FChecked;
    Property CheckedAutosave: Boolean Read FCheckedAutosave Write FCheckedAutosave;    
    Property DefaultChecked: Boolean Read FDefaultChecked Write FDefaultChecked;
    Property Path: String Read FPath;
    Property ObjectTypes: TOpenDirObjectTypes Read FObjectTypes Write SetObjectTypes;
    Property Options: TOpenDirOptions Read FOptions Write SetOptions;
    Property OnCreate: TNotifyEvent Read FOnCreate Write FOnCreate;
    Property OnChange: TOnFolderChanged Read FOnChange Write FOnChange;
    Property Handle: HWND Read FHandle;
    Property Owner: HWND Read FOwner Write FOwner;
  End;

Function BrowseFolderCallBackProc(HWnd: HWND; Msg, LParam, WParam: Integer): Integer; Stdcall;
//*** убрано MyDlgProc. Зачем оно тут было? И, кстати, почему если убрать отсюда
//BrowseFolderCallBackProc, то при запуске возникает Access Violation

Implementation

Var
  CheckBoxHandle: THandle;
  OpenDirDlg: TOpenDirDialog;
  OldDlgProc: Pointer;
  TempChecked : Boolean; //*** Т.к. раньше, если Autosave и закрыть по "Отмена"
                         //то состояние сохранится. Теперь оно сохраниться только
                         //если нажали ОК. (см. Execute)  

{ Functions "friends" of class TOpenDirDlg } // Вообще жаль, что такого понятия нет в Дельфи... (в Си есть)
Function MyDlgProc(HWnd: HWND; Msg, WParam, LParam: Integer): Integer; Stdcall;
Begin
  If (Msg = WM_COMMAND) And
     (HiWord(WParam) = BN_CLICKED) And
     (Cardinal(LParam) = CheckBoxHandle) //*** Cardinal() Т.к. ранее могли быть баги
                                         //т.к. lparam со знаком, а THandle - без
                                         //и если бы они были больше 2^31 то баги
                                         //и были бы...
  Then TempChecked := Bool(SendMessage(CheckBoxHandle, BM_GETCHECK, 0, 0));
  Result := CallWindowProc(OldDlgProc, Hwnd, Msg, WParam, LParam);
End;

Function BrowseFolderCallBackProc(HWnd: HWND; Msg, LParam, WParam: Integer): Integer;
Var
  Temp: PChar;
  Path: String;
Begin
  Case Msg Of

    BFFM_INITIALIZED:
    Begin
      //SetWindowPos(Hwnd, 0, 0, 0, 324, 361, SWP_NOMOVE);
      OldDlgProc := Pointer(GetWindowLong(HWnd, DWL_DLGPROC));
      SetWindowLong(HWnd, DWL_DLGPROC, LongInt(@MyDlgProc));
      SetWindowLong(HWnd, GWL_EXSTYLE, GetWindowLong(HWnd, GWL_EXSTYLE) or WS_EX_TOOLWINDOW or WS_EX_CLIENTEDGE	);
      OpenDirDlg.FHandle := HWnd;
      SendMessage(HWnd, BFFM_SETSELECTION, 1, Integer(PChar(OpenDirDlg.FPath)));
      If OpenDirDlg.ShowCheckBox Then OpenDirDlg.CreateCheckBox;
      //*** перенесено в конец
      If Assigned(OpenDirDlg.FOnCreate) Then OpenDirDlg.FOnCreate(OpenDirDlg);
    End;

    BFFM_SELCHANGED:
    Begin
      If Assigned(OpenDirDlg.FOnChange) Then
        Begin
          GetMem(Temp, MAX_PATH);
          SHGetPathFromIDList(PITEMIDLIST(LParam), Temp);
          Path := StrPas(Temp);
          FreeMem(Temp, MAX_PATH);
          OpenDirDlg.FOnChange(OpenDirDlg, Path);
        End;
    End;
  End;
  Result := 0;
End;

{ Class TOpenDirDialog }
Constructor TOpenDirDialog.Create (Owner:HWND);
Begin
  FOwner := Owner;
  FBrowseInfo.ulFlags := 0;
  FItemIdList := NIL;
  FObjectTypes := [otFolders];
  FOptions := [];
  FShowCheckBox := True;
  FDefaultChecked := False;
  FCheckedAutosave := true;
  FChecked := false;
  OpenDirDlg := Self;
End;

Procedure TOpenDirDialog.CreateCheckBox;
var
  FHandle: THandle;
Begin
  //Это создаваемое по-умолчанию окно (TLabel) для заголовка окна...
  DestroyWindow(FindWindowEx(OpenDirDlg.FHandle, 0, 'Static', NIL));
  //*** теперь просто CreateWindow
  CheckBoxHandle := CreateWindow('Button', PChar(Caption),
                    WS_VISIBLE Or WS_CHILD Or BS_AUTOCHECKBOX or WS_TabStop{//***},
                    11, 12, 143, 16, OpenDirDlg.FHandle,
                    0{//*** почему здесь было 1000?}, HInstance, NIL);
  SendMessage(CheckBoxHandle, WM_SETFONT,SendMessage(GetParent(CheckBoxHandle), WM_GETFONT, 0, 0), 1);
  //*** Если поставлено автосохранять состояние, то новое окно откроется с тем
  //же состоянием флажка, которое было при его последнем закрытии.
  //Если нет, то всегда ставить DefaultChecked
  if FCheckedAutosave
    then SendMessage(CheckBoxHandle, BM_SETCHECK, LongInt(Checked), 0)
    else SendMessage(CheckBoxHandle, BM_SETCHECK, LongInt(DefaultChecked), 0);

{  FHandle := CreateStatusWindow(WS_CHILD Or WS_VISIBLE or SBT_OWNERDRAW and not SBARS_SIZEGRIP,
    NIL, Handle, 123);
  SendMessage(FHandle, SB_SIMPLE, 1, 0);
  SendMessage(FHandle, SB_SETTEXT, 255, LongInt(PChar('Powered by ExDlgs 1.2.0.158'))); }
End;

Function TOpenDirDialog.Execute: Boolean;
Var
  Temp: PChar;
Begin
  CoInitialize(NIL);
  GetMem(Temp, MAX_PATH);
  With FBrowseInfo Do
  Begin
    ulFlags := 0;
    If otFolders In FObjectTypes Then
      ulFlags := ulFlags or BIF_RETURNONLYFSDIRS;
    If otFiles In  FObjectTypes Then
      ulFlags := ulFlags or BIF_BROWSEINCLUDEFILES;
    If otPrinters In  FObjectTypes Then
      ulFlags := ulFlags or BIF_BROWSEFORPRINTER;
    if odEditBox in FOptions then
      ulFlags := ulFlags or BIF_EDITBOX;
    if odNewStyle in FOptions then
      ulFlags := ulFlags or BIF_NEWDIALOGSTYLE or BIF_STATUSTEXT;

    hwndOwner := FOwner;
    if not FShowCheckBox //*** Если не показываем чекбокс, то просто выводим надпись
      then lpszTitle := PChar(FCaption)
      else lpszTitle := PChar('');
    pszDisplayName := Temp;
    pidlRoot := NIL; //*** В будущем еще бы научится Root задавать
    lpfn := @BrowseFolderCallBackProc;
  End;

  if FCheckedAutosave               //***
    then TempChecked := FChecked
    else TempChecked := FDefaultChecked;
    
  FItemIdList := SHBrowseForFolder(FBrowseInfo);

  If FItemIdList <> NIL Then
    Begin
      SHGetPathFromIDList(FItemIdList, Temp);
      FPath := StrPas(Temp);
      FChecked := TempChecked;     //***
      Result := True;
    End
  Else
      Result := False;
  FreeMem(Temp, MAX_PATH);
  CoTaskMemFree(FItemIdList);
End;

//*** Xor вместо Or
Procedure TOpenDirDialog.SetObjectTypes(Const Value: TOpenDirObjectTypes);
Begin
  FObjectTypes := Value;
End;

Procedure TOpenDirDialog.SetOptions(Const Value: TOpenDirOptions);
Begin
  FOptions := Value;
End;

End.
