home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d123456 / DFS.ZIP / BrowseDr.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-27  |  57KB  |  1,422 lines
  1. {$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }
  2.  
  3. {------------------------------------------------------------------------------}
  4. { TdfsBrowseDirectoryDlg v2.62                                                 }
  5. {------------------------------------------------------------------------------}
  6. { A component to encapsulate the Win32 style directory selection dialog        }
  7. { SHBrowseForFolder().                                                         }
  8. {                                                                              }
  9. { Copyright 1999-2001, Brad Stowers.  All Rights Reserved.                     }
  10. {                                                                              }
  11. { Copyright:                                                                   }
  12. { All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
  13. { Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
  14. { property of the author.                                                      }
  15. {                                                                              }
  16. { Distribution Rights:                                                         }
  17. { You are granted a non-exlusive, royalty-free right to produce and distribute }
  18. { compiled binary files (executables, DLLs, etc.) that are built with any of   }
  19. { the DFS source code unless specifically stated otherwise.                    }
  20. { You are further granted permission to redistribute any of the DFS source     }
  21. { code in source code form, provided that the original archive as found on the }
  22. { DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
  23. { example, if you create a descendant of TdfsColorButton, you must include in  }
  24. { the distribution package the colorbtn.zip file in the exact form that you    }
  25. { downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
  26. {                                                                              }
  27. { Restrictions:                                                                }
  28. { Without the express written consent of the author, you may not:              }
  29. {   * Distribute modified versions of any DFS source code by itself. You must  }
  30. {     include the original archive as you found it at the DFS site.            }
  31. {   * Sell or lease any portion of DFS source code. You are, of course, free   }
  32. {     to sell any of your own original code that works with, enhances, etc.    }
  33. {     DFS source code.                                                         }
  34. {   * Distribute DFS source code for profit.                                   }
  35. {                                                                              }
  36. { Warranty:                                                                    }
  37. { There is absolutely no warranty of any kind whatsoever with any of the DFS   }
  38. { source code (hereafter "software"). The software is provided to you "AS-IS", }
  39. { and all risks and losses associated with it's use are assumed by you. In no  }
  40. { event shall the author of the softare, Bradley D. Stowers, be held           }
  41. { accountable for any damages or losses that may occur from use or misuse of   }
  42. { the software.                                                                }
  43. {                                                                              }
  44. { Support:                                                                     }
  45. { Support is provided via the DFS Support Forum, which is a web-based message  }
  46. { system.  You can find it at http://www.delphifreestuff.com/discus/           }
  47. { All DFS source code is provided free of charge. As such, I can not guarantee }
  48. { any support whatsoever. While I do try to answer all questions that I        }
  49. { receive and address all problems that are reported to me, you must           }
  50. { understand that I simply can not guarantee that this will always be so.      }
  51. {                                                                              }
  52. { Clarifications:                                                              }
  53. { If you need any further information, please feel free to contact me directly.}
  54. { This agreement can be found online at my site in the "Miscellaneous" section.}
  55. {------------------------------------------------------------------------------}
  56. { The lateset version of my components are always available on the web at:     }
  57. {   http://www.delphifreestuff.com/                                            }
  58. { See BrowseDr.txt for notes, known issues, and revision history.              }
  59. {------------------------------------------------------------------------------}
  60. { Date last modified:  June 27, 2001                                           }
  61. {------------------------------------------------------------------------------}
  62.  
  63.  
  64. {: This unit provides a component that displays a standard Windows 95/NT 4...
  65.    dialog containing the user's system in a heirarchial manner and allows a...
  66.    selection to be made.  It is a wrapper for the SHBrowseForFolder() API,...
  67.    which is quite messy to use directly.  Also provided is an editor which...
  68.    allows you to display the dialog at design time with the selected options.
  69.  
  70.    Note:
  71.    This component Requires Delphi 3 or Delphi v2.01's ShlObj unit.  If you...
  72.    have Delphi 2.00, you can get the equivalent using Pat Ritchey's ShellObj...
  73.    unit.  It is freely available on his web site at...
  74.    http://ourworld.compuserve.com/homepages/PRitchey/.  Both Borland's ShlObj...
  75.    unit and Pat's ShellObj unit contain errors that should be fixed.  I have...
  76.    included instructions on how to do this.  They are in the included...
  77.    ShellFix.txt file.  Delphi 3's ShlObj unit does not have any errors that I...
  78.    am currently aware of.
  79. }
  80.  
  81.  
  82. unit BrowseDr;
  83.  
  84. {$IFNDEF DFS_WIN32}
  85.   ERROR!  Only available for Win32!
  86. {$ENDIF}
  87.  
  88. interface
  89.  
  90. uses
  91.   Windows, Dialogs,
  92.   {$IFDEF DFS_COMPILER_3_UP}
  93.   ActiveX,
  94.   {$ELSE}
  95.   OLE2,
  96.   {$ENDIF}
  97.   {$IFDEF DFS_USEDEFSHLOBJ}
  98.   ShlObj, { Delphi 3 fixes all of 2.01's bugs! }
  99.   {$ELSE}
  100.   // If you get a compiler error here, read the included SHELLFIX.TXT file for
  101.   // instructions on creating MyShlObj.pas.
  102.   MyShlObj,
  103. {$ENDIF}
  104.   Controls, Classes;
  105.  
  106. const
  107.   { This shuts up C++Builder 3 about the redefiniton being different. There
  108.     seems to be no equivalent in C1.  Sorry. }
  109.   {$IFDEF DFS_CPPB_3_UP}
  110.   {$EXTERNALSYM DFS_COMPONENT_VERSION}
  111.   {$ENDIF}
  112.   DFS_COMPONENT_VERSION = 'TdfsBrowseDirectoryDlg v2.62';
  113.  
  114.   {: This is a newly documented folder identifier that is not in the Delphi...
  115.      units yet.  You can use it with any of the Win32 Shell API functions...
  116.       that wants a CSIDL_* identifier such as SHGetSpecialFolderLocation. }
  117.  
  118.   { This shuts up C++Builder 3 about the redefiniton being different. There
  119.     seems to be no equivalent in C1.  Sorry. }
  120.   {$IFDEF DFS_CPPB_3_UP}
  121.   {$EXTERNALSYM CSIDL_INTERNET}
  122.   {$ENDIF}
  123.   CSIDL_INTERNET         = $0001;
  124.   {$IFDEF DFS_COMPILER_2}
  125.   { IDs that exist in Delphi/C++B 3 ShlObj.pas unit, but not Delphi 2. }
  126.   CSIDL_COMMON_STARTMENU              = $0016;
  127.   CSIDL_COMMON_PROGRAMS               = $0017;
  128.   CSIDL_COMMON_STARTUP                = $0018;
  129.   CSIDL_COMMON_DESKTOPDIRECTORY       = $0019;
  130.   CSIDL_APPDATA                       = $001a;
  131.   CSIDL_PRINTHOOD                     = $001b;
  132.   {$ENDIF}
  133.  
  134.   {: This folder identifer is undocumented, but should work for a long time...
  135.      since the highest ID is currently around 30 or so.  It is used to open...
  136.      the tree already expanded with the desktop as the root item. }
  137.   CSIDL_DESKTOPEXPANDED  = $FEFE;
  138.   {$IFDEF DFS_COMPILER_2}
  139.   {: This constant was missing from the Delphi 2 units, but was added to...
  140.      Delphi 3.  It causes files to be included in the tree as well as folders. }
  141.   BIF_BROWSEINCLUDEFILES = $4000;
  142.   {$ENDIF}
  143.  
  144.   {$IFNDEF DFS_COMPILER_4_UP}
  145.   {: These constants are new to v4.71 of SHELL32.DLL.  Delphi 4 defines them...
  146.      but the are missing in all previous versions. }
  147.   {$IFDEF DFS_CPPB_3_UP}
  148.   {$EXTERNALSYM BIF_EDITBOX}
  149.   {$ENDIF}
  150.   BIF_EDITBOX            = $0010;
  151.   {$IFDEF DFS_CPPB_3_UP}
  152.   {$EXTERNALSYM BIF_VALIDATE}
  153.   {$ENDIF}
  154.   BIF_VALIDATE           = $0020;  { insist on valid result (or CANCEL) }
  155.   {$IFDEF DFS_CPPB_3_UP}
  156.   {$EXTERNALSYM BFFM_VALIDATEFAILED}
  157.   {$ENDIF}
  158.   BFFM_VALIDATEFAILED    = 3;      { lParam:szPath ret:1(cont),0(EndDialog) }
  159.   {$ENDIF}
  160.   {$IFNDEF DFS_COMPILER_7_UP}
  161.   {$IFDEF DFS_CPPB_3_UP} {EXTERNALSYM BIF_BROWSEINCLUDEURLS} {$ENDIF}
  162.   BIF_BROWSEINCLUDEURLS  = $0080;
  163.   {$IFDEF DFS_CPPB_3_UP} {$EXTERNALSYM BIF_NEWDIALOGSTYLE} {$ENDIF}
  164.   BIF_NEWDIALOGSTYLE = $0040;
  165.   {$IFDEF DFS_CPPB_3_UP} {$EXTERNALSYM BIF_SHAREABLE} {$ENDIF}
  166.   BIF_SHAREABLE = $8000;
  167.   {$IFDEF DFS_CPPB_3_UP} {$EXTERNALSYM BIF_USENEWUI} {$ENDIF}
  168.   BIF_USENEWUI = BIF_NEWDIALOGSTYLE or BIF_EDITBOX;
  169.   {$ENDIF}
  170.  
  171. type
  172.   {: This enumerated type is the equivalent of the CSIDL_* constants in the...
  173.      Win32 API. They are used to specify the root of the heirarchy tree.
  174.  
  175.     idDesktop: Windows desktop -- virtual folder at the root of the name space.
  176.     idInternet: Internet Explorer -- virtual folder of the Internet Explorer.
  177.     idPrograms: File system directory that contains the user's program groups...
  178.        (which are also file system directories).
  179.     idControlPanel: Control Panel -- virtual folder containing icons for the...
  180.        control panel applications.
  181.     idPrinters: Printers folder -- virtual folder containing installed printers.
  182.     idPersonal: File system directory that serves as a common respository for...
  183.        documents.
  184.     idFavorites: Favorites folder -- virtual folder containing the user's...'
  185.        Internet Explorer bookmark items and subfolders.
  186.     idStartup: File system directory that corresponds to the user's Startup...
  187.        program group.
  188.     idRecent: File system directory that contains the user's most recently...
  189.        used documents.
  190.     idSendTo: File system directory that contains Send To menu items.
  191.     idRecycleBin: Recycle bin -- file system directory containing file...
  192.        objects in the user's recycle bin. The location of this directory is...
  193.        not in the registry; it is marked with the hidden and system...
  194.        attributes to prevent the user from moving or deleting it.
  195.     idStartMenu: File system directory containing Start menu items.
  196.     idDesktopDirectory: File system directory used to physically store file...
  197.        objects on the desktop (not to be confused with the desktop folder itself).
  198.     idDrives: My Computer -- virtual folder containing everything on the...
  199.        local computer: storage devices, printers, and Control Panel. The...
  200.        folder may also contain mapped network drives.
  201.     idNetwork: Network Neighborhood -- virtual folder representing the top...
  202.        level of the network hierarchy.
  203.     idNetHood: File system directory containing objects that appear in the...
  204.        network neighborhood.
  205.     idFonts: Virtual folder containing fonts.
  206.     idTemplates: File system directory that serves as a common repository for...
  207.        document templates.
  208.     idCommonStartMenu: File system directory that contains the programs and...
  209.        folders that appear on the Start menu for all users on Windows NT.
  210.     idCommonPrograms: File system directory that contains the directories for...
  211.        the common program groups that appear on the Start menu for all users...
  212.        on Windows NT.
  213.     idCommonStartup: File system directory that contains the programs that...
  214.        appear in the Startup folder for all users. The system starts these...
  215.        programs whenever any user logs on to Windows NT.
  216.     idCommonDesktopDirectory: File system directory that contains files and...
  217.        folders that appear on the desktop for all users on Windows NT.
  218.     idAppData: File system directory that contains data common to all...
  219.        applications.
  220.     idPrintHood: File system directory containing object that appear in the...
  221.        printers folder.
  222.     idDesktopExpanded: Same as idDesktop except that the root item is already...
  223.        expanded when the dialog is initally displayed.
  224.  
  225.     NOTE: idCommonStartMenu, idCommonPrograms, idCommonStartup, and...
  226.        idCommonDesktopDirectory only have effect when the dialog is being...
  227.        displayed on an NT system.  On Windows 95, these values will be...
  228.        mapped to thier "non-common" equivalents, i.e. idCommonPrograms will...
  229.        become idPrograms.
  230.   }
  231.  
  232.   TRootID = (
  233.     idDesktop, idInternet, idPrograms, idControlPanel, idPrinters, idPersonal,
  234.     idFavorites, idStartup, idRecent, idSendTo, idRecycleBin, idStartMenu,
  235.     idDesktopDirectory, idDrives, idNetwork, idNetHood, idFonts, idTemplates,
  236.     idCommonStartMenu, idCommonPrograms, idCommonStartup,
  237.     idCommonDesktopDirectory, idAppData, idPrintHood, idDesktopExpanded
  238.    );
  239.  
  240.   {: These are equivalent to the BIF_* constants in the Win32 API.  They are...
  241.      used to specify what items can be expanded, and what items can be...
  242.      selected by combining them in a set in the Options property.
  243.  
  244.      bfDirectoriesOnly: Only returns file system directories. If the user...
  245.         selects folders that are not part of the file system, the OK button...
  246.         is grayed.
  247.      bfDomainOnly: Does not include network folders below the domain level...
  248.         in the dialog.
  249.      bfAncestors: Only returns file system ancestors (items which contain...
  250.         files, like drives).  If the user selects anything other than a file...
  251.         system ancestor, the OK button is grayed.
  252.      bfComputers: Shows other computers.  If anything other than a computer...
  253.         is selected, the OK button is disabled.
  254.      bfPrinters:    Shows all printers.  If anything other than a printers is...
  255.         selected, the OK button is disabled.
  256.      bfIncludeFiles: Show non-folder items that exist in the folders.
  257.      bfEditBox:   Includes an edit control in which the user can type the ...
  258.         of an item.  Requires v4.71 of SHELL32.DLL.
  259.      bfIncludeURLs: The browse dialog box can display URLs. The bfUseNewUI and
  260.         bfIncludeFiles flags must also be set. If these three flags are not set,
  261.         the browser dialog box will reject URLs. Even when these flags are set,
  262.         the browse dialog box will only display URLs if the folder that contains
  263.         the selected item supports them. When the folder's
  264.         IShellFolder::GetAttributesOf method is called to request the selected
  265.         item's attributes, the folder must set the SFGAO_FOLDER attribute flag.
  266.         Otherwise, the browse dialog box will not display the URL. Requires
  267.         v5.0 of SHELL32.DLL
  268.      bfNewDialogStyle: Use the new user-interface. Setting this flag provides
  269.         the user with a larger dialog box that can be resized. It has several
  270.         new capabilities including: drag and drop capability within the dialog
  271.         box, reordering, context menus, new folders, delete, and other context
  272.         menu commands. Requires v5.0 of SHELL32.DLL
  273.      bfShareable: The browse dialog box can display shareable resources on
  274.         remote systems. It is intended for applications that want to expose
  275.         remote shares on a local system. The bfUseNewUI flag must also be set.
  276.         Requires v5.0 of SHELL32.DLL
  277.      bfUseNewUI: Use the new user-interface including an edit box. This flag is
  278.         equivalent to bfEditBox and bfNewDialogStyle. Requires v5.0 of
  279.         SHELL32.DLL
  280.   }
  281.   TBrowseFlag = (
  282.     bfDirectoriesOnly, bfDomainOnly, bfAncestors, bfComputers, bfPrinters,
  283.     bfIncludeFiles, bfEditBox, bfIncludeURLs, bfNewDialogStyle, bfShareable,
  284.     bfUseNewUI
  285.    );
  286.  
  287.   {: A set of TBrowseFlag items. }
  288.   TBrowseFlags = set of TBrowseFlag;
  289.  
  290.   { TBDSelChangedEvent is used for events associated with...
  291.     TdfsBrowseDirectoryDlg's OnSelChanged event.
  292.  
  293.     The Sender parameter is the TdfsBrowseDirectoryDlg object whose event handler...
  294.     is called.  The NewSel parameter is the text representation of the new...
  295.     selection.  The NewSelPIDL is the new PItemIDList representation of the...
  296.     new selection. }
  297.   TBDSelChangedEvent = procedure(Sender: TObject; NewSel: string;
  298.      NewSelPIDL: PItemIDList) of object;
  299.  
  300.   TBDValidateFailedEvent = procedure(Sender: TObject; Path: string;
  301.      var Cancel: boolean) of object;
  302.      
  303. type
  304.   {: TdfsBrowseDirectoryDlg provides a component that displays a standard...
  305.      Windows 95/NT 4 dialog containing the user's system in a heirarchial...
  306.      manner and allows a selection to be made.  It is a wrapper for the...
  307.      SHBrowseForFolder() API, which is quite messy to use directly. }
  308.   TdfsBrowseDirectoryDlg = class(TComponent)
  309.   private
  310.     { Property variables }
  311.     FDlgWnd: HWND;
  312.     FCaption: string;
  313.     FParent: TWinControl;
  314.     FShowSelectionInStatus: boolean;
  315.     FFitStatusText: boolean;
  316.     FTitle: string;
  317.     FRoot: TRootID;
  318.     FOptions: TBrowseFlags;
  319.     FSelection: string;
  320.     FCenter: boolean;
  321.     FStatusText: string;
  322.     FEnableOKButton: boolean;
  323.     FImageIndex: integer;
  324.     FSelChanged: TBDSelChangedEvent;
  325.     FOnCreate: TNotifyEvent;
  326.         FSelectionPIDL: PItemIDList;
  327.     FShellMalloc: IMalloc;
  328.     FDisplayName: string;
  329.     FOnValidateFailed: TBDValidateFailedEvent;
  330.  
  331.         function GetDisplayName: string;
  332.     procedure ShowStatusTextLabel;
  333.   protected
  334.     // internal methods
  335.     function FittedStatusText: string;
  336.     procedure SendSelectionMessage;
  337.     // internal event methods.
  338.     procedure DoInitialized(Wnd: HWND); virtual;
  339.     procedure DoSelChanged(Wnd: HWND; Item: PItemIDList); virtual;
  340.     procedure DoValidateFailed(Path: string; var Cancel: boolean); virtual;
  341.     // property methods
  342.     procedure SetFitStatusText(Val: boolean);
  343.     procedure SetOptions(const Val: TBrowseFlags);
  344.     procedure SetStatusText(const Val: string);
  345.     procedure SetSelection(const Val: string);
  346.         procedure SetSelectionPIDL(Value: PItemIDList);
  347.     procedure SetEnableOKButton(Val: boolean);
  348.     function GetCaption: string;
  349.     procedure SetCaption(const Val: string);
  350.     procedure SetParent(AParent: TWinControl);
  351.     function GetVersion: string;
  352.     procedure SetVersion(const Val: string);
  353.   public
  354.     constructor Create(AOwner: TComponent); override;
  355.     destructor Destroy; override;
  356.     {: Displays the browser folders dialog.  It returns TRUE if user selected...
  357.        an item and pressed OK, otherwise it returns FALSE. }
  358.     function Execute: boolean; virtual;
  359.  
  360.     {: The window component that is the browse dialog's parent window.  By...
  361.        assigning a value to this property, you can control the parent window...
  362.        independant of the form that the component exists on.
  363.  
  364.        You do not normally need to assign any value to this property as it...
  365.        will use the form that contains the component by default. }
  366.     property Parent: TWinControl
  367.        read FParent
  368.        write SetParent;
  369.     {: An alternative to the Selection property.  Use this property if the...
  370.        item you are interested in does not have a path (Control Panels, for...
  371.        example).  The most common way to retrieve a value for this property...
  372.        is to use the SHGetSpecialFolderLocation Windows API function. Once...
  373.        you have assigned a value to this property, it is "owned" by the...
  374.        component.  That is, the component will take care of freeing it when...
  375.        it is no longer needed.
  376.  
  377.        When setting this property before calling the Execute method, it will...
  378.        only be used if the Selection property is blank.  If Selection is not...
  379.        blank, it will be used instead.
  380.  
  381.        Upon return from the Execute method, this property will contain the...
  382.        PItemIDList of the item the user selected.  In some cases, this will...
  383.        the only way to get the user's choice since items such as Control...
  384.        Panel do not have a string that can be placed in the Selection property.}
  385.         property SelectionPIDL: PItemIDList
  386.        read FSelectionPIDL
  387.        write SetSelectionPIDL;
  388.     {: DisplayName is run-time, read-only property that returns the display...
  389.        name of the selection.  It only has meaning after the dialog has been...
  390.        executed and the user has made a selection.  It returns the "human...
  391.        readable" form of the selection.  This generally is the same as the...
  392.        Selection property when it is a file path, but in the case of items...
  393.        such as the Control Panel which do not have a path, Selection is blank.
  394.        In this case, the only way to access the users' selection is to use...
  395.        the SelectionPIDL property.  That doesn't provide an easy way of...
  396.        presenting a textual representation of what they chose, but this...
  397.        property will do that for you.
  398.  
  399.        If, for example, the user chose the Control Panel folder, the Selection...
  400.        property would be blank, but DisplayName would be "Control Panel".  You...
  401.        could not actually use this value to get to the Control Panel, for that...
  402.        you need to use the SelectionPIDL property and various Shell Namespace...
  403.        API functions. }
  404.         property DisplayName: string
  405.        read GetDisplayName;
  406.     {: Handle is a run-time, read-only property that returns the window handle...
  407.        of the browse dialog window.  It is valid only while the dialog is...
  408.        displayed.  That is, it's not valid until the OnCreate event fires, and
  409.        is no longer valid after the Execute method returns. }
  410.     property Handle: HWND
  411.        read FDlgWnd;
  412.   published
  413.     property Version: string
  414.        read GetVersion
  415.        write SetVersion
  416.        stored FALSE;
  417.  
  418.     {: The selected item in the browse folder dialog.
  419.  
  420.        Setting this before calling the Execute method will cause the assigned...
  421.        value to be initially selected when the dialog is initially displayed...
  422.        if the item exists.  If it does not exist, the root item will be selected.
  423.  
  424.        If this value is blank, the SelectionPIDL item will be used instead.
  425.  
  426.        After the Execute method returns, you can read this value to determine...
  427.        what item the user selected, unless that item does not have a string...
  428.        representation (Control Panel, for example). }
  429.     property Selection: string
  430.        read FSelection
  431.        write SetSelection;
  432.     {: Specifies the text to appear at the top of the dialog above the tree...
  433.        control.  There is enough room for two lines of text, and it will be...
  434.        word-wrapped for you automatically.
  435.  
  436.        Generally, this is used to provide user instructions or as a title for
  437.        the StatusText property.
  438.  
  439.        Example:
  440.  
  441.        // Title property set to "The current selection is:"
  442.        procedure TForm1.BrowseDirectoryDlgSelChanged(Sender: TObject; const NewSel: string);
  443.        begin
  444.          // NewSel has the full selection
  445.          BrowseDirectoryDlg.StatusText := NewSel;
  446.        end;
  447.     }
  448.     property Title: string
  449.        read FTitle
  450.        write FTitle;
  451.     {: Specifies the item that is to be treated as the root of the tree...
  452.        display.
  453.  
  454.     idDesktop: Windows desktop -- virtual folder at the root of the name space.
  455.     idInternet: Internet Explorer -- virtual folder of the Internet Explorer.
  456.     idPrograms: File system directory that contains the user's program groups...
  457.        (which are also file system directories).
  458.     idControlPanel: Control Panel -- virtual folder containing icons for the...
  459.        control panel applications.
  460.     idPrinters: Printers folder -- virtual folder containing installed printers.
  461.     idPersonal: File system directory that serves as a common respository for...
  462.        documents.
  463.     idFavorites: Favorites folder -- virtual folder containing the user's...'
  464.        Internet Explorer bookmark items and subfolders.
  465.     idStartup: File system directory that corresponds to the user's Startup...
  466.        program group.
  467.     idRecent: File system directory that contains the user's most recently...
  468.        used documents.
  469.     idSendTo: File system directory that contains Send To menu items.
  470.     idRecycleBin: Recycle bin -- file system directory containing file...
  471.        objects in the user's recycle bin. The location of this directory is...
  472.        not in the registry; it is marked with the hidden and system...
  473.        attributes to prevent the user from moving or deleting it.
  474.     idStartMenu: File system directory containing Start menu items.
  475.     idDesktopDirectory: File system directory used to physically store file...
  476.        objects on the desktop (not to be confused with the desktop folder itself).
  477.     idDrives: My Computer -- virtual folder containing everything on the...
  478.        local computer: storage devices, printers, and Control Panel. The...
  479.        folder may also contain mapped network drives.
  480.     idNetwork: Network Neighborhood -- virtual folder representing the top...
  481.        level of the network hierarchy.
  482.     idNetHood: File system directory containing objects that appear in the...
  483.        network neighborhood.
  484.     idFonts: Virtual folder containing fonts.
  485.     idTemplates: File system directory that serves as a common repository for...
  486.        document templates.
  487.     idCommonStartMenu: File system directory that contains the programs and...
  488.        folders that appear on the Start menu for all users on Windows NT.
  489.     idCommonPrograms: File system directory that contains the directories for...
  490.        the common program groups that appear on the Start menu for all users...
  491.        on Windows NT.
  492.     idCommonStartup: File system directory that contains the programs that...
  493.        appear in the Startup folder for all users. The system starts these...
  494.        programs whenever any user logs on to Windows NT.
  495.     idCommonDesktopDirectory: File system directory that contains files and...
  496.        folders that appear on the desktop for all users on Windows NT.
  497.     idAppData: File system directory that contains data common to all...
  498.        applications.
  499.     idPrintHood: File system directory containing object that appear in the...
  500.        printers folder.
  501.     idDesktopExpanded: Same as idDesktop except that the root item is already...
  502.        expanded when the dialog is initally displayed.
  503.  
  504.     NOTE: idCommonStartMenu, idCommonPrograms, idCommonStartup, and...
  505.        idCommonDesktopDirectory only have effect when the dialog is being...
  506.        displayed on an NT system.  On Windows 95, these values will be...
  507.        mapped to thier "non-common" equivalents, i.e. idCommonPrograms will...
  508.        become idPrograms.
  509.     }
  510.     property Root: TRootID
  511.        read FRoot
  512.        write FRoot
  513.        default idDesktop;
  514.     {: Options is a set of TBrowseFlag items that controls what is allowed to...
  515.        be selected and expanded in the tree.  It can be a combination of any...
  516.        (or none) of the following:
  517.  
  518.      bfDirectoriesOnly: Only returns file system directories. If the user...
  519.         selects folders that are not part of the file system, the OK button...
  520.         is grayed.
  521.      bfDomainOnly: Does not include network folders below the domain level...
  522.         in the dialog.
  523.      bfAncestors: Only returns file system ancestors (items which contain...
  524.         files, like drives).  If the user selects anything other than a file...
  525.         system ancestor, the OK button is grayed.
  526.      bfComputers: Shows other computers.  If anything other than a computer...
  527.         is selected, the OK button is disabled.
  528.      bfPrinters:    Shows all printers.  If anything other than a printers is...
  529.         selected, the OK button is disabled.
  530.      bfIncludeFiles: Show non-folder items that exist in the folders.
  531.      bfEditBox:   Includes an edit control in which the user can type the ...
  532.         of an item.  If the user enters an invalid path, the OnValidateFailed...
  533.         event will fire.  Requires v4.71 of SHELL32.DLL.
  534.      bfIncludeURLs: The browse dialog box can display URLs. The bfUseNewUI and
  535.         bfIncludeFiles flags must also be set. If these three flags are not set,
  536.         the browser dialog box will reject URLs. Even when these flags are set,
  537.         the browse dialog box will only display URLs if the folder that contains
  538.         the selected item supports them. When the folder's
  539.         IShellFolder::GetAttributesOf method is called to request the selected
  540.         item's attributes, the folder must set the SFGAO_FOLDER attribute flag.
  541.         Otherwise, the browse dialog box will not display the URL. Requires
  542.         v5.0 of SHELL32.DLL
  543.      bfNewDialogStyle: Use the new user-interface. Setting this flag provides
  544.         the user with a larger dialog box that can be resized. It has several
  545.         new capabilities including: drag and drop capability within the dialog
  546.         box, reordering, context menus, new folders, delete, and other context
  547.         menu commands. Requires v5.0 of SHELL32.DLL
  548.      bfShareable: The browse dialog box can display shareable resources on
  549.         remote systems. It is intended for applications that want to expose
  550.         remote shares on a local system. The bfUseNewUI flag must also be set.
  551.         Requires v5.0 of SHELL32.DLL
  552.      bfUseNewUI: Use the new user-interface including an edit box. This flag is
  553.         equivalent to bfEditBox and bfNewDialogStyle. Requires v5.0 of
  554.         SHELL32.DLL
  555.     }
  556.     property Options: TBrowseFlags
  557.        read FOptions
  558.        write SetOptions
  559.        default [];
  560.     {: Indicates whether the dialog should be centered on the screen or shown...
  561.       in a default, system-determined location. }
  562.     property Center: boolean
  563.        read FCenter
  564.        write FCenter
  565.        default TRUE;
  566.     {: A string that is displayed directly above the tree view control and...
  567.        just under the Title text in the dialog box. This string can be used...
  568.        for any purpose such as to specify instructions to the user, or show...
  569.        the full path of the currently selected item.  You can modify this...
  570.        value while the dialog is displayed from the the OnSelChanged event.
  571.  
  572.        If StatusText is blank when the Execute method is called, the dialog...
  573.        will not have a status text area and assigning to the StatusText...
  574.        property will have no effect.
  575.  
  576.        Example:
  577.  
  578.        // Title property set to "The current selection is:"
  579.        procedure TForm1.BrowseDirectoryDlgSelChanged(Sender: TObject; const NewSel: string);
  580.        begin
  581.          // NewSel has the full selection
  582.          BrowseDirectoryDlg.StatusText := NewSel;
  583.        end;
  584.        }
  585.     property StatusText: string
  586.        read FStatusText
  587.        write SetStatusText;
  588.     {: Indicates whether the StatusText string should be shortened to make it...
  589.        fit in available status text area.  The status text area is only large...
  590.        enough to hold one line of text, and if the text is too long for the...
  591.        available space, it will simply be chopped off.  However, if this...
  592.        property is set to TRUE, the text will be shortened using an ellipsis...
  593.        ("...").
  594.  
  595.        For example, if the status text property were...
  596.        "C:\Windows\Start Menu\Programs\Applications\Microsoft Reference", it
  597.        could be shortened to...
  598.        "C:\...\Start Menu\Programs\Applications\Microsoft Reference" depending
  599.        on the screen resolution and dialog font size.
  600.     }
  601.     property FitStatusText: boolean
  602.        read FFitStatusText
  603.        write SetFitStatusText
  604.        default TRUE;
  605.     {: This property enables or disables the OK button on the browse folders...
  606.        dialog.  This allows control over whether a selection can be made or...
  607.        not. You can modify this value while the dialog is displayed from the...
  608.        the OnSelChanged event.  This allows you to control whether the user...
  609.        can select an item based on what the current selection is.
  610.  
  611.        Example:
  612.        procedure TForm1.BrowseDirectoryDlgSelChanged(Sender: TObject; const NewSel: string);
  613.        begin
  614.          // NewSel has the full selection.  Only allow items greater than 10 characters to be selected.
  615.          BrowseDirectoryDlg.EnableOKButton := Length(NewSel > 10);
  616.        end;
  617.     }
  618.     property EnableOKButton: boolean
  619.        read FEnableOKButton
  620.        write SetEnableOKButton
  621.        default TRUE;
  622.     {: After a selection has been made in the dialog, this property will...
  623.        contain the index into the system image list of the selected node. See...
  624.        the demo application for an example how this can be used. }
  625.     property ImageIndex: integer
  626.        read FImageIndex;
  627.     {: Specifies the text in the dialog's caption bar. Use Caption to specify...
  628.        the text that appears in the browse folder dialog's title bar. If no...
  629.        value is assigned to Title, the dialog has a title based on the...
  630.        Options property.
  631.  
  632.        For example, if bfPrinters was set, the title would be "Browse for...
  633.        Printer". }
  634.     property Caption: string
  635.        read GetCaption
  636.        write SetCaption;
  637.     {: Automatically shows the current selection in the status text area of...
  638.        the dialog.  }
  639.     property ShowSelectionInStatus: boolean
  640.        read FShowSelectionInStatus
  641.        write FShowSelectionInStatus;
  642.     {: The OnSelChange event is fired every time a new item is selected in...
  643.        the tree.
  644.  
  645.       The Sender parameter is the TdfsBrowseDirectoryDlg object whose event...
  646.       handler is called.  The NewSel parameter is the text representation of...
  647.       the new selection.  The NewSelPIDL is the new PItemIDList...
  648.       representation of the new selection.
  649.  
  650.       NOTE:  You will need to add ShlObj to your uses clause if you define...
  651.       a handler for this event. }
  652.     property OnSelChanged: TBDSelChangedEvent
  653.        read FSelChanged
  654.        write FSelChanged;
  655.     { The OnCreate event is fired when dialog has been created, but just...
  656.        before it is displayed to the user. }
  657.     property OnCreate: TNotifyEvent
  658.        read FOnCreate
  659.        write FOnCreate;
  660.     { If the bfEditBox flag is set in the Options property, the user can type...
  661.       a path into the dialog.  If the path entered is invalid, this event...
  662.       will be fired.  This event is not used if bfEditBox is not specified in...
  663.       Options.  Requires v4.71 of SHELL32.DLL. }
  664.     property OnValidateFailed: TBDValidateFailedEvent
  665.        read FOnValidateFailed
  666.        write FOnValidateFailed;
  667.   end;
  668.  
  669. { Utility function you may find useful }
  670. function DirExists(const Dir: string): boolean;
  671.  
  672. implementation
  673.  
  674. uses
  675.   Forms, SysUtils, Messages, ShellAPI;
  676.  
  677. // Utility functions used to convert from Delphi set types to API constants.
  678. function ConvertRoot(Root: TRootID): integer;
  679. const
  680.   WinNT_RootValues: array[TRootID] of integer = (
  681.     CSIDL_DESKTOP, CSIDL_INTERNET, CSIDL_PROGRAMS, CSIDL_CONTROLS,
  682.     CSIDL_PRINTERS, CSIDL_PERSONAL, CSIDL_FAVORITES, CSIDL_STARTUP,
  683.     CSIDL_RECENT, CSIDL_SENDTO, CSIDL_BITBUCKET, CSIDL_STARTMENU,
  684.     CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES, CSIDL_NETWORK, CSIDL_NETHOOD,
  685.     CSIDL_FONTS, CSIDL_TEMPLATES, CSIDL_COMMON_STARTMENU, CSIDL_COMMON_PROGRAMS,
  686.     CSIDL_COMMON_STARTUP, CSIDL_COMMON_DESKTOPDIRECTORY, CSIDL_APPDATA,
  687.     CSIDL_PRINTHOOD, CSIDL_DESKTOPEXPANDED
  688.   );
  689.   Win95_RootValues: array[TRootID] of integer = (
  690.     CSIDL_DESKTOP, CSIDL_INTERNET, CSIDL_PROGRAMS, CSIDL_CONTROLS,
  691.     CSIDL_PRINTERS, CSIDL_PERSONAL, CSIDL_FAVORITES, CSIDL_STARTUP,
  692.     CSIDL_RECENT, CSIDL_SENDTO, CSIDL_BITBUCKET, CSIDL_STARTMENU,
  693.     CSIDL_DESKTOPDIRECTORY, CSIDL_DRIVES, CSIDL_NETWORK, CSIDL_NETHOOD,
  694.     CSIDL_FONTS, CSIDL_TEMPLATES, CSIDL_STARTMENU, CSIDL_PROGRAMS,
  695.     CSIDL_STARTUP, CSIDL_DESKTOPDIRECTORY, CSIDL_APPDATA, CSIDL_PRINTHOOD,
  696.     CSIDL_DESKTOPEXPANDED
  697.   );
  698. var
  699.   VerInfo: TOSVersionInfo;
  700. begin
  701.   VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  702.   GetVersionEx(VerInfo);
  703.   if VerInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
  704.     Result := WinNT_RootValues[Root]
  705.   else
  706.     Result := Win95_RootValues[Root];
  707. end;
  708.  
  709. function ConvertFlags(Flags: TBrowseFlags): UINT;
  710. const
  711.   FlagValues: array[TBrowseFlag] of UINT = (
  712.     BIF_RETURNONLYFSDIRS, BIF_DONTGOBELOWDOMAIN, BIF_RETURNFSANCESTORS,
  713.     BIF_BROWSEFORCOMPUTER, BIF_BROWSEFORPRINTER, BIF_BROWSEINCLUDEFILES,
  714.     BIF_EDITBOX, BIF_BROWSEINCLUDEURLS, BIF_NEWDIALOGSTYLE, BIF_SHAREABLE,
  715.     BIF_USENEWUI
  716.    );
  717. var
  718.   Opt: TBrowseFlag;
  719. begin
  720.   Result := 0;
  721.   { Loop through all possible values }
  722.   for Opt := Low(TBrowseFlag) to High(TBrowseFlag) do
  723.     if Opt in Flags then
  724.       Result := Result OR FlagValues[Opt];
  725. end;
  726.  
  727. function GetTextWidth(DC: HDC; const Text: String): Integer;
  728. var
  729.   Extent: TSize;
  730. begin
  731.   if GetTextExtentPoint(DC, PChar(Text), Length(Text), Extent) then
  732.     Result := Extent.cX
  733.   else
  734.     Result := 0;
  735. end;
  736.  
  737. function MinimizeName(Wnd: HWND; const Filename: string): string;
  738.  
  739.   procedure CutFirstDirectory(var S: string);
  740.   var
  741.     Root: Boolean;
  742.     P: Integer;
  743.   begin
  744.     if S = '\' then
  745.       S := ''
  746.     else begin
  747.       if S[1] = '\' then begin
  748.         Root := True;
  749.         Delete(S, 1, 1);
  750.       end else
  751.         Root := False;
  752.       if S[1] = '.' then
  753.         Delete(S, 1, 4);
  754.       P := Pos('\',S);
  755.       if P <> 0 then begin
  756.         Delete(S, 1, P);
  757.         S := '...\' + S;
  758.       end else
  759.         S := '';
  760.       if Root then
  761.         S := '\' + S;
  762.     end;
  763.   end;
  764.  
  765. var
  766.   Drive: string;
  767.   Dir: string;
  768.   Name: string;
  769.   R: TRect;
  770.   DC: HDC;
  771.   MaxLen: integer;
  772.   OldFont, Font: HFONT;
  773. begin
  774.   Result := FileName;
  775.   if Wnd = 0 then exit;
  776.   DC := GetDC(Wnd);
  777.   if DC = 0 then exit;
  778.   Font := HFONT(SendMessage(Wnd, WM_GETFONT, 0, 0));
  779.   OldFont := SelectObject(DC, Font);
  780.   try
  781.     GetWindowRect(Wnd, R);
  782.     MaxLen := R.Right - R.Left;
  783.  
  784.     Dir := ExtractFilePath(Result);
  785.     Name := ExtractFileName(Result);
  786.  
  787.     if (Length(Dir) >= 2) and (Dir[2] = ':') then begin
  788.       Drive := Copy(Dir, 1, 2);
  789.       Delete(Dir, 1, 2);
  790.     end else
  791.       Drive := '';
  792.     while ((Dir <> '') or (Drive <> '')) and (GetTextWidth(DC, Result) > MaxLen) do begin
  793.       if Dir = '\...\' then begin
  794.         Drive := '';
  795.         Dir := '...\';
  796.       end else if Dir = '' then
  797.         Drive := ''
  798.       else
  799.         CutFirstDirectory(Dir);
  800.       Result := Drive + Dir + Name;
  801.     end;
  802.   finally
  803.     SelectObject(DC, OldFont);
  804.     ReleaseDC(Wnd, DC);
  805.   end;
  806. end;
  807.  
  808. function MinimizeString(Wnd: HWND; const Text: string): string;
  809. var
  810.   R: TRect;
  811.   DC: HDC;
  812.   MaxLen: integer;
  813.   OldFont, Font: HFONT;
  814.   TempStr: string;
  815. begin
  816.   Result := Text;
  817.   TempStr := Text;
  818.   if Wnd = 0 then exit;
  819.   DC := GetDC(Wnd);
  820.   if DC = 0 then exit;
  821.   Font := HFONT(SendMessage(Wnd, WM_GETFONT, 0, 0));
  822.   OldFont := SelectObject(DC, Font);
  823.   try
  824.     GetWindowRect(Wnd, R);
  825.     MaxLen := R.Right - R.Left;
  826.     while (TempStr <> '') and (GetTextWidth(DC, Result) > MaxLen) do begin
  827.       SetLength(TempStr, Length(TempStr)-1);
  828.       Result := TempStr + '...';
  829.     end;
  830.   finally
  831.     SelectObject(DC, OldFont);
  832.     ReleaseDC(Wnd, DC);
  833.   end;
  834. end;
  835.  
  836.  
  837. function DirExists(const Dir: string): boolean;
  838.   function StripTrailingBackslash(const Dir: string): string;
  839.   begin
  840.     Result := Dir;
  841.     // Make sure we have a string, and if so, see if the last char is a \
  842.     if (Result <> '') and (Result[Length(Result)] = '\') then
  843.       SetLength(Result, Length(Result)-1); // Shorten the length by one to remove
  844.   end;
  845. var
  846.   Tmp: string;
  847.   DriveBits: set of 0..25;
  848.   SR: TSearchRec;
  849.   Found: boolean;
  850.   OldMode: Word;
  851. begin
  852.   OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  853.   try
  854.     if (Length(Dir) = 3) and (Dir[2] = ':') and (Dir[3] = '\') then begin
  855.       Integer(DriveBits) := GetLogicalDrives;
  856.       Tmp := UpperCase(Dir[1]);
  857.       Result := (ord(Tmp[1]) - ord('A')) in DriveBits;
  858.     end else begin
  859.       Found := FindFirst(StripTrailingBackslash(Dir), faDirectory, SR) = 0;
  860.       Result := Found and (Dir <> '');
  861.       if Result then
  862.         Result := (SR.Attr and faDirectory) = faDirectory;
  863.       if Found then
  864.         // only call FinClose if FindFirst succeeds.  Can lock NT up if it didn't
  865.         FindClose(SR);
  866.     end;
  867.   finally
  868.     SetErrorMode(OldMode);
  869.   end;
  870. end; // DirExists
  871.  
  872. function BrowseCallbackProc(Wnd: HWnd; Msg: UINT; lParam: LPARAM; lData: LPARAM): integer; stdcall;
  873. var
  874.   Cancel: boolean;
  875. begin
  876.   Result := 0;
  877.   if lData <> 0 then
  878.   begin
  879.     case Msg of
  880.       BFFM_INITIALIZED:
  881.         TdfsBrowseDirectoryDlg(lData).DoInitialized(Wnd);
  882.       BFFM_SELCHANGED:
  883.         TdfsBrowseDirectoryDlg(lData).DoSelChanged(Wnd, PItemIDList(lParam));
  884.       BFFM_VALIDATEFAILED:
  885.         begin
  886.           Cancel := FALSE;
  887.           TdfsBrowseDirectoryDlg(lData).DoValidateFailed(string(PChar(lParam)),
  888.              Cancel);
  889.           if Cancel then
  890.             Result := 0
  891.           else
  892.             Result := 1;
  893.         end;
  894.     end;
  895.   end;
  896. end;
  897.  
  898.  
  899. (*
  900. function CopyPIDL(ShellMalloc: IMalloc; AnID: PItemIDList): PItemIDList;
  901. var
  902.   Size: integer;
  903. begin
  904.   Size := 0;
  905.   if AnID <> NIL then
  906.   begin
  907.     while AnID.mkid.cb > 0 do
  908.     begin
  909.       Inc(Size, AnID.mkid.cb  + SizeOf(AnID.mkid.cb));
  910.       AnID := PItemIDList(Longint(AnID) + AnID.mkid.cb);
  911.     end;
  912.   end;
  913.  
  914.   if Size > 0 then
  915.   begin
  916.     Result := ShellMalloc.Alloc(Size); // Create the memory
  917.     FillChar(Result^, Size, #0); // Initialize the memory to zero
  918.     Move(AnID^, Result^, Size); // Copy the current ID
  919.   end else
  920.     Result := NIL;
  921. end;
  922. *)
  923.  
  924. function GetImageIndex(const AFile: string): integer;
  925. var
  926.   SFI: TSHFileInfo;
  927. begin
  928.   SHGetFileInfo(PChar(AFile), 0, SFI, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX);
  929.   Result := SFI.iIcon;
  930. end;
  931.  
  932.  
  933. function BrowseDirectory(const ShellMalloc: IMalloc; var Dest: string;
  934.    var DestPIDL: PItemIDList; var ImgIdx: integer; var DisplayName: string;
  935.    const AParent: TWinControl; const Title: string; Root: TRootID;
  936.    Flags: TBrowseFlags; WantStatusText: boolean; Callback: TFNBFFCallBack;
  937.    Data: Longint): boolean;
  938. var
  939.   shBuff: PChar;
  940.   BrowseInfo: TBrowseInfo;
  941.   idRoot, idBrowse: PItemIDList;
  942.   WndHandle: HWND;
  943.   OldErrorMode: word;
  944. begin
  945.   Result := FALSE; // Assume the worst.
  946.   Dest := ''; // Clear it out.
  947.   SetLength(Dest, MAX_PATH);  // Make sure their will be enough room in dest.
  948.   if assigned(AParent) then
  949.     WndHandle := AParent.Handle
  950.   else
  951.     WndHandle := 0;
  952.   shBuff := PChar(ShellMalloc.Alloc(MAX_PATH)); // Shell allocate buffer.
  953.   if assigned(shBuff) then begin
  954.     CoInitialize(NIL);
  955.     try
  956.       // Get id for desired root item.
  957.       SHGetSpecialFolderLocation(WndHandle, ConvertRoot(Root), idRoot);
  958.       try
  959.         with BrowseInfo do begin  // Fill info structure
  960.           hwndOwner := WndHandle;
  961.           pidlRoot := idRoot;
  962.           pszDisplayName := shBuff;
  963.           lpszTitle := PChar(Title);
  964.           ulFlags := ConvertFlags(Flags);
  965.           { See if we need to handle the validate event }
  966.           if bfEditBox in Flags then
  967.             ulFlags := ulFlags or BIF_VALIDATE;
  968.           if WantStatusText then
  969.             ulFlags := ulFlags or BIF_STATUSTEXT;
  970.           lpfn := Callback;
  971.           lParam := Data;
  972.         end;
  973.         OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  974.         try
  975.           idBrowse := SHBrowseForFolder(BrowseInfo);
  976.         finally
  977.           SetErrorMode(OldErrorMode);
  978.         end;
  979.         DestPIDL := idBrowse;
  980.         if assigned(idBrowse) then begin
  981.           // Try to turn it into a real path.
  982.           if (bfComputers in Flags) then
  983.           begin
  984.             { Make a copy because SHGetPathFromIDList will whack it }
  985.             Dest:= '\\' + string(shBuff);
  986.             Result := SHGetPathFromIDList(idBrowse, shBuff);
  987.             { Is it a valid path? }
  988.             if Result then
  989.               Dest := shBuff // Put it in user's variable.
  990.             else
  991.               { do nothing, the copy we made above is set to go };
  992.             Result:= True;
  993.           end else begin
  994.             Result := SHGetPathFromIDList(idBrowse, shBuff);
  995.             Dest := shBuff; // Put it in user's variable.
  996.           end;
  997.           // Stupid thing won't return the index if the user typed it in.
  998.           if Result and (BrowseInfo.iImage = -1) then
  999.             ImgIdx := GetImageIndex(Dest)
  1000.           else
  1001.             ImgIdx := BrowseInfo.iImage; // Update the image index.
  1002.         end;
  1003.         if not Result then
  1004.           Result := DestPIDL <> NIL;
  1005.         if Result then
  1006.           DisplayName := BrowseInfo.pszDisplayName;
  1007.       finally
  1008.         ShellMalloc.Free(idRoot); // Clean-up.
  1009.       end;
  1010.     finally
  1011.       ShellMalloc.Free(shBuff); // Clean-up.
  1012.       CoUninitialize;
  1013.     end;
  1014.   end;
  1015. end;
  1016.  
  1017. constructor TdfsBrowseDirectoryDlg.Create(AOwner: TComponent);
  1018. begin
  1019.   inherited Create(AOwner);
  1020.   FDisplayName := '';
  1021.   FDlgWnd := 0;
  1022.   FFitStatusText := TRUE;
  1023.   FEnableOKButton := TRUE;
  1024.   FTitle := '';
  1025.   FRoot := idDesktop;
  1026.   FOptions := [];
  1027.   FSelection := '';
  1028.   FSelectionPIDL := NIL;
  1029.   FCenter := TRUE;
  1030.   FSelChanged := NIL;
  1031.   FStatusText := '';
  1032.   FImageIndex := -1;
  1033.   FCaption := '';
  1034.   SHGetMalloc(FShellMalloc);
  1035.  
  1036.   if assigned(AOwner) then
  1037.     if AOwner is TWinControl then
  1038.       FParent := TWinControl(Owner)
  1039.     else if assigned(Application) and assigned(Application.MainForm) then
  1040.       FParent := Application.MainForm;
  1041. end;
  1042.  
  1043. destructor TdfsBrowseDirectoryDlg.Destroy;
  1044. begin
  1045.   if assigned(FSelectionPIDL) then
  1046.     FShellMalloc.Free(FSelectionPIDL);
  1047.   // D3 cleans it up for you, D2 does not.
  1048.   {$IFNDEF DFS_NO_COM_CLEANUP} FShellMalloc.Release; {$ENDIF}
  1049.  
  1050.   inherited Destroy;
  1051. end;
  1052.  
  1053. function TdfsBrowseDirectoryDlg.Execute: boolean;
  1054. var
  1055.   S: string;
  1056.   AParent: TWinControl;
  1057.   TempPIDL: PItemIDList;
  1058. begin
  1059.   FDisplayName := '';
  1060.   { Assume the worst }
  1061.   AParent := NIL;
  1062.   if not (csDesigning in ComponentState) then
  1063.     { Determine who the parent is. }
  1064.     if assigned(FParent) then
  1065.       AParent := FParent
  1066.     else begin
  1067.       if assigned(Owner) then
  1068.         if Owner is TWinControl then
  1069.           AParent := TWinControl(Owner)
  1070.         else
  1071.           if assigned(Application) and assigned(Application.MainForm) then
  1072.             AParent := Application.MainForm;
  1073.     end;
  1074.  
  1075.   { Call the function }
  1076.   Result := BrowseDirectory(FShellMalloc, S, TempPIDL, FImageIndex,
  1077.      FDisplayName, AParent, FTitle, FRoot, FOptions,
  1078.      (FStatusText <> '') or FShowSelectionInStatus, BrowseCallbackProc,
  1079.      LongInt(Self));
  1080.  
  1081.   FDlgWnd := 0; { Not valid any more. }
  1082.  
  1083.   { If selection made, update property }
  1084.   if Result then
  1085.   begin
  1086.     FSelection := S;
  1087.     SelectionPIDL := TempPIDL;
  1088.   end else begin
  1089.     FSelection := '';
  1090.     SelectionPIDL := NIL;
  1091.   end;
  1092. end;
  1093.  
  1094. function FormatSelection(const APath: string): string;
  1095. begin
  1096.   Result := APath;
  1097.   if Result <> '' then begin
  1098.     if (Length(Result) < 4) and (Result[2] = ':') then begin
  1099.       if Length(Result) = 2 then
  1100.         Result := Result + '\'
  1101.     end else
  1102.       if (Result[Length(Result)] = '\') and (Result <> '\') then
  1103.         SetLength(Result, Length(Result)-1);
  1104.   end;
  1105. end;
  1106.  
  1107. procedure TdfsBrowseDirectoryDlg.SendSelectionMessage;
  1108. var
  1109.   TempSelectionPIDL: PItemIDList;
  1110.   ShellFolder: IShellFolder;
  1111.   OLEStr: array[0..MAX_PATH] of TOLEChar;
  1112.   Eaten: ULONG;
  1113.   Attr: ULONG;
  1114.   shBuff: PChar;
  1115. begin
  1116.   if (FSelection = '') and assigned(FSelectionPIDL) then
  1117.   begin
  1118.     shBuff := PChar(FShellMalloc.Alloc(MAX_PATH)); // Shell allocate buffer.
  1119.     try
  1120.       if SHGetPathFromIDList(FSelectionPIDL, shBuff) then
  1121.         FSelection := shBuff
  1122.       else
  1123.         FSelection := '';
  1124.     finally
  1125.       FShellMalloc.Free(shBuff); // Clean-up.
  1126.     end;
  1127.     SendMessage(FDlgWnd, BFFM_SETSELECTION, 0, LPARAM(FSelectionPIDL));
  1128.   end else begin
  1129.     if Copy(FSelection, 1, 2) = '\\' then // UNC name!
  1130.     begin
  1131.       if SHGetDesktopFolder(ShellFolder) = NO_ERROR then
  1132.       begin
  1133.         try
  1134.           if ShellFolder.ParseDisplayName(FDlgWnd, NIL,
  1135.              StringToWideChar(FSelection, OLEStr, MAX_PATH), Eaten,
  1136.              TempSelectionPIDL, Attr) = NO_ERROR then
  1137.           begin
  1138.             SelectionPIDL := TempSelectionPIDL;
  1139.             SendMessage(FDlgWnd, BFFM_SETSELECTION, 0, LPARAM(FSelectionPIDL));
  1140.           end;
  1141.         finally
  1142.           {$IFNDEF DFS_NO_COM_CLEANUP} ShellFolder.Release; {$ENDIF}
  1143.         end;
  1144.       end;
  1145.     end else begin { normal path }
  1146.       if SHGetDesktopFolder(ShellFolder) = NO_ERROR then
  1147.       begin
  1148.         try
  1149.           if ShellFolder.ParseDisplayName(FDlgWnd, NIL,
  1150.              StringToWideChar(FSelection, OLEStr, MAX_PATH), Eaten,
  1151.              TempSelectionPIDL, Attr) = NO_ERROR then
  1152.             SelectionPIDL := TempSelectionPIDL;
  1153.         finally
  1154.           {$IFNDEF DFS_NO_COM_CLEANUP} ShellFolder.Release; {$ENDIF}
  1155.         end;
  1156.         SendMessage(FDlgWnd, BFFM_SETSELECTION, 1,
  1157.            LPARAM(FormatSelection(FSelection)));
  1158.       end;
  1159.     end;
  1160.   end;
  1161. end;
  1162.  
  1163. procedure TdfsBrowseDirectoryDlg.DoInitialized(Wnd: HWND);
  1164. var
  1165.   Rect: TRect;
  1166. begin
  1167.   FDlgWnd := Wnd;
  1168.   if FCenter then begin
  1169.     GetWindowRect(Wnd, Rect);
  1170.     SetWindowPos(Wnd, 0,
  1171.       (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
  1172.       (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 2,
  1173.       0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
  1174.   end;
  1175.  
  1176. if [bfNewDialogStyle, bfUseNewUI] * Options <> [] then
  1177.   ShowStatusTextLabel;
  1178.  
  1179.   // Documentation for BFFM_ENABLEOK is incorrect.  Value sent in LPARAM, not WPARAM.
  1180.   SendMessage(FDlgWnd, BFFM_ENABLEOK, 0, LPARAM(FEnableOKButton));
  1181.   if FStatusText <> '' then
  1182.     SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(FittedStatusText)));
  1183.   if (FSelection <> '') or (FSelectionPIDL <> NIL) then
  1184.     SendSelectionMessage;
  1185.   if FCaption <> '' then
  1186.     SendMessage(FDlgWnd, WM_SETTEXT, 0, LPARAM(FCaption));
  1187.   if assigned(FOnCreate) then
  1188.     FOnCreate(Self);
  1189. end;
  1190.  
  1191. procedure TdfsBrowseDirectoryDlg.DoSelChanged(Wnd: HWND; Item: PItemIDList);
  1192. var
  1193.   Name: string;
  1194. begin
  1195.   if FShowSelectionInStatus or assigned(FSelChanged) then
  1196.   begin
  1197.     Name := '';
  1198.     SetLength(Name, MAX_PATH);
  1199.     SHGetPathFromIDList(Item, PChar(Name));
  1200.     SetLength(Name, StrLen(PChar(Name)));
  1201.     if FShowSelectionInStatus then
  1202.       StatusText := Name;
  1203.     if assigned(FSelChanged) then
  1204.       FSelChanged(Self, Name, Item);
  1205.   end;
  1206. end;
  1207.  
  1208. procedure TdfsBrowseDirectoryDlg.DoValidateFailed(Path: string;
  1209.    var Cancel: boolean);
  1210. begin
  1211.   if assigned(FOnValidateFailed) then
  1212.     FOnValidateFailed(Self, Path, Cancel);
  1213. end;
  1214.  
  1215. procedure TdfsBrowseDirectoryDlg.SetFitStatusText(Val: boolean);
  1216. begin
  1217.   if FFitStatusText = Val then exit;
  1218.   FFitStatusText := Val;
  1219.   // Reset the status text area if needed.
  1220.   if FDlgWnd <> 0 then
  1221.     SendMessage(FDlgWnd, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(FittedStatusText)));
  1222. end;
  1223.  
  1224. procedure TdfsBrowseDirectoryDlg.SetStatusText(const Val: string);
  1225. begin
  1226.   if FStatusText = Val then exit;
  1227.   FStatusText := Val;
  1228.   if FDlgWnd <> 0 then
  1229.     SendMessage(FDlgWnd, BFFM_SETSTATUSTEXT, 0, LPARAM(PChar(FittedStatusText)));
  1230. end;
  1231.  
  1232. procedure TdfsBrowseDirectoryDlg.SetSelection(const Val: string);
  1233. begin
  1234.   if FSelection = Val then exit;
  1235.   FSelection := Val;
  1236.   // Add trailing backslash so it looks better in the IDE.
  1237.   if (FSelection <> '') and (FSelection[Length(FSelection)] <> '\') and
  1238.      DirExists(FSelection) then
  1239.     FSelection := FSelection + '\'
  1240.   else if (FSelection = '') and assigned(FSelectionPIDL) then
  1241.   begin
  1242.     FShellMalloc.Free(FSelectionPIDL);
  1243.     FSelectionPIDL := NIL;
  1244.   end;
  1245.   if FShowSelectionInStatus then
  1246.     StatusText := FSelection;
  1247.   if FDlgWnd <> 0 then
  1248.     SendSelectionMessage;
  1249. end;
  1250.  
  1251. procedure TdfsBrowseDirectoryDlg.SetSelectionPIDL(Value: PItemIDList);
  1252. begin
  1253.     if (FSelectionPIDL <> Value) then
  1254.   begin
  1255.     if assigned(FSelectionPIDL) then
  1256.       FShellMalloc.Free(FSelectionPIDL);
  1257.         FSelectionPIDL := Value;
  1258.     end;
  1259. end;
  1260.  
  1261.  
  1262.  
  1263. procedure TdfsBrowseDirectoryDlg.SetEnableOKButton(Val: boolean);
  1264. begin
  1265.   FEnableOKButton := Val;
  1266.   if FDlgWnd <> 0 then
  1267.     // Documentation for BFFM_ENABLEOK is incorrect.  Value sent in LPARAM, not WPARAM.
  1268.     SendMessage(FDlgWnd, BFFM_ENABLEOK, 0, LPARAM(FEnableOKButton));
  1269. end;
  1270.  
  1271. function TdfsBrowseDirectoryDlg.GetCaption: string;
  1272. var
  1273.   Temp: array[0..255] of char;
  1274. begin
  1275.   if FDlgWnd <> 0 then
  1276.   begin
  1277.     SendMessage(FDlgWnd, WM_GETTEXT, SizeOf(Temp), LPARAM(@Temp));
  1278.     Result := string(Temp);
  1279.   end else
  1280.     Result := FCaption;
  1281. end;
  1282.  
  1283. procedure TdfsBrowseDirectoryDlg.SetCaption(const Val: string);
  1284. begin
  1285.   FCaption := Val;
  1286.   if FDlgWnd <> 0 then
  1287.     SendMessage(FDlgWnd, WM_SETTEXT, 0, LPARAM(FCaption));
  1288. end;
  1289.  
  1290. procedure TdfsBrowseDirectoryDlg.SetParent(AParent: TWinControl);
  1291. begin
  1292.   FParent := AParent;
  1293. end;
  1294.  
  1295. // Note that BOOL <> boolean type.  Important!
  1296. function FindStatusTextWndProc(Child: HWND; Data: LParam): BOOL; stdcall;
  1297. const
  1298.   STATUS_TEXT_WINDOW_ID = 14147;
  1299. type
  1300.   PHWND = ^HWND;
  1301. begin
  1302. //  if GetWindowLong(Child, GWL_ID) = STATUS_TEXT_WINDOW_ID then begin
  1303.   if not IsWindowVisible(Child) then
  1304.   begin
  1305. ShowWindow(Child, SW_SHOW);
  1306. EnableWindow(Child, true);
  1307. SendMessage(Child, WM_SETTEXT, 0, LPARAM(PCHAR('foo'))); 
  1308.     PHWND(Data)^ := Child;
  1309.     Result := TRUE;
  1310.   end else
  1311.     Result := TRUE;
  1312. end;
  1313.  
  1314. procedure TdfsBrowseDirectoryDlg.ShowStatusTextLabel;
  1315. var
  1316.   ChildWnd: HWND;
  1317. begin
  1318.   if FDlgWnd <> 0 then
  1319.   begin
  1320.     ChildWnd := 0;
  1321.     if FDlgWnd <> 0 then
  1322.       // Enumerate all child windows of the dialog to find the status text window.
  1323.       EnumChildWindows(FDlgWnd, @FindStatusTextWndProc, LPARAM(@ChildWnd));
  1324.  
  1325.     if (ChildWnd <> 0) then
  1326.       ShowWindow(ChildWnd, SW_SHOW);
  1327.   end;
  1328. end;
  1329.  
  1330. // Note that BOOL <> boolean type.  Important!
  1331. function EnumChildWndProc(Child: HWND; Data: LParam): BOOL; stdcall;
  1332. const
  1333.   STATUS_TEXT_WINDOW_ID = 14147;
  1334. type
  1335.   PHWND = ^HWND;
  1336. begin
  1337.   if GetWindowLong(Child, GWL_ID) = STATUS_TEXT_WINDOW_ID then begin
  1338.     PHWND(Data)^ := Child;
  1339.     Result := FALSE;
  1340.   end else
  1341.     Result := TRUE;
  1342. end;
  1343.  
  1344. function TdfsBrowseDirectoryDlg.FittedStatusText: string;
  1345. var
  1346.   ChildWnd: HWND;
  1347. begin
  1348.   Result := FStatusText;
  1349.   if FFitStatusText then begin
  1350.     ChildWnd := 0;
  1351.     if FDlgWnd <> 0 then
  1352.       // Enumerate all child windows of the dialog to find the status text window.
  1353.       EnumChildWindows(FDlgWnd, @EnumChildWndProc, LPARAM(@ChildWnd));
  1354.     if (ChildWnd <> 0) and (FStatusText <> '') then
  1355.       if DirExists(FStatusText) then
  1356.         Result := MinimizeName(ChildWnd, FStatusText)
  1357.       else
  1358.         Result := MinimizeString(ChildWnd, FStatusText);
  1359.   end;
  1360. end;
  1361.  
  1362. function TdfsBrowseDirectoryDlg.GetDisplayName: string;
  1363. var
  1364.   ShellFolder: IShellFolder;
  1365.   Str : TStrRet;
  1366. begin
  1367.   Result := '';
  1368.   if FSelectionPIDL <> NIL then
  1369.   begin
  1370.     if SHGetDesktopFolder(ShellFolder) = NO_ERROR then
  1371.     begin
  1372.       try
  1373.         if ShellFolder.GetDisplayNameOf(FSelectionPIDL, SHGDN_FORPARSING,
  1374.            Str) = NOERROR then
  1375.         begin
  1376.           case Str.uType of
  1377.             STRRET_WSTR:   Result := WideCharToString(Str.pOleStr);
  1378.             {$IFDEF DFS_COMPILER_4_UP}
  1379.             STRRET_OFFSET: Result := PChar(LongWord(FSelectionPIDL) + Str.uOffset);
  1380.             {$ELSE}
  1381.             STRRET_OFFSET: Result := PChar(Longint(FSelectionPIDL) + Str.uOffset);
  1382.             {$ENDIF}
  1383.             STRRET_CSTR:   Result := Str.cStr;
  1384.           end;
  1385.         end;
  1386.       finally
  1387.         {$IFNDEF DFS_NO_COM_CLEANUP} ShellFolder.Release; {$ENDIF}
  1388.       end;
  1389.     end;
  1390.   end;
  1391.   if Result = '' then
  1392.     Result := FDisplayName;
  1393.   if Result = '' then
  1394.     Result := FSelection;
  1395. end;
  1396.  
  1397. function TdfsBrowseDirectoryDlg.GetVersion: string;
  1398. begin
  1399.   Result := DFS_COMPONENT_VERSION;
  1400. end;
  1401.  
  1402. procedure TdfsBrowseDirectoryDlg.SetVersion(const Val: string);
  1403. begin
  1404.   { empty write method, just needed to get it to show up in Object Inspector }
  1405. end;
  1406.  
  1407. procedure TdfsBrowseDirectoryDlg.SetOptions(const Val: TBrowseFlags);
  1408. begin
  1409.   if FOptions <> Val then
  1410.   begin
  1411.     FOptions := Val;
  1412.     if bfIncludeURLs in FOptions then
  1413.       FOptions := FOptions + [bfIncludeFiles, bfUseNewUI];
  1414.     if bfShareable in FOptions then
  1415.       FOptions := FOptions + [bfUseNewUI];
  1416.     if bfUseNewUI in FOptions then
  1417.       FOptions := FOptions + [bfNewDialogStyle, bfEditBox];
  1418.   end;
  1419. end;
  1420.  
  1421. end.
  1422.