home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Vcl / filectrl.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  53KB  |  2,011 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit FileCtrl;
  11.  
  12. {$R-,T-,H+,X+}
  13.  
  14. interface
  15.  
  16. uses Windows, Messages, SysUtils, Classes, Controls, Graphics, Forms,
  17.   Menus, StdCtrls, Buttons;
  18.  
  19. type
  20.   TFileAttr = (ftReadOnly, ftHidden, ftSystem, ftVolumeID, ftDirectory,
  21.     ftArchive, ftNormal);
  22.   TFileType = set of TFileAttr;
  23.  
  24.   TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
  25.     dtRAM);
  26.  
  27.   TDirectoryListBox = class;
  28.   TFilterComboBox = class;
  29.   TDriveComboBox = class;
  30.  
  31. { TFileListBox }
  32.  
  33.   TFileListBox = class(TCustomListBox)
  34.   private
  35.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  36.     function GetDrive: char;
  37.     function GetFileName: string;
  38.     function IsMaskStored: Boolean;
  39.     procedure SetDrive(Value: char);
  40.     procedure SetFileEdit(Value: TEdit);
  41.     procedure SetDirectory(const NewDirectory: string);
  42.     procedure SetFileType(NewFileType: TFileType);
  43.     procedure SetMask(const NewMask: string);
  44.     procedure SetFileName(const NewFile: string);
  45.     procedure SetShowGlyphs (Value: Boolean);
  46.     procedure ResetItemHeight;
  47.   protected
  48.     FDirectory: string;
  49.     FMask: string;
  50.     FFileType: TFileType;
  51.     FFileEdit: TEdit;
  52.     FDirList: TDirectoryListBox;
  53.     FFilterCombo: TFilterComboBox;
  54.     ExeBMP, DirBMP, UnknownBMP: TBitmap;
  55.     FOnChange: TNotifyEvent;
  56.     FLastSel: Integer;
  57.     FShowGlyphs: Boolean;
  58.     procedure CreateWnd; override;
  59.     procedure ReadBitmaps; virtual;
  60.     procedure Click; override;
  61.     procedure Change; virtual;
  62.     procedure ReadFileNames; virtual;
  63.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);  override;
  64.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  65.     function GetFilePath: string; virtual;
  66.   public
  67.     constructor Create(AOwner: TComponent); override;
  68.     destructor Destroy; override;
  69.     procedure Update; reintroduce;
  70.     procedure ApplyFilePath (const EditText: string); virtual;
  71.     property Drive: char read GetDrive write SetDrive;
  72.     property Directory: string read FDirectory write ApplyFilePath;
  73.     property FileName: string read GetFilePath write ApplyFilePath;
  74.   published
  75.     property Align;
  76.     property Anchors;
  77.     property Color;
  78.     property Constraints;
  79.     property Ctl3D;
  80.     property DragCursor;
  81.     property DragMode;
  82.     property Enabled;
  83.     property ExtendedSelect;
  84.     property FileEdit: TEdit read FFileEdit write SetFileEdit;
  85.     property FileType: TFileType read FFileType write SetFileType default [ftNormal];
  86.     property Font;
  87.     property ImeMode;
  88.     property ImeName;
  89.     property IntegralHeight;
  90.     property ItemHeight;
  91.     property Mask: string read FMask write SetMask stored IsMaskStored;
  92.     property MultiSelect;
  93.     property ParentColor;
  94.     property ParentCtl3D;
  95.     property ParentFont;
  96.     property ParentShowHint;
  97.     property PopupMenu;
  98.     property ShowGlyphs: Boolean read FShowGlyphs write SetShowGlyphs default False;
  99.     property ShowHint;
  100.     property TabOrder;
  101.     property TabStop;
  102.     property Visible;
  103.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  104.     property OnClick;
  105.     property OnContextPopup;
  106.     property OnDblClick;
  107.     property OnDragDrop;
  108.     property OnDragOver;
  109.     property OnEndDrag;
  110.     property OnEnter;
  111.     property OnExit;
  112.     property OnKeyDown;
  113.     property OnKeyPress;
  114.     property OnKeyUp;
  115.     property OnMouseDown;
  116.     property OnMouseMove;
  117.     property OnMouseUp;
  118.     property OnStartDrag;
  119.   end;
  120.  
  121. { TDirectoryListBox }
  122.  
  123.   TDirectoryListBox = class(TCustomListBox)
  124.   private
  125.     FFileList: TFileListBox;
  126.     FDriveCombo: TDriveComboBox;
  127.     FDirLabel: TLabel;
  128.     FInSetDir: Boolean;
  129.     FPreserveCase: Boolean;
  130.     FCaseSensitive: Boolean;
  131.     function GetDrive: char;
  132.     procedure SetFileListBox(Value: TFileListBox);
  133.     procedure SetDirLabel(Value: TLabel);
  134.     procedure SetDirLabelCaption;
  135.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  136.     procedure SetDrive(Value: char);
  137.     procedure DriveChange(NewDrive: Char);
  138.     procedure SetDir(const NewDirectory: string);
  139.     procedure SetDirectory(const NewDirectory: string); virtual;
  140.     procedure ResetItemHeight;
  141.   protected
  142.     ClosedBMP, OpenedBMP, CurrentBMP: TBitmap;
  143.     FDirectory: string;
  144.     FOnChange: TNotifyEvent;
  145.     procedure Change; virtual;
  146.     procedure DblClick; override;
  147.     procedure ReadBitmaps; virtual;
  148.     procedure CreateWnd; override;
  149.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  150.     function  ReadDirectoryNames(const ParentDirectory: string;
  151.       DirectoryList: TStringList): Integer;
  152.     procedure BuildList; virtual;
  153.     procedure KeyPress(var Key: Char); override;
  154.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  155.   public
  156.     constructor Create(AOwner: TComponent); override;
  157.     destructor Destroy; override;
  158.     function  DisplayCase(const S: String): String;
  159.     function  FileCompareText(const A, B: String): Integer;
  160.     function GetItemPath(Index: Integer): string;
  161.     procedure OpenCurrent;
  162.     procedure Update; reintroduce;
  163.     property Drive: Char read GetDrive write SetDrive;
  164.     property Directory: string read FDirectory write SetDirectory;
  165.     property PreserveCase: Boolean read FPreserveCase;
  166.     property CaseSensitive: Boolean read FCaseSensitive;
  167.   published
  168.     property Align;
  169.     property Anchors;
  170.     property Color;
  171.     property Columns;
  172.     property Constraints;
  173.     property Ctl3D;
  174.     property DirLabel: TLabel read FDirLabel write SetDirLabel;
  175.     property DragCursor;
  176.     property DragMode;
  177.     property Enabled;
  178.     property FileList: TFileListBox read FFileList write SetFileListBox;
  179.     property Font;
  180.     property ImeMode;
  181.     property ImeName;
  182.     property IntegralHeight;
  183.     property ItemHeight;
  184.     property ParentColor;
  185.     property ParentCtl3D;
  186.     property ParentFont;
  187.     property ParentShowHint;
  188.     property PopupMenu;
  189.     property ShowHint;
  190.     property TabOrder;
  191.     property TabStop;
  192.     property Visible;
  193.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  194.     property OnClick;
  195.     property OnContextPopup;
  196.     property OnDblClick;
  197.     property OnDragDrop;
  198.     property OnDragOver;
  199.     property OnEndDrag;
  200.     property OnEnter;
  201.     property OnExit;
  202.     property OnKeyDown;
  203.     property OnKeyPress;
  204.     property OnKeyUp;
  205.     property OnMouseDown;
  206.     property OnMouseMove;
  207.     property OnMouseUp;
  208.     property OnStartDrag;
  209.   end;
  210.  
  211. { TDriveComboBox }
  212.  
  213.   TTextCase = (tcLowerCase, tcUpperCase);
  214.  
  215.   TDriveComboBox = class(TCustomComboBox)
  216.   private
  217.     FDirList: TDirectoryListBox;
  218.     FDrive: Char;
  219.     FTextCase: TTextCase;
  220.     procedure SetDirListBox (Value: TDirectoryListBox);
  221.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  222.     procedure SetDrive(NewDrive: Char);
  223.     procedure SetTextCase(NewTextCase: TTextCase);
  224.     procedure ReadBitmaps;
  225.     procedure ResetItemHeight;
  226.   protected
  227.     FloppyBMP, FixedBMP, NetworkBMP, CDROMBMP, RAMBMP: TBitmap;
  228.     procedure CreateWnd; override;
  229.     procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  230.     procedure Click; override;
  231.     procedure BuildList; virtual;
  232.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  233.   public
  234.     constructor Create(AOwner: TComponent); override;
  235.     destructor Destroy; override;
  236.     property Text;
  237.     property Drive: Char read FDrive write SetDrive;
  238.   published
  239.     property Anchors;
  240.     property Color;
  241.     property Constraints;
  242.     property Ctl3D;
  243.     property DirList: TDirectoryListBox read FDirList write SetDirListBox;
  244.     property DragMode;
  245.     property DragCursor;
  246.     property Enabled;
  247.     property Font;
  248.     property ImeMode;
  249.     property ImeName;
  250.     property ParentColor;
  251.     property ParentCtl3D;
  252.     property ParentFont;
  253.     property ParentShowHint;
  254.     property PopupMenu;
  255.     property ShowHint;
  256.     property TabOrder;
  257.     property TabStop;
  258.     property TextCase: TTextCase read FTextCase write SetTextCase default tcLowerCase;
  259.     property Visible;
  260.     property OnChange;
  261.     property OnClick;
  262.     property OnContextPopup;
  263.     property OnDblClick;
  264.     property OnDragDrop;
  265.     property OnDragOver;
  266.     property OnDropDown;
  267.     property OnEndDrag;
  268.     property OnEnter;
  269.     property OnExit;
  270.     property OnKeyDown;
  271.     property OnKeyPress;
  272.     property OnKeyUp;
  273.     property OnStartDrag;
  274.   end;
  275.  
  276. { TFilterComboBox }
  277.  
  278.   TFilterComboBox = class(TCustomComboBox)
  279.   private
  280.     FFilter: string;
  281.     FFileList: TFileListBox;
  282.     MaskList: TStringList;
  283.     function IsFilterStored: Boolean;
  284.     function GetMask: string;
  285.     procedure SetFilter(const NewFilter: string);
  286.     procedure SetFileListBox (Value: TFileListBox);
  287.   protected
  288.     procedure Change; override;
  289.     procedure CreateWnd; override;
  290.     procedure Click; override;
  291.     procedure BuildList;
  292.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  293.   public
  294.     constructor Create(AOwner: TComponent); override;
  295.     destructor Destroy; override;
  296.     property Mask: string read GetMask;
  297.     property Text;
  298.   published
  299.     property Anchors;
  300.     property Color;
  301.     property Constraints;
  302.     property Ctl3D;
  303.     property DragMode;
  304.     property DragCursor;
  305.     property Enabled;
  306.     property FileList: TFileListBox read FFileList write SetFileListBox;
  307.     property Filter: string read FFilter write SetFilter stored IsFilterStored;
  308.     property Font;
  309.     property ImeName;
  310.     property ImeMode;
  311.     property ParentColor;
  312.     property ParentCtl3D;
  313.     property ParentFont;
  314.     property ParentShowHint;
  315.     property PopupMenu;
  316.     property ShowHint;
  317.     property TabOrder;
  318.     property TabStop;
  319.     property Visible;
  320.     property OnChange;
  321.     property OnClick;
  322.     property OnContextPopup;
  323.     property OnDblClick;
  324.     property OnDragDrop;
  325.     property OnDragOver;
  326.     property OnDropDown;
  327.     property OnEndDrag;
  328.     property OnEnter;
  329.     property OnExit;
  330.     property OnKeyDown;
  331.     property OnKeyPress;
  332.     property OnKeyUp;
  333.     property OnStartDrag;
  334.   end;
  335.  
  336. procedure ProcessPath (const EditText: string; var Drive: Char;
  337.   var DirPart: string; var FilePart: string);
  338.  
  339. function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  340.   MaxLen: Integer): TFileName;
  341.  
  342. const
  343.   WNTYPE_DRIVE = 1;  { from WINNET.H, WFW 3.1 SDK }
  344.  
  345. type
  346.   TSelectDirOpt = (sdAllowCreate, sdPerformCreate, sdPrompt);
  347.   TSelectDirOpts = set of TSelectDirOpt;
  348.  
  349. function SelectDirectory(var Directory: string;
  350.   Options: TSelectDirOpts; HelpCtx: Longint): Boolean; overload;
  351. function SelectDirectory(const Caption: string; const Root: WideString;
  352.   out Directory: string): Boolean; overload;
  353. function DirectoryExists(const Name: string): Boolean;
  354. function ForceDirectories(Dir: string): Boolean;
  355.  
  356. implementation
  357.  
  358. uses Consts, Dialogs, ShlObj, ActiveX;
  359.  
  360. {$R FileCtrl}
  361.  
  362. type
  363.  
  364.   TPathLabel = class(TCustomLabel)
  365.   protected
  366.     procedure Paint; override;
  367.   public
  368.     constructor Create(AnOwner: TComponent); override;
  369.   published
  370.     property Alignment;
  371.     property Transparent;
  372.   end;
  373.  
  374. { TSelectDirDlg }
  375.   TSelectDirDlg = class(TForm)
  376.     DirList: TDirectoryListBox;
  377.     DirEdit: TEdit;
  378.     DriveList: TDriveComboBox;
  379.     DirLabel: TPathLabel;
  380.     OKButton: TButton;
  381.     CancelButton: TButton;
  382.     HelpButton: TButton;
  383.     NetButton: TButton;
  384.     FileList: TFileListBox;
  385.     procedure DirListChange(Sender: TObject);
  386.     procedure FormCreate(Sender: TObject);
  387.     procedure DriveListChange(Sender: TObject);
  388.     procedure NetClick(Sender: TObject);
  389.     procedure OKClick(Sender: TObject);
  390.     procedure HelpButtonClick(Sender: TObject);
  391.   private
  392.     { Private declarations }
  393.     FAllowCreate: Boolean;
  394.     FPrompt: Boolean;
  395.     WNetConnectDialog: function (WndParent: HWND; IType: Longint): Longint;
  396.     procedure SetAllowCreate(Value: Boolean);
  397.     procedure SetDirectory(const Value: string);
  398.     function GetDirectory: string;
  399.   public
  400.     { Public declarations }
  401.     constructor Create(AOwner: TComponent); override;
  402.     property Directory: string read GetDirectory write SetDirectory;
  403.     property AllowCreate: Boolean read FAllowCreate write SetAllowCreate default False;
  404.     property Prompt: Boolean read FPrompt write FPrompt default False;
  405.   end;
  406.  
  407. function SlashSep(const Path, S: String): String;
  408. begin
  409.   if AnsiLastChar(Path)^ <> '\' then
  410.     Result := Path + '\' + S
  411.   else
  412.     Result := Path + S;
  413. end;
  414.  
  415. { TPathLabel }
  416.  
  417. constructor TPathLabel.Create(AnOwner: TComponent);
  418. begin
  419.   inherited Create(AnOwner);
  420.   WordWrap := False;
  421.   AutoSize := False;
  422.   ShowAccelChar := False;
  423. end;
  424.  
  425. procedure TPathLabel.Paint;
  426. const
  427.   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  428. var
  429.   Rect: TRect;
  430.   Temp: String;
  431. begin
  432.   with Canvas do
  433.   begin
  434.     Rect := ClientRect;
  435.     if not Transparent then
  436.     begin
  437.       Brush.Color := Self.Color;
  438.       Brush.Style := bsSolid;
  439.       FillRect(Rect);
  440.     end;
  441.     Brush.Style := bsClear;
  442.     Temp := MinimizeName(Caption, Canvas, Rect.Right - Rect.Left);
  443.     DrawText(Canvas.Handle, PChar(Temp), Length(Temp), Rect,
  444.       DT_NOPREFIX or Alignments[Alignment]);
  445.   end;
  446. end;
  447.  
  448. { TDriveComboBox }
  449.  
  450. procedure CutFirstDirectory(var S: TFileName);
  451. var
  452.   Root: Boolean;
  453.   P: Integer;
  454. begin
  455.   if S = '\' then
  456.     S := ''
  457.   else
  458.   begin
  459.     if S[1] = '\' then
  460.     begin
  461.       Root := True;
  462.       Delete(S, 1, 1);
  463.     end
  464.     else
  465.       Root := False;
  466.     if S[1] = '.' then
  467.       Delete(S, 1, 4);
  468.     P := AnsiPos('\',S);
  469.     if P <> 0 then
  470.     begin
  471.       Delete(S, 1, P);
  472.       S := '...\' + S;
  473.     end
  474.     else
  475.       S := '';
  476.     if Root then
  477.       S := '\' + S;
  478.   end;
  479. end;
  480.  
  481. function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  482.   MaxLen: Integer): TFileName;
  483. var
  484.   Drive: TFileName;
  485.   Dir: TFileName;
  486.   Name: TFileName;
  487. begin
  488.   Result := FileName;
  489.   Dir := ExtractFilePath(Result);
  490.   Name := ExtractFileName(Result);
  491.  
  492.   if (Length(Dir) >= 2) and (Dir[2] = ':') then
  493.   begin
  494.     Drive := Copy(Dir, 1, 2);
  495.     Delete(Dir, 1, 2);
  496.   end
  497.   else
  498.     Drive := '';
  499.   while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do
  500.   begin
  501.     if Dir = '\...\' then
  502.     begin
  503.       Drive := '';
  504.       Dir := '...\';
  505.     end
  506.     else if Dir = '' then
  507.       Drive := ''
  508.     else
  509.       CutFirstDirectory(Dir);
  510.     Result := Drive + Dir + Name;
  511.   end;
  512. end;
  513.  
  514. function VolumeID(DriveChar: Char): string;
  515. var
  516.   OldErrorMode: Integer;
  517.   NotUsed, VolFlags: DWORD;
  518.   Buf: array [0..MAX_PATH] of Char;
  519. begin
  520.   OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  521.   try
  522.     Buf[0] := #$00;
  523.     if GetVolumeInformation(PChar(DriveChar + ':\'), Buf, DWORD(sizeof(Buf)),
  524.       nil, NotUsed, VolFlags, nil, 0) then
  525.       SetString(Result, Buf, StrLen(Buf))
  526.     else Result := '';  
  527.     if DriveChar < 'a' then
  528.       Result := AnsiUpperCaseFileName(Result)
  529.     else
  530.       Result := AnsiLowerCaseFileName(Result);
  531.     Result := Format('[%s]',[Result]);
  532.   finally
  533.     SetErrorMode(OldErrorMode);
  534.   end;
  535. end;
  536.  
  537. function NetworkVolume(DriveChar: Char): string;
  538. var
  539.   Buf: Array [0..MAX_PATH] of Char;
  540.   DriveStr: array [0..3] of Char;
  541.   BufferSize: DWORD;
  542. begin
  543.   BufferSize := sizeof(Buf);
  544.   DriveStr[0] := UpCase(DriveChar);
  545.   DriveStr[1] := ':';
  546.   DriveStr[2] := #0;
  547.   if WNetGetConnection(DriveStr, Buf, BufferSize) = WN_SUCCESS then
  548.   begin
  549.     SetString(Result, Buf, BufferSize);
  550.     if DriveChar < 'a' then
  551.       Result := AnsiUpperCaseFileName(Result)
  552.     else
  553.       Result := AnsiLowerCaseFileName(Result);
  554.   end
  555.   else
  556.     Result := VolumeID(DriveChar);
  557. end;
  558.  
  559. procedure ProcessPath (const EditText: string; var Drive: Char;
  560.   var DirPart: string; var FilePart: string);
  561. var
  562.   SaveDir, Root: string;
  563. begin
  564.   GetDir(0, SaveDir);
  565.   Drive := SaveDir[1];
  566.   DirPart := EditText;
  567.   if (DirPart[1] = '[') and (AnsiLastChar(DirPart)^ = ']') then
  568.     DirPart := Copy(DirPart, 2, Length(DirPart) - 2)
  569.   else
  570.   begin
  571.     Root := ExtractFileDrive(DirPart);
  572.     if Length(Root) = 0 then
  573.       Root := ExtractFileDrive(SaveDir)
  574.     else
  575.       Delete(DirPart, 1, Length(Root));
  576.     if (Length(Root) >= 2) and (Root[2] = ':') then
  577.       Drive := Root[1]
  578.     else
  579.       Drive := #0;
  580.   end;
  581.  
  582.   try
  583.     if DirectoryExists(Root) then
  584.       ChDir(Root);
  585.     FilePart := ExtractFileName (DirPart);
  586.     if Length(DirPart) = (Length(FilePart) + 1) then
  587.       DirPart := '\'
  588.     else if Length(DirPart) > Length(FilePart) then
  589.       SetLength(DirPart, Length(DirPart) - Length(FilePart) - 1)
  590.     else
  591.     begin
  592.       GetDir(0, DirPart);
  593.       Delete(DirPart, 1, Length(ExtractFileDrive(DirPart)));
  594.       if Length(DirPart) = 0 then
  595.         DirPart := '\';
  596.     end;
  597.     if Length(DirPart) > 0 then
  598.       ChDir (DirPart);  {first go to our new directory}
  599.     if (Length(FilePart) > 0) and not
  600.        (((Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0)) or
  601.        FileExists(FilePart)) then
  602.     begin
  603.       ChDir(FilePart);
  604.       if Length(DirPart) = 1 then
  605.         DirPart := '\' + FilePart
  606.       else
  607.         DirPart := DirPart + '\' + FilePart;
  608.       FilePart := '';
  609.     end;
  610.     if Drive = #0 then
  611.       DirPart := Root + DirPart;
  612.   finally
  613.     if DirectoryExists(SaveDir) then
  614.       ChDir(SaveDir);  { restore original directory }
  615.   end;
  616. end;
  617.  
  618. function GetItemHeight(Font: TFont): Integer;
  619. var
  620.   DC: HDC;
  621.   SaveFont: HFont;
  622.   Metrics: TTextMetric;
  623. begin
  624.   DC := GetDC(0);
  625.   SaveFont := SelectObject(DC, Font.Handle);
  626.   GetTextMetrics(DC, Metrics);
  627.   SelectObject(DC, SaveFont);
  628.   ReleaseDC(0, DC);
  629.   Result := Metrics.tmHeight;
  630. end;
  631.  
  632. { TDriveComboBox }
  633.  
  634. constructor TDriveComboBox.Create(AOwner: TComponent);
  635. var
  636.   Temp: ShortString;
  637. begin
  638.   inherited Create(AOwner);
  639.   Style := csOwnerDrawFixed;
  640.   ReadBitmaps;
  641.   GetDir(0, Temp);
  642.   FDrive := Temp[1]; { make default drive selected }
  643.   if FDrive = '\' then FDrive := #0;
  644.   ResetItemHeight;
  645. end;
  646.  
  647. destructor TDriveComboBox.Destroy;
  648. begin
  649.   FloppyBMP.Free;
  650.   FixedBMP.Free;
  651.   NetworkBMP.Free;
  652.   CDROMBMP.Free;
  653.   RAMBMP.Free;
  654.   inherited Destroy;
  655. end;
  656.  
  657. procedure TDriveComboBox.BuildList;
  658. var
  659.   DriveNum: Integer;
  660.   DriveChar: Char;
  661.   DriveType: TDriveType;
  662.   DriveBits: set of 0..25;
  663.  
  664.   procedure AddDrive(const VolName: string; Obj: TObject);
  665.   begin
  666.     Items.AddObject(Format('%s: %s',[DriveChar, VolName]), Obj);
  667.   end;
  668.  
  669. begin
  670.   { fill list }
  671.   Clear;
  672.   Integer(DriveBits) := GetLogicalDrives;
  673.   for DriveNum := 0 to 25 do
  674.   begin
  675.     if not (DriveNum in DriveBits) then Continue;
  676.     DriveChar := Char(DriveNum + Ord('a'));
  677.     DriveType := TDriveType(GetDriveType(PChar(DriveChar + ':\')));
  678.     if TextCase = tcUpperCase then
  679.       DriveChar := Upcase(DriveChar);
  680.  
  681.     case DriveType of
  682.       dtFloppy:   Items.AddObject(DriveChar + ':', FloppyBMP);
  683.       dtFixed:    AddDrive(VolumeID(DriveChar), FixedBMP);
  684.       dtNetwork:  AddDrive(NetworkVolume(DriveChar), NetworkBMP);
  685.       dtCDROM:    AddDrive(VolumeID(DriveChar), CDROMBMP);
  686.       dtRAM:      AddDrive(VolumeID(DriveChar), RAMBMP);
  687.     end;
  688.   end;
  689. end;
  690.  
  691. procedure TDriveComboBox.SetDrive(NewDrive: Char);
  692. var
  693.   Item: Integer;
  694.   drv: string;
  695. begin
  696.   if (ItemIndex < 0) or (UpCase(NewDrive) <> UpCase(FDrive)) then
  697.   begin
  698.     if NewDrive = #0 then
  699.     begin
  700.       FDrive := NewDrive;
  701.       ItemIndex := -1;
  702.     end
  703.     else
  704.     begin
  705.       if TextCase = tcUpperCase then
  706.         FDrive := UpCase(NewDrive)
  707.       else
  708.         FDrive := Chr(ord(UpCase(NewDrive)) + 32);
  709.  
  710.       { change selected item }
  711.       for Item := 0 to Items.Count - 1 do
  712.       begin
  713.         drv := Items[Item];
  714.         if (UpCase(drv[1]) = UpCase(FDrive)) and (drv[2] = ':') then
  715.         begin
  716.           ItemIndex := Item;
  717.           break;
  718.         end;
  719.       end;
  720.     end;
  721.     if FDirList <> nil then FDirList.DriveChange(Drive);
  722.     Change;
  723.   end;
  724. end;
  725.  
  726. procedure TDriveComboBox.SetTextCase(NewTextCase: TTextCase);
  727. var
  728.   OldDrive: Char;
  729. begin
  730.   FTextCase := NewTextCase;
  731.   OldDrive := FDrive;
  732.   BuildList;
  733.   SetDrive (OldDrive);
  734. end;
  735.  
  736. procedure TDriveComboBox.SetDirListBox (Value: TDirectoryListBox);
  737. begin
  738.   if FDirList <> nil then FDirList.FDriveCombo := nil;
  739.   FDirList := Value;
  740.   if FDirList <> nil then
  741.   begin
  742.     FDirList.FDriveCombo := Self;
  743.     FDirList.FreeNotification(Self);
  744.   end;
  745. end;
  746.  
  747. procedure TDriveComboBox.CreateWnd;
  748. begin
  749.   inherited CreateWnd;
  750.   BuildList;
  751.   SetDrive (FDrive);
  752. end;
  753.  
  754. procedure TDriveComboBox.DrawItem(Index: Integer; Rect: TRect;
  755.   State: TOwnerDrawState);
  756. var
  757.   Bitmap: TBitmap;
  758.   bmpWidth: Integer;
  759. begin
  760.   with Canvas do
  761.   begin
  762.     FillRect(Rect);
  763.     bmpWidth  := 16;
  764.     Bitmap := TBitmap(Items.Objects[Index]);
  765.     if Bitmap <> nil then
  766.     begin
  767.       bmpWidth := Bitmap.Width;
  768.       BrushCopy(Bounds(Rect.Left + 2,
  769.                (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
  770.                Bitmap.Width, Bitmap.Height),
  771.                Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
  772.                Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
  773.     end;
  774.      { uses DrawText instead of TextOut in order to get clipping against
  775.        the combo box button   }
  776.     Rect.Left := Rect.Left + bmpWidth + 6;
  777.     DrawText(Canvas.Handle, PChar(Items[Index]), -1, Rect,
  778.              DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  779.   end;
  780. end;
  781.  
  782. procedure TDriveComboBox.Click;
  783. begin
  784.   inherited Click;
  785.   if ItemIndex >= 0 then
  786.     Drive := Items[ItemIndex][1];
  787. end;
  788.  
  789. procedure TDriveComboBox.CMFontChanged(var Message: TMessage);
  790. begin
  791.   inherited;
  792.   ResetItemHeight;
  793.   RecreateWnd;
  794. end;
  795.  
  796. procedure TDriveComboBox.ResetItemHeight;
  797. var
  798.   nuHeight: Integer;
  799. begin
  800.   nuHeight :=  GetItemHeight(Font);
  801.   if nuHeight < (FloppyBMP.Height) then nuHeight := FloppyBmp.Height;
  802.   ItemHeight := nuHeight;
  803. end;
  804.  
  805. procedure TDriveComboBox.ReadBitmaps;
  806. begin
  807.   { assign bitmap glyphs }
  808.   FloppyBMP := TBitmap.Create;
  809.   FloppyBMP.Handle := LoadBitmap(HInstance, 'FLOPPY');
  810.   FixedBMP := TBitmap.Create;
  811.   FixedBMP.Handle := LoadBitmap(HInstance, 'HARD');
  812.   NetworkBMP := TBitmap.Create;
  813.   NetworkBMP.Handle := LoadBitmap(HInstance, 'NETWORK');
  814.   CDROMBMP := TBitmap.Create;
  815.   CDROMBMP.Handle := LoadBitmap(HInstance, 'CDROM');
  816.   RAMBMP := TBitmap.Create;
  817.   RAMBMP.Handle := LoadBitmap(HInstance, 'RAM');
  818. end;
  819.  
  820. procedure TDriveComboBox.Notification(AComponent: TComponent;
  821.   Operation: TOperation);
  822. begin
  823.   inherited Notification(AComponent, Operation);
  824.   if (Operation = opRemove) and (AComponent = FDirList) then
  825.     FDirList := nil;
  826. end;
  827.  
  828. { TDirectoryListBox }
  829.  
  830. function DirLevel(const PathName: string): Integer;  { counts '\' in path }
  831. var
  832.   P: PChar;
  833. begin
  834.   Result := 0;
  835.   P := AnsiStrScan(PChar(PathName), '\');
  836.   while P <> nil do
  837.   begin
  838.     Inc(Result);
  839.     Inc(P);
  840.     P := AnsiStrScan(P, '\');
  841.   end;
  842. end;
  843.  
  844. constructor TDirectoryListBox.Create(AOwner: TComponent);
  845. begin
  846.   inherited Create(AOwner);
  847.   Width := 145;
  848.   Style := lbOwnerDrawFixed;
  849.   Sorted := False;
  850.   ReadBitmaps;
  851.   GetDir(0, FDirectory); { initially use current dir on default drive }
  852.   ResetItemHeight;
  853. end;
  854.  
  855. destructor TDirectoryListBox.Destroy;
  856. begin
  857.   ClosedBMP.Free;
  858.   OpenedBMP.Free;
  859.   CurrentBMP.Free;
  860.   inherited Destroy;
  861. end;
  862.  
  863. procedure TDirectoryListBox.DriveChange(NewDrive: Char);
  864. begin
  865.   if (UpCase(NewDrive) <> UpCase(Drive)) then
  866.   begin
  867.     if NewDrive <> #0 then
  868.     begin
  869.       ChDir(NewDrive + ':');
  870.       GetDir(0, FDirectory);  { store correct directory name }
  871.     end;
  872.     if not FInSetDir then
  873.     begin
  874.       BuildList;
  875.       Change;
  876.     end;
  877.   end;
  878. end;
  879.  
  880. procedure TDirectoryListBox.SetFileListBox (Value: TFileListBox);
  881. begin
  882.   if FFileList <> nil then FFileList.FDirList := nil;
  883.   FFileList := Value;
  884.   if FFileList <> nil then
  885.   begin
  886.     FFileList.FDirList := Self;
  887.     FFileList.FreeNotification(Self);
  888.   end;
  889. end;
  890.  
  891. procedure TDirectoryListBox.SetDirLabel (Value: TLabel);
  892. begin
  893.   FDirLabel := Value;
  894.   if Value <> nil then Value.FreeNotification(Self);
  895.   SetDirLabelCaption;
  896. end;
  897.  
  898. procedure TDirectoryListBox.SetDir(const NewDirectory: string);
  899. begin
  900.      { go to old directory first, in case of incomplete pathname
  901.        and curdir changed - probably not necessary }
  902.   if DirectoryExists(FDirectory) then
  903.     ChDir(FDirectory);
  904.   ChDir(NewDirectory);     { exception raised if invalid dir }
  905.   GetDir(0, FDirectory);   { store correct directory name }
  906.   BuildList;
  907.   Change;
  908. end;
  909.  
  910. procedure TDirectoryListBox.OpenCurrent;
  911. begin
  912.   Directory := GetItemPath(ItemIndex);
  913. end;
  914.  
  915. procedure TDirectoryListBox.Update;
  916. begin
  917.   BuildList;
  918.   Change;
  919. end;
  920.  
  921. function TDirectoryListBox.DisplayCase(const S: String): String;
  922. begin
  923.   if FPreserveCase or FCaseSensitive then
  924.     Result := S
  925.   else
  926.     Result := AnsiLowerCase(S);
  927. end;
  928.  
  929. function TDirectoryListBox.FileCompareText(const A,B: String): Integer;
  930. begin
  931.   if FCaseSensitive then
  932.     Result := AnsiCompareStr(A,B)
  933.   else
  934.     Result := AnsiCompareFileName(A,B);
  935. end;
  936.  
  937.   {
  938.     Reads all directories in ParentDirectory, adds their paths to
  939.     DirectoryList,and returns the number added
  940.   }
  941. function TDirectoryListbox.ReadDirectoryNames(const ParentDirectory: string;
  942.   DirectoryList: TStringList): Integer;
  943. var
  944.   Status: Integer;
  945.   SearchRec: TSearchRec;
  946. begin
  947.   Result := 0;
  948.   Status := FindFirst(SlashSep(ParentDirectory, '*.*'), faDirectory, SearchRec);
  949.   try
  950.     while Status = 0 do
  951.     begin
  952.       if (SearchRec.Attr and faDirectory = faDirectory) then
  953.       begin
  954.         if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
  955.         begin
  956.           DirectoryList.Add(SearchRec.Name);
  957.           Inc(Result);
  958.         end;
  959.       end;
  960.       Status := FindNext(SearchRec);
  961.     end;
  962.   finally
  963.     FindClose(SearchRec);
  964.   end;
  965. end;
  966.  
  967. procedure TDirectoryListBox.BuildList;
  968. var
  969.   TempPath: string;
  970.   DirName: string;
  971.   IndentLevel, BackSlashPos: Integer;
  972.   VolFlags: DWORD;
  973.   I: Integer;
  974.   Siblings: TStringList;
  975.   NewSelect: Integer;
  976.   Root: string;
  977. begin
  978.   try
  979.     Items.BeginUpdate;
  980.     Items.Clear;
  981.     IndentLevel := 0;
  982.     Root := ExtractFileDrive(Directory)+'\';
  983.     GetVolumeInformation(PChar(Root), nil, 0, nil, DWORD(i), VolFlags, nil, 0);
  984.     FPreserveCase := VolFlags and (FS_CASE_IS_PRESERVED or FS_CASE_SENSITIVE) <> 0;
  985.     FCaseSensitive := (VolFlags and FS_CASE_SENSITIVE) <> 0;
  986.     if (Length(Root) >= 2) and (Root[2] = '\') then
  987.     begin
  988.       Items.AddObject(Root, OpenedBMP);
  989.       Inc(IndentLevel);
  990.       TempPath := Copy(Directory, Length(Root)+1, Length(Directory));
  991.     end
  992.     else
  993.       TempPath := Directory;
  994.     if (Length(TempPath) > 0) then
  995.     begin
  996.       if AnsiLastChar(TempPath)^ <> '\' then
  997.       begin
  998.         BackSlashPos := AnsiPos('\', TempPath);
  999.         while BackSlashPos <> 0 do
  1000.         begin
  1001.           DirName := Copy(TempPath, 1, BackSlashPos - 1);
  1002.           if IndentLevel = 0 then DirName := DirName + '\';
  1003.           Delete(TempPath, 1, BackSlashPos);
  1004.           Items.AddObject(DirName, OpenedBMP);
  1005.           Inc(IndentLevel);
  1006.           BackSlashPos := AnsiPos('\', TempPath);
  1007.         end;
  1008.       end;
  1009.       Items.AddObject(TempPath, CurrentBMP);
  1010.     end;
  1011.     NewSelect := Items.Count - 1;
  1012.     Siblings := TStringList.Create;
  1013.     try
  1014.       Siblings.Sorted := True;
  1015.         { read all the dir names into Siblings }
  1016.       ReadDirectoryNames(Directory, Siblings);
  1017.       for i := 0 to Siblings.Count - 1 do
  1018.         Items.AddObject(Siblings[i], ClosedBMP);
  1019.     finally
  1020.       Siblings.Free;
  1021.     end;
  1022.   finally
  1023.     Items.EndUpdate;
  1024.   end;
  1025.   if HandleAllocated then
  1026.     ItemIndex := NewSelect;
  1027. end;
  1028.  
  1029. procedure TDirectoryListBox.ReadBitmaps;
  1030. begin
  1031.   OpenedBMP := TBitmap.Create;
  1032.   OpenedBMP.LoadFromResourceName(HInstance, 'OPENFOLDER');
  1033.   ClosedBMP := TBitmap.Create;
  1034.   ClosedBMP.LoadFromResourceName(HInstance, 'CLOSEDFOLDER');
  1035.   CurrentBMP := TBitmap.Create;
  1036.   CurrentBMP.LoadFromResourceName(HInstance, 'CURRENTFOLDER');
  1037. end;
  1038.  
  1039. procedure TDirectoryListBox.DblClick;
  1040. begin
  1041.   inherited DblClick;
  1042.   OpenCurrent;
  1043. end;
  1044.  
  1045. procedure TDirectoryListBox.Change;
  1046. begin
  1047.   if FFileList <> nil then FFileList.SetDirectory(Directory);
  1048.   SetDirLabelCaption;
  1049.   if Assigned(FOnChange) then FOnChange(Self);
  1050. end;
  1051.  
  1052. procedure TDirectoryListBox.DrawItem(Index: Integer; Rect: TRect;
  1053.   State: TOwnerDrawState);
  1054. var
  1055.   Bitmap: TBitmap;
  1056.   bmpWidth: Integer;
  1057.   dirOffset: Integer;
  1058. begin
  1059.   with Canvas do
  1060.   begin
  1061.     FillRect(Rect);
  1062.     bmpWidth  := 16;
  1063.     dirOffset := Index * 4 + 2;    {add 2 for spacing}
  1064.  
  1065.     Bitmap := TBitmap(Items.Objects[Index]);
  1066.     if Bitmap <> nil then
  1067.     begin
  1068.       if Bitmap = ClosedBMP then
  1069.         dirOffset := (DirLevel (Directory) + 1) * 4 + 2;
  1070.  
  1071.       bmpWidth := Bitmap.Width;
  1072.       BrushCopy(Bounds(Rect.Left + dirOffset,
  1073.                (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
  1074.                Bitmap.Width, Bitmap.Height),
  1075.                Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
  1076.                Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
  1077.     end;
  1078.     TextOut(Rect.Left + bmpWidth + dirOffset + 4, Rect.Top, DisplayCase(Items[Index]))
  1079.   end;
  1080. end;
  1081.  
  1082. function TDirectoryListBox.GetItemPath (Index: Integer): string;
  1083. var
  1084.   CurDir: string;
  1085.   i, j: Integer;
  1086.   Bitmap: TBitmap;
  1087. begin
  1088.   Result := '';
  1089.   if Index < Items.Count then
  1090.   begin
  1091.     CurDir := Directory;
  1092.     Bitmap := TBitmap(Items.Objects[Index]);
  1093.     if Index = 0 then
  1094.       Result := ExtractFileDrive(CurDir)+'\'
  1095.     else if Bitmap = ClosedBMP then
  1096.       Result := SlashSep(CurDir,Items[Index])
  1097.     else if Bitmap = CurrentBMP then
  1098.       Result := CurDir
  1099.     else
  1100.     begin
  1101.       i   := 0;
  1102.       j   := 0;
  1103.       Delete(CurDir, 1, Length(ExtractFileDrive(CurDir)));
  1104.       while j <> (Index + 1) do
  1105.       begin
  1106.         Inc(i);
  1107.         if i > Length (CurDir) then
  1108.           break;
  1109.         if CurDir[i] in LeadBytes then
  1110.           Inc(i)
  1111.         else if CurDir[i] = '\' then
  1112.           Inc(j);
  1113.       end;
  1114.       Result := ExtractFileDrive(Directory) + Copy(CurDir, 1, i - 1);
  1115.     end;
  1116.   end;
  1117. end;
  1118.  
  1119. procedure TDirectoryListBox.CreateWnd;
  1120. begin
  1121.   inherited CreateWnd;
  1122.   BuildList;
  1123.   ItemIndex := DirLevel (Directory);
  1124. end;
  1125.  
  1126. procedure TDirectoryListBox.CMFontChanged(var Message: TMessage);
  1127. begin
  1128.   inherited;
  1129.   ResetItemHeight;
  1130. end;
  1131.  
  1132. procedure TDirectoryListBox.ResetItemHeight;
  1133. var
  1134.   nuHeight: Integer;
  1135. begin
  1136.   nuHeight :=  GetItemHeight(Font);
  1137.   if nuHeight < (OpenedBMP.Height + 1) then nuHeight := OpenedBmp.Height + 1;
  1138.   ItemHeight := nuHeight;
  1139. end;
  1140.  
  1141. function TDirectoryListBox.GetDrive: char;
  1142. begin
  1143.   Result := FDirectory[1];
  1144. end;
  1145.  
  1146. procedure TDirectoryListBox.SetDrive(Value: char);
  1147. begin
  1148.   if (UpCase(Value) <> UpCase(Drive)) then
  1149.     SetDirectory (Format ('%s:', [Value]));
  1150. end;
  1151.  
  1152. procedure TDirectoryListBox.SetDirectory(const NewDirectory: string);
  1153. var
  1154.   DirPart: string;
  1155.   FilePart: string;
  1156.   NewDrive: Char;
  1157. begin
  1158.   if Length (NewDirectory) = 0 then Exit;
  1159.   if (FileCompareText(NewDirectory, Directory) = 0) then Exit;
  1160.   ProcessPath (NewDirectory, NewDrive, DirPart, FilePart);
  1161.   try
  1162.     if Drive <> NewDrive then
  1163.     begin
  1164.       FInSetDir := True;
  1165.       if (FDriveCombo <> nil) then
  1166.         FDriveCombo.Drive := NewDrive
  1167.       else
  1168.         DriveChange(NewDrive);
  1169.     end;
  1170.   finally
  1171.     FInSetDir := False;
  1172.   end;
  1173.   SetDir(DirPart);
  1174. end;
  1175.  
  1176. procedure TDirectoryListBox.KeyPress(var Key: Char);
  1177. begin
  1178.   inherited KeyPress(Key);
  1179.   if (Word(Key) = VK_RETURN) then
  1180.     OpenCurrent;
  1181. end;
  1182.  
  1183. procedure TDirectoryListBox.Notification(AComponent: TComponent;
  1184.   Operation: TOperation);
  1185. begin
  1186.   inherited Notification(AComponent, Operation);
  1187.   if (Operation = opRemove) then
  1188.   begin
  1189.     if (AComponent = FFileList) then FFileList := nil
  1190.     else if (AComponent = FDriveCombo) then FDriveCombo := nil
  1191.     else if (AComponent = FDirLabel) then FDirLabel := nil;
  1192.   end;
  1193. end;
  1194.  
  1195. procedure TDirectoryListBox.SetDirLabelCaption;
  1196. var
  1197.   DirWidth: Integer;
  1198. begin
  1199.   if FDirLabel <> nil then
  1200.   begin
  1201.     DirWidth := Width;
  1202.     if not FDirLabel.AutoSize then DirWidth := FDirLabel.Width;
  1203.     FDirLabel.Caption := MinimizeName(Directory, FDirLabel.Canvas, DirWidth);
  1204.   end;
  1205. end;
  1206.  
  1207. { TFileListBox }
  1208.  
  1209. const
  1210.   DefaultMask = '*.*';
  1211.  
  1212. constructor TFileListBox.Create(AOwner: TComponent);
  1213. begin
  1214.   inherited Create(AOwner);
  1215.   Width := 145;
  1216. {  IntegralHeight := True; }
  1217.   FFileType := [ftNormal]; { show only normal files by default }
  1218.   GetDir(0, FDirectory); { initially use current dir on default drive }
  1219.  
  1220.   FMask := DefaultMask;  { default file mask is all }
  1221.   MultiSelect := False;    { default is not multi-select }
  1222.   FLastSel := -1;
  1223.   ReadBitmaps;
  1224.   Sorted := True;
  1225.   Style := lbOwnerDrawFixed;
  1226.   ResetItemHeight;
  1227. end;
  1228.  
  1229. destructor TFileListBox.Destroy;
  1230. begin
  1231.   ExeBMP.Free;
  1232.   DirBMP.Free;
  1233.   UnknownBMP.Free;
  1234.   inherited Destroy;
  1235. end;
  1236.  
  1237. procedure TFileListBox.Update;
  1238. begin
  1239.   ReadFileNames;
  1240. end;
  1241.  
  1242. procedure TFileListBox.CreateWnd;
  1243. begin
  1244.   inherited CreateWnd;
  1245.   ReadFileNames;
  1246. end;
  1247.  
  1248. function TFileListBox.IsMaskStored: Boolean;
  1249. begin
  1250.   Result := DefaultMask <> FMask;
  1251. end;
  1252.  
  1253. function TFileListBox.GetDrive: char;
  1254. begin
  1255.   Result := FDirectory[1];
  1256. end;
  1257.  
  1258. procedure TFileListBox.ReadBitmaps;
  1259. begin
  1260.   ExeBMP := TBitmap.Create;
  1261.   ExeBMP.Handle := LoadBitmap(HInstance, 'EXECUTABLE');
  1262.   DirBMP := TBitmap.Create;
  1263.   DirBMP.Handle := LoadBitmap(HInstance, 'CLOSEDFOLDER');
  1264.   UnknownBMP := TBitmap.Create;
  1265.   UnknownBMP.Handle := LoadBitmap(HInstance, 'UNKNOWNFILE');
  1266. end;
  1267.  
  1268. procedure TFileListBox.ReadFileNames;
  1269. var
  1270.   AttrIndex: TFileAttr;
  1271.   I: Integer;
  1272.   FileExt: string;
  1273.   MaskPtr: PChar;
  1274.   Ptr: PChar;
  1275.   AttrWord: Word;
  1276.   FileInfo: TSearchRec;
  1277.   SaveCursor: TCursor;
  1278.   Glyph: TBitmap;
  1279. const
  1280.    Attributes: array[TFileAttr] of Word = (faReadOnly, faHidden, faSysFile,
  1281.      faVolumeID, faDirectory, faArchive, 0);
  1282. begin
  1283.       { if no handle allocated yet, this call will force
  1284.         one to be allocated incorrectly (i.e. at the wrong time.
  1285.         In due time, one will be allocated appropriately.  }
  1286.   AttrWord := DDL_READWRITE;
  1287.   if HandleAllocated then
  1288.   begin
  1289.     { Set attribute flags based on values in FileType }
  1290.     for AttrIndex := ftReadOnly to ftArchive do
  1291.       if AttrIndex in FileType then
  1292.         AttrWord := AttrWord or Attributes[AttrIndex];
  1293.  
  1294.     ChDir(FDirectory); { go to the directory we want }
  1295.     Clear; { clear the list }
  1296.  
  1297.     I := 0;
  1298.     SaveCursor := Screen.Cursor;
  1299.     try
  1300.       MaskPtr := PChar(FMask);
  1301.       while MaskPtr <> nil do
  1302.       begin
  1303.         Ptr := StrScan (MaskPtr, ';');
  1304.         if Ptr <> nil then
  1305.           Ptr^ := #0;
  1306.         if FindFirst(MaskPtr, AttrWord, FileInfo) = 0 then
  1307.         begin
  1308.           repeat            { exclude normal files if ftNormal not set }
  1309.             if (ftNormal in FileType) or (FileInfo.Attr and AttrWord <> 0) then
  1310.               if FileInfo.Attr and faDirectory <> 0 then
  1311.               begin
  1312.                 I := Items.Add(Format('[%s]',[FileInfo.Name]));
  1313.                 if ShowGlyphs then
  1314.                   Items.Objects[I] := DirBMP;
  1315.               end
  1316.               else
  1317.               begin
  1318.                 FileExt := AnsiLowerCase(ExtractFileExt(FileInfo.Name));
  1319.                 Glyph := UnknownBMP;
  1320.                 if (FileExt = '.exe') or (FileExt = '.com') or
  1321.                   (FileExt = '.bat') or (FileExt = '.pif') then
  1322.                   Glyph := ExeBMP;
  1323.                 I := Items.AddObject(FileInfo.Name, Glyph);
  1324.               end;
  1325.             if I = 100 then
  1326.               Screen.Cursor := crHourGlass;
  1327.           until FindNext(FileInfo) <> 0;
  1328.           FindClose(FileInfo);
  1329.         end;
  1330.         if Ptr <> nil then
  1331.         begin
  1332.           Ptr^ := ';';
  1333.           Inc (Ptr);
  1334.         end;
  1335.         MaskPtr := Ptr;
  1336.       end;
  1337.     finally
  1338.       Screen.Cursor := SaveCursor;
  1339.     end;
  1340.     Change;
  1341.   end;
  1342. end;
  1343.  
  1344. procedure TFileListBox.Click;
  1345. begin
  1346.   inherited Click;
  1347.   if FLastSel <> ItemIndex then
  1348.      Change;
  1349. end;
  1350.  
  1351. procedure TFileListBox.Change;
  1352. begin
  1353.   FLastSel := ItemIndex;
  1354.   if FFileEdit <> nil then
  1355.   begin
  1356.     if Length(GetFileName) = 0 then
  1357.       FileEdit.Text := Mask
  1358.     else
  1359.       FileEdit.Text := GetFileName;
  1360.     FileEdit.SelectAll;
  1361.   end;
  1362.   if Assigned(FOnChange) then FOnChange(Self);
  1363. end;
  1364.  
  1365. procedure TFileListBox.SetShowGlyphs(Value: Boolean);
  1366. begin
  1367.   if FShowGlyphs <> Value then
  1368.   begin
  1369.     FShowGlyphs := Value;
  1370.     if (FShowGlyphs = True) and (ItemHeight < (ExeBMP.Height + 1)) then
  1371.       ResetItemHeight;
  1372.     Invalidate;
  1373.   end;
  1374. end;
  1375.  
  1376. function TFileListBox.GetFileName: string;
  1377. var
  1378.   idx: Integer;
  1379. begin
  1380.       { if multi-select is turned on, then using ItemIndex
  1381.         returns a bogus value if nothing is selected   }
  1382.   idx  := ItemIndex;
  1383.   if (idx < 0)  or  (Items.Count = 0)  or  (Selected[idx] = FALSE)  then
  1384.     Result  := ''
  1385.   else
  1386.     Result  := Items[idx];
  1387. end;
  1388.  
  1389. procedure TFileListBox.SetFileName(const NewFile: string);
  1390. begin
  1391.   if AnsiCompareFileName(NewFile, GetFileName) <> 0 then
  1392.   begin
  1393.     ItemIndex := SendMessage(Handle, LB_FindStringExact, 0,
  1394.       Longint(PChar(NewFile)));
  1395.     Change;
  1396.   end;
  1397. end;
  1398.  
  1399. procedure TFileListBox.SetFileEdit(Value: TEdit);
  1400. begin
  1401.   FFileEdit := Value;
  1402.   if FFileEdit <> nil then
  1403.   begin
  1404.     FFileEdit.FreeNotification(Self);
  1405.     if GetFileName <> '' then
  1406.       FFileEdit.Text := GetFileName
  1407.     else
  1408.       FFileEdit.Text := Mask;
  1409.   end;
  1410. end;
  1411.  
  1412. procedure TFileListBox.DrawItem(Index: Integer; Rect: TRect;
  1413.   State: TOwnerDrawState);
  1414. var
  1415.   Bitmap: TBitmap;
  1416.   offset: Integer;
  1417. begin
  1418.   with Canvas do
  1419.   begin
  1420.     FillRect(Rect);
  1421.     offset := 2;
  1422.     if ShowGlyphs then
  1423.     begin
  1424.       Bitmap := TBitmap(Items.Objects[Index]);
  1425.       if Assigned(Bitmap) then
  1426.       begin
  1427.         BrushCopy(Bounds(Rect.Left + 2,
  1428.                   (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
  1429.                   Bitmap.Width, Bitmap.Height),
  1430.                   Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
  1431.                   Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
  1432.         offset := Bitmap.width + 6;
  1433.       end;
  1434.     end;
  1435.     TextOut(Rect.Left + offset, Rect.Top, Items[Index])
  1436.   end;
  1437. end;
  1438.  
  1439. procedure TFileListBox.SetDrive(Value: char);
  1440. begin
  1441.   if (UpCase(Value) <> UpCase(FDirectory[1])) then
  1442.     ApplyFilePath (Format ('%s:', [Value]));
  1443. end;
  1444.  
  1445. procedure TFileListBox.SetDirectory(const NewDirectory: string);
  1446. begin
  1447.   if AnsiCompareFileName(NewDirectory, FDirectory) <> 0 then
  1448.   begin
  1449.        { go to old directory first, in case not complete pathname
  1450.          and curdir changed - probably not necessary }
  1451.     if DirectoryExists(FDirectory) then
  1452.       ChDir(FDirectory);
  1453.     ChDir(NewDirectory);     { exception raised if invalid dir }
  1454.     GetDir(0, FDirectory);   { store correct directory name }
  1455.     ReadFileNames;
  1456.   end;
  1457. end;
  1458.  
  1459. procedure TFileListBox.SetFileType(NewFileType: TFileType);
  1460. begin
  1461.   if NewFileType <> FFileType then
  1462.   begin
  1463.     FFileType := NewFileType;
  1464.     ReadFileNames;
  1465.   end;
  1466. end;
  1467.  
  1468. procedure TFileListBox.SetMask(const NewMask: string);
  1469. begin
  1470.   if FMask <> NewMask then
  1471.   begin
  1472.     FMask := NewMask;
  1473.     ReadFileNames;
  1474.   end;
  1475. end;
  1476.  
  1477. procedure TFileListBox.CMFontChanged(var Message: TMessage);
  1478. begin
  1479.   inherited;
  1480.   ResetItemHeight;
  1481. end;
  1482.  
  1483. procedure TFileListBox.ResetItemHeight;
  1484. var
  1485.   nuHeight: Integer;
  1486. begin
  1487.   nuHeight :=  GetItemHeight(Font);
  1488.   if (FShowGlyphs = True) and (nuHeight < (ExeBMP.Height + 1)) then
  1489.     nuHeight := ExeBmp.Height + 1;
  1490.   ItemHeight := nuHeight;
  1491. end;
  1492.  
  1493. procedure TFileListBox.ApplyFilePath(const EditText: string);
  1494. var
  1495.   DirPart: string;
  1496.   FilePart: string;
  1497.   NewDrive: Char;
  1498. begin
  1499.   if AnsiCompareFileName(FileName, EditText) = 0 then Exit;
  1500.   if Length (EditText) = 0 then Exit;
  1501.   ProcessPath (EditText, NewDrive, DirPart, FilePart);
  1502.   if FDirList <> nil then
  1503.     FDirList.Directory := EditText
  1504.   else
  1505.     if NewDrive <> #0 then
  1506.       SetDirectory(Format('%s:%s', [NewDrive, DirPart]))
  1507.     else
  1508.       SetDirectory(DirPart);
  1509.   if (Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0) then
  1510.     SetMask (FilePart)
  1511.   else if Length(FilePart) > 0 then
  1512.   begin
  1513.     SetFileName (FilePart);
  1514.     if FileExists (FilePart) then
  1515.     begin
  1516.       if GetFileName = '' then
  1517.       begin
  1518.         SetMask(FilePart);
  1519.         SetFileName (FilePart);
  1520.       end;
  1521.     end
  1522.     else
  1523.       raise EInvalidOperation.CreateFmt(SInvalidFileName, [EditText]);
  1524.   end;
  1525. end;
  1526.  
  1527. function TFileListBox.GetFilePath: string;
  1528. begin
  1529.   Result := '';
  1530.   if GetFileName <> '' then
  1531.     Result := SlashSep(FDirectory, GetFileName);
  1532. end;
  1533.  
  1534. procedure TFileListBox.Notification(AComponent: TComponent;
  1535.   Operation: TOperation);
  1536. begin
  1537.   inherited Notification(AComponent, Operation);
  1538.   if (Operation = opRemove) then
  1539.   begin
  1540.     if (AComponent = FFileEdit) then FFileEdit := nil
  1541.     else if (AComponent = FDirList) then FDirList := nil
  1542.     else if (AComponent = FFilterCombo) then FFilterCombo := nil;
  1543.   end;
  1544. end;
  1545.  
  1546. { TFilterComboBox }
  1547.  
  1548. constructor TFilterComboBox.Create(AOwner: TComponent);
  1549. begin
  1550.   inherited Create(AOwner);
  1551.   Style := csDropDownList;
  1552.   FFilter := SDefaultFilter;
  1553.   MaskList := TStringList.Create;
  1554. end;
  1555.  
  1556. destructor TFilterComboBox.Destroy;
  1557. begin
  1558.   MaskList.Free;
  1559.   inherited Destroy;
  1560. end;
  1561.  
  1562. procedure TFilterComboBox.CreateWnd;
  1563. begin
  1564.   inherited CreateWnd;
  1565.   BuildList;
  1566. end;
  1567.  
  1568. function TFilterComboBox.IsFilterStored: Boolean;
  1569. begin
  1570.   Result := SDefaultFilter <> FFilter;
  1571. end;
  1572.  
  1573. procedure TFilterComboBox.SetFilter(const NewFilter: string);
  1574. begin
  1575.   if AnsiCompareFileName(NewFilter, FFilter) <> 0 then
  1576.   begin
  1577.     FFilter := NewFilter;
  1578.     if HandleAllocated then BuildList;
  1579.     Change;
  1580.   end;
  1581. end;
  1582.  
  1583. procedure TFilterComboBox.SetFileListBox (Value: TFileListBox);
  1584. begin
  1585.   if FFileList <> nil then FFileList.FFilterCombo := nil;
  1586.   FFileList := Value;
  1587.   if FFileList <> nil then
  1588.   begin
  1589.     FFileList.FreeNotification(Self);
  1590.     FFileList.FFilterCombo := Self;
  1591.   end;
  1592. end;
  1593.  
  1594. procedure TFilterComboBox.Click;
  1595. begin
  1596.   inherited Click;
  1597.   Change;
  1598. end;
  1599.  
  1600. function TFilterComboBox.GetMask: string;
  1601. begin
  1602.   if ItemIndex < 0 then
  1603.     ItemIndex := Items.Count - 1;
  1604.  
  1605.   if ItemIndex >= 0 then
  1606.   begin
  1607.      Result := MaskList[ItemIndex];
  1608.   end
  1609.   else
  1610.      Result := '*.*';
  1611. end;
  1612.  
  1613. procedure TFilterComboBox.BuildList;
  1614. var
  1615.   AFilter, MaskName, Mask: string;
  1616.   BarPos: Integer;
  1617. begin
  1618.   Clear;
  1619.   MaskList.Clear;
  1620.   AFilter := Filter;
  1621.   BarPos := AnsiPos('|', AFilter);
  1622.   while BarPos <> 0 do
  1623.   begin
  1624.     MaskName := Copy(AFilter, 1, BarPos - 1);
  1625.     Delete(AFilter, 1, BarPos);
  1626.     BarPos := AnsiPos('|', AFilter);
  1627.     if BarPos > 0 then
  1628.     begin
  1629.       Mask := Copy(AFilter, 1, BarPos - 1);
  1630.       Delete(AFilter, 1, BarPos);
  1631.     end
  1632.     else
  1633.     begin
  1634.       Mask := AFilter;
  1635.       AFilter := '';
  1636.     end;
  1637.     Items.Add(MaskName);
  1638.     MaskList.Add(Mask);
  1639.     BarPos := AnsiPos('|', AFilter);
  1640.   end;
  1641.   ItemIndex := 0;
  1642. end;
  1643.  
  1644. procedure TFilterComboBox.Notification(AComponent: TComponent;
  1645.   Operation: TOperation);
  1646. begin
  1647.   inherited Notification(AComponent, Operation);
  1648.   if (Operation = opRemove) and (AComponent = FFileList) then
  1649.     FFileList := nil;
  1650. end;
  1651.  
  1652. procedure TFilterComboBox.Change;
  1653. begin
  1654.   if FFileList <> nil then FFileList.Mask := Mask;
  1655.   inherited Change;
  1656. end;
  1657.  
  1658. { TSelectDirDlg }
  1659. constructor TSelectDirDlg.Create(AOwner: TComponent);
  1660. begin
  1661.   inherited CreateNew(AOwner);
  1662.   Caption := SSelectDirCap;
  1663.   BorderStyle := bsDialog;
  1664.   ClientWidth := 424;
  1665.   ClientHeight := 255;
  1666.   Position := poScreenCenter;
  1667.  
  1668.   DirEdit := TEdit.Create(Self);
  1669.   with DirEdit do
  1670.   begin
  1671.     Parent := Self;
  1672.     SetBounds(8, 24, 313, 20);
  1673.     Visible := False;
  1674.     TabOrder := 1;
  1675.   end;
  1676.  
  1677.   with TLabel.Create(Self) do
  1678.   begin
  1679.     Parent := Self;
  1680.     SetBounds(8, 8, 92, 13);
  1681.     FocusControl := DirEdit;
  1682.     Caption := SDirNameCap;
  1683.   end;
  1684.  
  1685.   DriveList := TDriveComboBox.Create(Self);
  1686.   with DriveList do
  1687.   begin
  1688.     Parent := Self;
  1689.     SetBounds(232, 192, 185, 19);
  1690.     TabOrder := 2;
  1691.     OnChange := DriveListChange;
  1692.   end;
  1693.  
  1694.   with TLabel.Create(Self) do
  1695.   begin
  1696.     Parent := Self;
  1697.     SetBounds(232, 176, 41, 13);
  1698.     Caption := SDrivesCap;
  1699.     FocusControl := DriveList;
  1700.   end;
  1701.  
  1702.   DirLabel := TPathLabel.Create(Self);
  1703.   with DirLabel do
  1704.   begin
  1705.     Parent := Self;
  1706.     SetBounds(120, 8, 213, 13);
  1707.   end;
  1708.  
  1709.   DirList := TDirectoryListBox.Create(Self);
  1710.   with DirList do
  1711.   begin
  1712.     Parent := Self;
  1713.     SetBounds(8, 72, 213, 138);
  1714.     TabOrder := 0;
  1715.     TabStop := True;
  1716.     ItemHeight := 17;
  1717.     IntegralHeight := True;
  1718.     OnChange := DirListChange;
  1719.   end;
  1720.  
  1721.   with TLabel.Create(Self) do
  1722.   begin
  1723.     Parent := Self;
  1724.     SetBounds(8, 56, 66, 13);
  1725.     Caption := SDirsCap;
  1726.     FocusControl := DirList;
  1727.   end;
  1728.  
  1729.   FileList := TFileListBox.Create(Self);
  1730.   with FileList do
  1731.   begin
  1732.     Parent := Self;
  1733.     SetBounds(232, 72, 185, 93);
  1734.     TabOrder := 6;
  1735.     TabStop := True;
  1736.     FileType := [ftNormal];
  1737.     Mask := '*.*';
  1738.     Font.Color := clGrayText;
  1739.     ItemHeight := 13;
  1740.   end;
  1741.  
  1742.   with TLabel.Create(Self) do
  1743.   begin
  1744.     Parent := Self;
  1745.     SetBounds(232, 56, 57, 13);
  1746.     Caption := SFilesCap;
  1747.     FocusControl := FileList;
  1748.   end;
  1749.  
  1750.   NetButton := TButton.Create(Self);
  1751.   with NetButton do
  1752.   begin
  1753.     Parent := Self;
  1754.     SetBounds(8, 224, 77, 27);
  1755.     Visible := False;
  1756.     TabOrder := 3;
  1757.     Caption := SNetworkCap;
  1758.     OnClick := NetClick;
  1759.   end;
  1760.  
  1761.   OKButton := TButton.Create(Self);
  1762.   with OKButton do
  1763.   begin
  1764.     Parent := Self;
  1765.     SetBounds(172, 224, 77, 27);
  1766.     TabOrder := 4;
  1767.     OnClick := OKClick;
  1768.     Caption := SOKButton;
  1769.     ModalResult := 1;
  1770.     Default := True;
  1771.   end;
  1772.  
  1773.   CancelButton := TButton.Create(Self);
  1774.   with CancelButton do
  1775.   begin
  1776.     Parent := Self;
  1777.     SetBounds(256, 224, 77, 27);
  1778.     TabOrder := 5;
  1779.     Cancel := True;
  1780.     Caption := SCancelButton;
  1781.     ModalResult := 2;
  1782.   end;
  1783.  
  1784.   HelpButton := TButton.Create(Self);
  1785.   with HelpButton do
  1786.   begin
  1787.     Parent := Self;
  1788.     SetBounds(340, 224, 77, 27);
  1789.     TabOrder := 7;
  1790.     Caption := SHelpButton;
  1791.     OnClick := HelpButtonClick;
  1792.   end;
  1793.  
  1794.   FormCreate(Self);
  1795.   ActiveControl := DirList;
  1796. end;
  1797.  
  1798. procedure TSelectDirDlg.HelpButtonClick(Sender: TObject);
  1799. begin
  1800.   Application.HelpContext(HelpContext);
  1801. end;
  1802.  
  1803. procedure TSelectDirDlg.DirListChange(Sender: TObject);
  1804. begin
  1805.   DirLabel.Caption := DirList.Directory;
  1806.   FileList.Directory := DirList.Directory;
  1807.   DirEdit.Text := DirLabel.Caption;
  1808.   DirEdit.SelectAll;
  1809. end;
  1810.  
  1811. procedure TSelectDirDlg.FormCreate(Sender: TObject);
  1812. var
  1813.   UserHandle: THandle;
  1814.   NetDriver: THandle;
  1815.   WNetGetCaps: function (Flags: Word): Word;
  1816. begin
  1817.   { is network access enabled? }
  1818.   UserHandle := GetModuleHandle(User32);
  1819.   @WNetGetCaps := GetProcAddress(UserHandle, 'WNETGETCAPS');
  1820.   if @WNetGetCaps <> nil then
  1821.   begin
  1822.     NetDriver := WNetGetCaps(Word(-1));
  1823.     if NetDriver <> 0 then
  1824.     begin
  1825.       @WNetConnectDialog := GetProcAddress(NetDriver, 'WNETCONNECTDIALOG');
  1826.       NetButton.Visible := @WNetConnectDialog <> nil;
  1827.     end;
  1828.   end;
  1829.  
  1830.   FAllowCreate := False;
  1831.   DirLabel.BoundsRect := DirEdit.BoundsRect;
  1832.   DirListChange(Self);
  1833. end;
  1834.  
  1835. procedure TSelectDirDlg.DriveListChange(Sender: TObject);
  1836. begin
  1837.   DirList.Drive := DriveList.Drive;
  1838. end;
  1839.  
  1840. procedure TSelectDirDlg.SetAllowCreate(Value: Boolean);
  1841. begin
  1842.   if Value <> FAllowCreate then
  1843.   begin
  1844.     FAllowCreate := Value;
  1845.     DirLabel.Visible := not FAllowCreate;
  1846.     DirEdit.Visible := FAllowCreate;
  1847.   end;
  1848. end;
  1849.  
  1850. procedure TSelectDirDlg.SetDirectory(const Value: string);
  1851. var
  1852.   Temp: string;
  1853. begin
  1854.   if Value <> '' then
  1855.   begin
  1856.     Temp := ExpandFileName(SlashSep(Value,'*.*'));
  1857.     if (Length(Temp) >= 3) and (Temp[2] = ':') then
  1858.     begin
  1859.       DriveList.Drive := Temp[1];
  1860.       Temp := ExtractFilePath(Temp);
  1861.       try
  1862.         DirList.Directory := Copy(Temp, 1, Length(Temp) - 1);
  1863.       except
  1864.         on EInOutError do
  1865.         begin
  1866.           GetDir(0, Temp);
  1867.           DriveList.Drive := Temp[1];
  1868.           DirList.Directory := Temp;
  1869.         end;
  1870.       end;
  1871.     end;
  1872.   end;
  1873. end;
  1874.  
  1875. function TSelectDirDlg.GetDirectory: string;
  1876. begin
  1877.   if FAllowCreate then
  1878.     Result := DirEdit.Text
  1879.   else
  1880.     Result := DirLabel.Caption;
  1881. end;
  1882.  
  1883. procedure TSelectDirDlg.NetClick(Sender: TObject);
  1884. begin
  1885.   if Assigned(WNetConnectDialog) then
  1886.     WNetConnectDialog(Handle, WNTYPE_DRIVE);
  1887. end;
  1888.  
  1889. procedure TSelectDirDlg.OKClick(Sender: TObject);
  1890. begin
  1891.   if AllowCreate and Prompt and (not DirectoryExists(Directory)) and
  1892.     (MessageDlg(SConfirmCreateDir, mtConfirmation, [mbYes, mbNo],
  1893.       0) <> mrYes) then
  1894.     ModalResult := 0;
  1895. end;
  1896.  
  1897. function SelectDirectory(var Directory: string;
  1898.   Options: TSelectDirOpts; HelpCtx: Longint): Boolean;
  1899. var
  1900.   D: TSelectDirDlg;
  1901. begin
  1902.   D := TSelectDirDlg.Create(Application);
  1903.   try
  1904.     D.Directory := Directory;
  1905.     D.AllowCreate := sdAllowCreate in Options;
  1906.     D.Prompt := sdPrompt in Options;
  1907.  
  1908.     { scale to screen res }
  1909.     if Screen.PixelsPerInch <> 96 then
  1910.     begin
  1911.       D.ScaleBy(Screen.PixelsPerInch, 96);
  1912.       D.FileList.ParentFont := True;
  1913.       D.Left := (Screen.Width div 2) - (D.Width div 2);
  1914.       D.Top := (Screen.Height div 2) - (D.Height div 2);
  1915.       D.FileList.Font.Color := clGrayText;
  1916.     end;
  1917.  
  1918.     if HelpCtx = 0 then
  1919.     begin
  1920.       D.HelpButton.Visible := False;
  1921.       D.OKButton.Left := D.CancelButton.Left;
  1922.       D.CancelButton.Left := D.HelpButton.Left;
  1923.     end
  1924.     else D.HelpContext := HelpCtx;
  1925.  
  1926.     Result := D.ShowModal = mrOK;
  1927.     if Result then
  1928.     begin
  1929.       Directory := D.Directory;
  1930.       if sdPerformCreate in Options then
  1931.         ForceDirectories(Directory);
  1932.     end;
  1933.   finally
  1934.     D.Free;
  1935.   end;
  1936. end;
  1937.  
  1938. function SelectDirectory(const Caption: string; const Root: WideString;
  1939.   out Directory: string): Boolean;
  1940. var
  1941.   WindowList: Pointer;
  1942.   BrowseInfo: TBrowseInfo;
  1943.   Buffer: PChar;
  1944.   RootItemIDList, ItemIDList: PItemIDList;
  1945.   ShellMalloc: IMalloc;
  1946.   IDesktopFolder: IShellFolder;
  1947.   Eaten, Flags: LongWord;
  1948. begin
  1949.   Result := False;
  1950.   Directory := '';
  1951.   FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  1952.   if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  1953.   begin
  1954.     Buffer := ShellMalloc.Alloc(MAX_PATH);
  1955.     try
  1956.       RootItemIDList := nil;
  1957.       if Root <> '' then
  1958.       begin
  1959.         SHGetDesktopFolder(IDesktopFolder);
  1960.         IDesktopFolder.ParseDisplayName(Application.Handle, nil,
  1961.           POleStr(Root), Eaten, RootItemIDList, Flags);
  1962.       end;
  1963.       with BrowseInfo do
  1964.       begin
  1965.         hwndOwner := Application.Handle;
  1966.         pidlRoot := RootItemIDList;
  1967.         pszDisplayName := Buffer;
  1968.         lpszTitle := PChar(Caption);
  1969.         ulFlags := BIF_RETURNONLYFSDIRS;
  1970.       end;
  1971.       WindowList := DisableTaskWindows(0);
  1972.       try
  1973.         ItemIDList := ShBrowseForFolder(BrowseInfo);
  1974.       finally
  1975.         EnableTaskWindows(WindowList);
  1976.       end;
  1977.       Result :=  ItemIDList <> nil;
  1978.       if Result then
  1979.       begin
  1980.         ShGetPathFromIDList(ItemIDList, Buffer);
  1981.         ShellMalloc.Free(ItemIDList);
  1982.         Directory := Buffer;
  1983.       end;
  1984.     finally
  1985.       ShellMalloc.Free(Buffer);
  1986.     end;
  1987.   end;
  1988. end;
  1989.  
  1990. function DirectoryExists(const Name: string): Boolean;
  1991. var
  1992.   Code: Integer;
  1993. begin
  1994.   Code := GetFileAttributes(PChar(Name));
  1995.   Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
  1996. end;
  1997.  
  1998. function ForceDirectories(Dir: string): Boolean;
  1999. begin
  2000.   Result := True;
  2001.   if Length(Dir) = 0 then
  2002.     raise Exception.CreateRes(@SCannotCreateDir);
  2003.   Dir := ExcludeTrailingBackslash(Dir);
  2004.   if (Length(Dir) < 3) or DirectoryExists(Dir)
  2005.     or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  2006.   Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
  2007. end;
  2008.  
  2009. end.
  2010.  
  2011.