{*******************************************************}
{                                                       }
{       Delphi Visual Component Library                 }
{                                                       }
{       Copyright (c) 1995 Borland International        }
{                                                       }
{*******************************************************}

unit FileCtrl;

interface

uses SysUtils, WinTypes, Messages, Classes, Controls, Graphics, Forms,
  Menus, StdCtrls, Buttons;

type
  TFileAttr = (ftReadOnly, ftHidden, ftSystem, ftVolumeID, ftDirectory,
    ftArchive, ftNormal);
  TFileType = set of TFileAttr;

  TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
    dtRAM);

  TDirectoryListBox = class;
  TFilterComboBox = class;
  TDriveComboBox = class;

{ TFileListBox }

  TFileListBox = class(TCustomListBox)
  private
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    function GetDrive: char;
    function GetDirectory: string;
    function GetFileType: TFileType;
    function GetMask: string;
    function GetFileName: string;
    function IsMaskStored: Boolean;
    procedure SetDrive(Value: char);
    procedure SetFileEdit(Value: TEdit);
    procedure SetDirectory(const NewDirectory: string);
    procedure SetFileType(NewFileType: TFileType);
    procedure SetMask(const NewMask: string);
    procedure SetFileName(const NewFile: string);
    procedure SetShowGlyphs (Value: Boolean);
    procedure ResetItemHeight;
  protected
    FDirectory: string;
    FMask: PChar;
    FFileType: TFileType;
    FFileEdit: TEdit;
    FDirList: TDirectoryListBox;
    FFilterCombo: TFilterComboBox;
    FShowGlyphs: Boolean;
    ExeBMP, DirBMP, UnknownBMP: TBitmap;
    FOnChange: TNotifyEvent;
    FLastSel: Integer;
    procedure CreateWnd; override;
    procedure ReadBitmaps; virtual;
    procedure Click; override;
    procedure Change; virtual;
    procedure ReadFileNames; virtual;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);  override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetFilePath: string; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update;
    procedure ApplyFilePath (const EditText: string); virtual;
    property Drive: char read GetDrive write SetDrive;
    property Directory: string read GetDirectory write ApplyFilePath;
    property FileName: String read GetFilePath write ApplyFilePath;
  published
    property Align;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FileEdit: TEdit read FFileEdit write SetFileEdit;
    property FileType: TFileType read GetFileType write SetFileType default [ftNormal];
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property Mask: string read GetMask write SetMask stored IsMaskStored;
    property MultiSelect;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowGlyphs: Boolean read FShowGlyphs write SetShowGlyphs default False;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

{ TDirectoryListBox }

  TFolderBitmap = class(TBitmap)
  public
    constructor Create;
  end;

  TDirectoryListBox = class(TCustomListBox)
  private
    FFileList: TFileListBox;
    FDriveCombo: TDriveComboBox;
    FDirLabel: TLabel;
    FInSetDir: Boolean;
    function GetCurrentDir: string;
    function GetDirectory: string;
    function GetDrive: char;
    procedure SetFileListBox(Value: TFileListBox);
    procedure SetDirLabel(Value: TLabel);
    procedure SetDirLabelCaption;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure SetDrive(Value: char);
    procedure DriveChange(NewDrive: Char);
    procedure SetDir(const NewDirectory: string);
    procedure SetDirectory(const NewDirectory: string); virtual;
    procedure ResetItemHeight;
  protected
    ClosedBMP, OpenedBMP, CurrentBMP: TFolderBitmap;
    FDirectory: string;
    FOnChange: TNotifyEvent;
    procedure Change; virtual;
    procedure DblClick; override;
    procedure ReadBitmaps; virtual;
    procedure CreateWnd; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure BuildList; virtual;
    procedure KeyPress(var Key: Char); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetItemPath(Index: Integer): string;
    procedure OpenCurrent;
    procedure Update;
    property Drive: Char read GetDrive write SetDrive;
    property Directory: string read GetDirectory write SetDirectory;
  published
    property Align;
    property Color;
    property Columns;
    property Ctl3D;
    property DirLabel: TLabel read FDirLabel write SetDirLabel;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FileList: TFileListBox read FFileList write SetFileListBox;
    property Font;
    property IntegralHeight;
    property ItemHeight;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

{ TDriveComboBox }

  TTextCase = (tcLowerCase, tcUpperCase);

  TDriveComboBox = class(TCustomComboBox)
  private
    FDirList: TDirectoryListBox;
    FDrive: Char;
    FTextCase: TTextCase;
    procedure SetDirListBox (Value: TDirectoryListBox);
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure SetDrive(NewDrive: Char);
    function GetTextCase: TTextCase;
    procedure SetTextCase(NewTextCase: TTextCase);
    procedure ReadBitmaps;
    procedure ResetItemHeight;
  protected
    FloppyBMP, FixedBMP, NetworkBMP, CDROMBMP, RAMBMP: TBitmap;
    FOnChange: TNotifyEvent;
    procedure CreateWnd; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure Click; override;
    procedure BuildList; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Change; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text;
    property Drive: Char read FDrive write SetDrive;
  published
    property Color;
    property Ctl3D;
    property DirList: TDirectoryListBox read FDirList write SetDirListBox;
    property DragMode;
    property DragCursor;
    property Enabled;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property TextCase: TTextCase read GetTextCase write SetTextCase default tcLowerCase;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
  end;

{ TFilterComboBox }

  TFilterComboBox = class(TCustomComboBox)
  private
    FFilter: string;
    FFileList: TFileListBox;
    MaskList: TStringList;
    function IsFilterStored: Boolean;
    function GetFilter: string;
    function GetMask: string;
    procedure SetFilter(const NewFilter: string);
    procedure SetFileListBox (Value: TFileListBox);
  protected
    FOnChange: TNotifyEvent;
    procedure CreateWnd; override;
    procedure Click; override;
    procedure BuildList;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Change; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Mask: string read GetMask;
    property Text;
  published
    property Color;
    property Ctl3D;
    property DragMode;
    property DragCursor;
    property Enabled;
    property FileList: TFileListBox read FFileList write SetFileListBox;
    property Filter: string read GetFilter write SetFilter stored IsFilterStored;
    property Font;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
  end;

procedure ProcessPath (const EditText: string; var Drive: Char;
  var DirPart: string; var FilePart: string);

function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  MaxLen: Integer): TFileName;

const
  WNTYPE_DRIVE = 1;  { from WINNET.H, WFW 3.1 SDK }

type
  TSelectDirOpt = (sdAllowCreate, sdPerformCreate, sdPrompt);
  TSelectDirOpts = set of TSelectDirOpt;

function SelectDirectory(var Directory: string;
  Options: TSelectDirOpts; HelpCtx: Longint): Boolean;
function DirectoryExists(Name: string): Boolean;
procedure ForceDirectories(Dir: string);

implementation

uses WinProcs, Consts, Dialogs;

{$R FileCtrl}

type

{ TSelectDirDlg }
  TSelectDirDlg = class(TForm)
    DirList: TDirectoryListBox;
    DirEdit: TEdit;
    DriveList: TDriveComboBox;
    DirLabel: TLabel;
    OKButton: TBitBtn;
    Button2: TBitBtn;
    NetButton: TButton;
    FileList: TFileListBox;
    BitBtn1: TBitBtn;
    procedure DirListChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DriveListChange(Sender: TObject);
    procedure NetClick(Sender: TObject);
    procedure OKClick(Sender: TObject);
  private
    { Private declarations }
    FAllowCreate: Boolean;
    FPrompt: Boolean;
    WNetConnectDialog: function (WndParent: HWND; IType: Word): Word;
    procedure SetAllowCreate(Value: Boolean);
    procedure SetDirectory(const Value: string);
    function GetDirectory: string;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent);
    property Directory: string read GetDirectory write SetDirectory;
    property AllowCreate: Boolean read FAllowCreate write SetAllowCreate default False;
    property Prompt: Boolean read FPrompt write FPrompt default False;
  end;

{ TDriveComboBox }


{ Check whether drive is a CD-ROM.  Returns True if MSCDEX is installed
  and the drive is using a CD driver }

function IsCDROM(DriveNum: Integer): Boolean; assembler;
asm
  MOV   AX,1500h { look for MSCDEX }
  XOR   BX,BX
  INT   2fh
  OR    BX,BX
  JZ    @Finish
  MOV   AX,150Bh { check for using CD driver }
  MOV   CX,DriveNum
  INT   2fh
  OR    AX,AX
  @Finish:
end;

function IsRAMDrive(DriveNum: Integer): Boolean; assembler;
var
  TempResult: Boolean;
asm
  MOV   TempResult,False
  PUSH  DS
  MOV   BX,SS
  MOV   DS,BX
  SUB   SP,0200h
  MOV   BX,SP
  MOV   AX,DriveNum
  MOV   CX,1
  XOR   DX,DX
  INT   25h  { read boot sector }
  ADD   SP,2
  JC    @ItsNot
  MOV   BX,SP
  CMP   BYTE PTR SS:[BX+15h],0F8h  { reverify fixed disk }
  JNE   @ItsNot
  CMP   BYTE PTR SS:[BX+10h],1  { check for single FAT }
  JNE   @ItsNot
  MOV   TempResult,True
  @ItsNot:
  ADD   SP,0200h
  POP   DS
  MOV   AL, TempResult
end;

function FindDriveType(DriveNum: Integer): TDriveType;
begin
  Result := TDriveType(GetDriveType(DriveNum));
  if (Result = dtFixed) or (Result = dtNetwork) then
  begin
    if IsCDROM(DriveNum) then Result := dtCDROM
    else if (Result = dtFixed) then
    begin
        { do not check for RAMDrive under Windows NT }
      if ((GetWinFlags and $4000) = 0) and IsRAMDrive(DriveNum) then
        Result := dtRAM;
    end;
  end;
end;


procedure CutFirstDirectory(var S: TFileName);
var
  Root: Boolean;
  P: Integer;
begin
  if S = '\' then S := ''
  else begin
    if S[1] = '\' then
    begin
      Root := True;
      S := Copy(S, 2, 255);
    end else Root := False;
    if S[1] = '.' then S := Copy(S, 5, 255);
    P := Pos('\',S);
    if P <> 0 then S := '...\' + Copy(S, P + 1, 255)
    else S := '';
    if Root then S := '\' + S;
  end;
end;

function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  MaxLen: Integer): TFileName;
var
  Drive: string[3];
  Dir: TFileName;
  Name: TFileName;
  Ext: TFileName;
  P: Integer;
begin
  Result := FileName;
  Dir := ExtractFilePath(Result);
  Name := ExtractFileName(Result);
  P := Pos('.', Name);
  if P > 0 then Name[0] := Chr(P - 1);
  Ext := ExtractFileExt(Result);

  if Dir[2] = ':' then
  begin
    Drive := Copy(Dir, 1, 2);
    Dir := Copy(Dir, 3, 255);
  end else Drive := '';
  while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do
  begin
    if Dir = '\...\' then
    begin
      Drive := '';
      Dir := '...\';
    end else if Dir = '' then Drive := ''
    else CutFirstDirectory(Dir);
    Result := Drive + Dir + Name + Ext;
  end;
end;

function VolumeID(DriveChar: Char): string;
var
  SearchMask: string[7];
  SearchRec: TSearchRec;
  DotPos: Byte;
  OldErrorMode: Word;
begin
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    SearchMask := 'c:\*.*';
    SearchMask[1] := DriveChar;
    if FindFirst(SearchMask, faVolumeID, SearchRec) = 0 then
    begin
      Result := SearchRec.Name;
      DotPos := Pos('.', Result);
      if DotPos <> 0 then
        System.Delete(Result, DotPos, 1);
      if DriveChar < 'a' then
        Result := ': [' + AnsiUpperCase(Result) + ']'
      else
        Result := ': [' + AnsiLowerCase(Result) + ']'
    end
    else Result := LoadStr(SNoVolumeLabel);
  finally
    SetErrorMode(OldErrorMode);
  end;
end;

function NetworkVolume(DriveChar: Char): string;
const
  LocalName: array[0..2] of Char = 'D:'#0;
var
  BufferSize: Word;
  TempName: array[0..128] of Char;
begin
  LocalName[0] := DriveChar;
  BufferSize := SizeOf(TempName) - 1;
  if WNetGetConnection(LocalName, TempName, @BufferSize) = WN_SUCCESS then
  begin
    if DriveChar < 'a' then
      Result := ': ' + AnsiUpperCase(StrPas(TempName))
    else
      Result := ': ' + AnsiLowerCase(StrPas(TempName));
  end
  else
    Result := VolumeID(DriveChar);
end;

procedure ProcessPath (const EditText: string; var Drive: Char;
  var DirPart: string; var FilePart: string);
var
  SaveDir: string;
  SaveDrive: Char;
begin
  GetDir (0, SaveDir);
  SaveDrive := SaveDir[1];
  Drive := SaveDrive;
  DirPart := EditText;
  if (DirPart[1] = '[') and (DirPart[Length(DirPart)] = ']') then
    DirPart := Copy(DirPart, 2, Length(DirPart) - 2)
  else if Pos(':', DirPart) = 2 then
  begin
    Drive := DirPart[1];
    DirPart := Copy(DirPart, 3, Length(DirPart) - 2);
  end;

  try
    if SaveDrive <> Drive then ChDir(Drive + ':');
    FilePart := ExtractFileName (DirPart);
    if Length(DirPart) = (Length(FilePart) + 1) then DirPart := '\'
    else if Length(DirPart) > Length(FilePart) then
      DirPart := Copy (DirPart, 1, Length(DirPart) - Length(FilePart) - 1)
    else
    begin
      GetDir (0, DirPart);
      DirPart := Copy (DirPart, 3, Length(DirPart) - 2);
    end;
    if Length(DirPart) > 0 then ChDir (DirPart);  {first go to our new directory}
    if (Length(FilePart) > 0) and not
       (((Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0)) or
       FileExists(FilePart)) then
    begin
      ChDir (FilePart);
      if Length (DirPart) = 1 then DirPart := Format('\%s', [FilePart])
      else DirPart := Format('%s\%s', [DirPart, FilePart]);
      FilePart := '';
    end;
  finally
    ChDir (SaveDir);  { restore original directory }
  end;
end;

function GetItemHeight(Font: TFont): Integer;
var
  DC: HDC;
  SaveFont: HFont;
  I,TextMargin: Integer;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  Result := Metrics.tmHeight;
end;

{ TDriveComboBox }

constructor TDriveComboBox.Create(AOwner: TComponent);
var
  DriveName: string[79];
begin
  inherited Create(AOwner);
  Style := csOwnerDrawFixed;
  ReadBitmaps;
  GetDir(0, DriveName);
  FDrive := DriveName[1];  { make default drive selected }
  ResetItemHeight;
end;

destructor TDriveComboBox.Destroy;
begin
  FloppyBMP.Free;
  FixedBMP.Free;
  NetworkBMP.Free;
  CDROMBMP.Free;
  RAMBMP.Free;
  inherited Destroy;
end;

procedure TDriveComboBox.BuildList;
var
  DriveNum: Integer;
  DriveChar: Char;
  DriveType: TDriveType;
begin
  { fill list }
  Clear;
  for DriveNum := 0 to 25 do
  begin
    DriveType := FindDriveType(DriveNum);
    DriveChar := Chr(DriveNum + ord('a'));
    if TextCase = tcUpperCase then
      DriveChar := Upcase(DriveChar);

    case DriveType of
      dtFloppy:   Items.AddObject(DriveChar + ':', FloppyBMP);
      dtFixed:    Items.AddObject(DriveChar + NetworkVolume(DriveChar), FixedBMP);
      dtNetwork:  Items.AddObject(DriveChar + NetworkVolume(DriveChar), NetworkBMP);
      dtCDROM:    Items.AddObject(DriveChar + NetworkVolume(DriveChar), CDROMBMP);
      dtRAM:      Items.AddObject(DriveChar + VolumeID(DriveChar), RAMBMP);
    end;
  end;
end;

procedure TDriveComboBox.SetDrive(NewDrive: Char);
var
  Item: Integer;
  drv: string;
begin
  if (ItemIndex < 0) or (UpCase(NewDrive) <> UpCase(FDrive)) then
  begin
    if TextCase = tcUpperCase then
      FDrive := UpCase(NewDrive)
    else
      FDrive := Chr(ord(UpCase(NewDrive)) + 32);

    { change selected item }
    for Item := 0 to Items.Count - 1 do
    begin
      drv := Items[Item];
      if (UpCase(drv[1]) = UpCase(FDrive)) and (drv[2] = ':') then
      begin
        ItemIndex := Item;
        break;
      end;
    end;
    if FDirList <> nil then FDirList.DriveChange(Drive);
    Change;
  end;
end;

function TDriveComboBox.GetTextCase: TTextCase;
begin
  Result := FTextCase;
end;

procedure TDriveComboBox.SetTextCase(NewTextCase: TTextCase);
var
  OldDrive: Char;
begin
  FTextCase := NewTextCase;
  OldDrive := FDrive;
  BuildList;
  SetDrive (OldDrive);
end;

procedure TDriveComboBox.SetDirListBox (Value: TDirectoryListBox);
begin
  if FDirList <> nil then FDirList.FDriveCombo := nil;
  FDirList := Value;
  if FDirList <> nil then FDirList.FDriveCombo := Self;
end;

procedure TDriveComboBox.CreateWnd;
begin
  inherited CreateWnd;
  BuildList;
  SetDrive (FDrive);
end;

procedure TDriveComboBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  bmpWidth: Integer;
  Text: array[0..255] of Char;
begin
  with Canvas do
  begin
    FillRect(Rect);
    bmpWidth  := 16;
    Bitmap := TBitmap(Items.Objects[Index]);
    if Bitmap <> nil then
    begin
      bmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + 2,
               (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
               Bitmap.Width, Bitmap.Height),
               Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
               Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
    end;
     { uses DrawText instead of TextOut in order to get clipping against
       the combo box button   }
{    TextOut(Rect.Left + bmpWidth + 6, Rect.Top, Items[Index])  }
    StrPCopy(Text, Items[Index]);
    Rect.Left := Rect.Left + bmpWidth + 6;
    DrawText(Canvas.Handle, Text, StrLen(Text), Rect,
             DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  end;
end;

procedure TDriveComboBox.Click;
begin
  inherited Click;
  if ItemIndex >= 0 then
    Drive := Items[ItemIndex][1];
end;

procedure TDriveComboBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  ResetItemHeight;
  RecreateWnd;
end;

procedure TDriveComboBox.ResetItemHeight;
var
  nuHeight: Integer;
begin
  nuHeight :=  GetItemHeight(Font);
  if nuHeight < (FloppyBMP.Height) then nuHeight := FloppyBmp.Height;
  ItemHeight := nuHeight;
end;

procedure TDriveComboBox.ReadBitmaps;
begin
  { assign bitmap glyphs }
  FloppyBMP := TBitmap.Create;
  FloppyBMP.Handle := LoadBitmap(HInstance, 'FLOPPY');
  FixedBMP := TBitmap.Create;
  FixedBMP.Handle := LoadBitmap(HInstance, 'HARD');
  NetworkBMP := TBitmap.Create;
  NetworkBMP.Handle := LoadBitmap(HInstance, 'NETWORK');
  CDROMBMP := TBitmap.Create;
  CDROMBMP.Handle := LoadBitmap(HInstance, 'CDROM');
  RAMBMP := TBitmap.Create;
  RAMBMP.Handle := LoadBitmap(HInstance, 'RAM');
end;

procedure TDriveComboBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FDirList) then
    FDirList := nil;
end;

procedure TDriveComboBox.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

{ TDirectoryListBox }

function DirLevel(const PathName: string): Integer;  { counts '\' in path }
var
  i: Integer;
begin
  Result := 0;
  i   := 0;
  for i := 1 to Length (PathName) do
  begin
    if PathName[i] = '\' then
       Inc (Result);
  end;
end;

  {
    Reads all directories in ParentDirectory, adds their paths to
    DirectoryList,and returns the number added
  }
function ReadDirectoryNames(const ParentDirectory: string; DirectoryList:
  TStringList): Integer;
var
  Status: Integer;
  ParentPath: string;
  TempName: string;
  SearchRec: TSearchRec;
begin
  Result := 0;
  ParentPath := ParentDirectory;
  if ParentPath[Length(ParentPath)] <> '\' then ParentPath := ParentPath + '\';
  Status := FindFirst(ParentPath + '*.*', faDirectory, SearchRec);
  while Status = 0 do
  begin
    if (SearchRec.Attr and faDirectory = faDirectory) then
    begin
      TempName := AnsiLowerCase(SearchRec.Name);
      if (TempName <> '.') and (TempName <> '..') then
      begin
        DirectoryList.Add(TempName);
        Inc(Result);
      end;
    end;
    Status := FindNext(SearchRec);
  end;
end;

constructor TFolderBitmap.Create;
begin
  inherited Create;
  Width := 16;
  Height := 16;
end;

constructor TDirectoryListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 145;
  Style := lbOwnerDrawFixed;
  Sorted := False;
  ReadBitmaps;
  FDirectory := GetCurrentDir; { initially use current dir on default drive }
  ResetItemHeight;
end;

destructor TDirectoryListBox.Destroy;
begin
  ClosedBMP.Free;
  OpenedBMP.Free;
  CurrentBMP.Free;
  inherited Destroy;
end;

procedure TDirectoryListBox.DriveChange(NewDrive: Char);
begin
  if (UpCase(NewDrive) <> UpCase(Drive)) then
  begin
    ChDir(NewDrive + ':');
    FDirectory := GetCurrentDir;  { store correct directory name }
    if not FInSetDir then
    begin
      BuildList;
      Change;
    end;
  end;
end;

procedure TDirectoryListBox.SetFileListBox (Value: TFileListBox);
begin
  if FFileList <> nil then FFileList.FDirList := nil;
  FFileList := Value;
  if FFileList <> nil then FFileList.FDirList := Self;
end;

procedure TDirectoryListBox.SetDirLabel (Value: TLabel);
begin
  FDirLabel := Value;
  SetDirLabelCaption;
end;

function TDirectoryListBox.GetCurrentDir: string;
begin
  GetDir(0, Result);   { store correct directory name }
  Result := AnsiLowerCase (Result);
end;

function TDirectoryListBox.GetDirectory: string;
begin
  Result := FDirectory;
end;

procedure TDirectoryListBox.SetDir(const NewDirectory: string);
begin
     { go to old directory first, in case not complete pathname
       and curdir changed - probably not necessary }
  ChDir(FDirectory);
  ChDir(NewDirectory);     { exception raised if invalid dir }
  FDirectory := GetCurrentDir; { store correct directory name }
  BuildList;
  Change;
end;

procedure TDirectoryListBox.OpenCurrent;
begin
  Directory := GetItemPath(ItemIndex);
end;

procedure TDirectoryListBox.Update;
begin
  BuildList;
  Change;
end;

procedure TDirectoryListBox.BuildList;
var
  TempPath: string;
  DirName, TempDir: string;
  IndentLevel, BackSlashPos, i: Integer;
  Siblings: TStringList;
  Temp, NewSelect: Integer;
begin
  try
    Items.BeginUpdate;
    Items.Clear;
    IndentLevel := 0;
    TempPath := AnsiLowerCase(Directory);
    if TempPath[Length(TempPath)] <> '\' then
    begin
      TempDir := ExtractFileName(TempPath);
      while Pos('\', TempPath) <> 0 do
      begin
        BackSlashPos := Pos('\', TempPath);
        DirName := Copy(TempPath, 1, BackSlashPos - 1);
        if IndentLevel = 0 then DirName := DirName + '\';
        TempPath := Copy(TempPath, BackSlashPos + 1, Length(TempPath));
        Items.AddObject(DirName, OpenedBMP);
        Inc(IndentLevel);
      end;
    end;
    Items.AddObject(TempPath, CurrentBMP);
    NewSelect := Items.Count - 1;
    DirName := ExtractFileName(Directory);
    try
      Siblings := TStringList.Create;
      Siblings.Sorted := True;
        { read all the dir names into Siblings }
      ReadDirectoryNames(Directory, Siblings);
      for i := 0 to Siblings.Count - 1 do
        Items.AddObject(Siblings[i], ClosedBMP);
    finally
      Siblings.Free;
    end;
  finally
    Items.EndUpdate;
  end;
  if HandleAllocated then
    ItemIndex := NewSelect;
end;

procedure TDirectoryListBox.ReadBitmaps;
begin
  OpenedBMP := TFolderBitmap.Create;
  OpenedBMP.Handle := LoadBitmap(HInstance, 'OPENFOLDER');
  ClosedBMP := TFolderBitmap.Create;
  ClosedBMP.Handle := LoadBitmap(HInstance, 'CLOSEDFOLDER');
  CurrentBMP := TFolderBitmap.Create;
  CurrentBMP.Handle := LoadBitmap(HInstance, 'CURRENTFOLDER');
end;

procedure TDirectoryListBox.DblClick;
begin
  inherited DblClick;
  OpenCurrent;
end;

procedure TDirectoryListBox.Change;
begin
  if FFileList <> nil then FFileList.SetDirectory(Directory);
  SetDirLabelCaption;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TDirectoryListBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  bmpWidth: Integer;
  dirOffset: Integer;
begin
  with Canvas do
  begin
    FillRect(Rect);
    bmpWidth  := 16;
    dirOffset := Index * 4 + 2;    {add 2 for spacing}

    Bitmap := TBitmap(Items.Objects[Index]);
    if Bitmap <> nil then
    begin
      if Bitmap = ClosedBMP then
        dirOffset := (DirLevel (Directory) + 1) * 4 + 2;

      bmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + dirOffset,
               (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
               Bitmap.Width, Bitmap.Height),
               Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
               Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
    end;
    TextOut(Rect.Left + bmpWidth + dirOffset + 4, Rect.Top, Items[Index])
  end;
end;

function TDirectoryListBox.GetItemPath (Index: Integer): string;
var
  CurDir: string;
  i, j: Integer;
  Bitmap: TBitmap;
begin
  Result := '';
  if Index < Items.Count then
  begin
    CurDir := Directory;
    Bitmap := TBitmap(Items.Objects[Index]);
    if Index = 0 then
      Result := Drive + ':\'
    else if Bitmap = ClosedBMP then
    begin
      if CurDir [Length(CurDir)] = '\' then
        Result := CurDir + Items[Index]   {if trailing backslash, don't add}
      else
        Result := CurDir + '\' + Items[Index];
    end
    else if Bitmap = CurrentBMP then
      Result := CurDir
    else
    begin
      i   := 0;
      j   := 0;
      while j <> (Index + 1) do
      begin
        i := i + 1;
        if i > Length (CurDir) then
           break;
        if CurDir[i] = '\' then
           j := j + 1;
      end;
      Result := Copy(CurDir, 1, i - 1);
    end;
    Result := AnsiUpperCase (Result);
  end;
end;

procedure TDirectoryListBox.CreateWnd;
begin
  inherited CreateWnd;
  BuildList;
  ItemIndex := DirLevel (Directory);
end;

procedure TDirectoryListBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  ResetItemHeight;
end;

procedure TDirectoryListBox.ResetItemHeight;
var
  nuHeight: Integer;
begin
  nuHeight :=  GetItemHeight(Font);
  if nuHeight < (OpenedBMP.Height + 1) then nuHeight := OpenedBmp.Height + 1;
  ItemHeight := nuHeight;
end;

function TDirectoryListBox.GetDrive: char;
begin
  Result := FDirectory[1];
end;

procedure TDirectoryListBox.SetDrive(Value: char);
begin
  if (UpCase(Value) <> UpCase(Drive)) then
    SetDirectory (Format ('%s:', [Value]));
end;

procedure TDirectoryListBox.SetDirectory(const NewDirectory: string);
var
  DirPart: string;
  FilePart: String;
  NewDrive: Char;
begin
  if Length (NewDirectory) = 0 then Exit;
  if (AnsiCompareText(NewDirectory, Directory) = 0) then Exit;
  ProcessPath (NewDirectory, NewDrive, DirPart, FilePart);
  try
    if Drive <> NewDrive then
    begin
      FInSetDir := True;
      if (FDriveCombo <> nil) then
        FDriveCombo.Drive := NewDrive
      else
        DriveChange(NewDrive);
    end;
  finally
    FInSetDir := False;
  end;
  SetDir(DirPart);
end;

procedure TDirectoryListBox.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  if (Word(Key) = VK_RETURN) then
    OpenCurrent;
end;

procedure TDirectoryListBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
  begin
    if (AComponent = FFileList) then FFileList := nil
    else if (AComponent = FDriveCombo) then FDriveCombo := nil
    else if (AComponent = FDirLabel) then FDirLabel := nil;
  end;
end;

procedure TDirectoryListBox.SetDirLabelCaption;
var
  DirWidth: Integer;
begin
  if FDirLabel <> nil then
  begin
{    FDirLabel.Caption := Directory;  }
    DirWidth := Width;
    if not FDirLabel.AutoSize then DirWidth := FDirLabel.Width;
    FDirLabel.Caption := MinimizeName(Directory, FDirLabel.Canvas, DirWidth);
  end;
end;

{ TFileListBox }

const
  DefaultMask = '*.*';

constructor TFileListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 145;
{  IntegralHeight := True; }
  FFileType := [ftNormal]; { show only normal files by default }
  GetDir(0, FDirectory);   { initially use current dir on default drive }

  FMask := StrNew(DefaultMask);  { default file mask is all }
  MultiSelect := False;    { default is not multi-select }
  FLastSel := -1;
  ReadBitmaps;
  Sorted := True;
  Style := lbOwnerDrawFixed;
  ResetItemHeight;
end;

destructor TFileListBox.Destroy;
begin
  ExeBMP.Free;
  DirBMP.Free;
  UnknownBMP.Free;
  StrDispose(FMask);
  inherited Destroy;
end;

procedure TFileListBox.Update;
begin
  ReadFileNames;
end;

procedure TFileListBox.CreateWnd;
begin
  inherited CreateWnd;
  ReadFileNames;
end;

function TFileListBox.IsMaskStored: Boolean;
begin
  Result := StrComp(DefaultMask, FMask) <> 0;
end;

function TFileListBox.GetDrive: char;
begin
  Result := FDirectory[1];
end;

function TFileListBox.GetDirectory: string;
begin
  Result := FDirectory;
end;

function TFileListBox.GetFileType: TFileType;
begin
  Result := FFileType;
end;

function TFileListBox.GetMask: string;
begin
  Result := StrPas(FMask);
end;

procedure TFileListBox.ReadBitmaps;
begin
  ExeBMP := TBitmap.Create;
  ExeBMP.Handle := LoadBitmap(HInstance, 'EXECUTABLE');
  DirBMP := TBitmap.Create;
  DirBMP.Handle := LoadBitmap(HInstance, 'CLOSEDFOLDER');
  UnknownBMP := TBitmap.Create;
  UnknownBMP.Handle := LoadBitmap(HInstance, 'UNKNOWNFILE');
end;

procedure TFileListBox.ReadFileNames;
var
  AttrIndex: TFileAttr;
  i: Integer;
  FileExt: string;
  MaskPtr: PChar;
  Ptr: PChar;
  AttrWord: Word;
const
  Attributes: array[TFileAttr] of Word = (DDL_READONLY, DDL_HIDDEN, DDL_SYSTEM,
    $0008, DDL_DIRECTORY, DDL_ARCHIVE, DDL_EXCLUSIVE);
begin
      { if no handle allocated yet, this call will force
        one to be allocated incorrectly (i.e. at the wrong time.
        In due time, one will be allocated appropriately.  }
  AttrWord := DDL_READWRITE;
  if HandleAllocated then
  begin
    { Set attribute flags based on values in FileType }
    for AttrIndex := ftReadOnly to ftArchive do
      if AttrIndex in FileType then
        AttrWord := AttrWord or Attributes[AttrIndex];

    { Use Exclusive bit to exclude normal files }
    if not (ftNormal in FileType) then
      AttrWord := AttrWord or DDL_EXCLUSIVE;

    ChDir(FDirectory); { go to the directory we want }
    Clear; { clear the list }

    MaskPtr := FMask;
    while MaskPtr <> nil do
    begin
      Ptr := StrScan (MaskPtr, ';');
      if Ptr <> nil then
        Ptr^ := #0;
      SendMessage(Handle, LB_DIR, AttrWord, Longint(MaskPtr)); { build the list }
      if Ptr <> nil then
      begin
        Ptr^ := ';';
        Inc (Ptr);
      end;
      MaskPtr := Ptr;
    end;

    { Now add the bitmaps }
    for i := 0 to Items.Count - 1 do
    begin
      FileExt := ExtractFileExt(Items[i]);
      if not FileExists(Items[i]) and (Items[i][1] = '[') and
          (ftDirectory in FileType) then
        Items.Objects[i] := DirBMP    { if not a file, must be a dir}
      else if (FileExt = '.exe') or (FileExt = '.com') or
          (FileExt = '.bat') or (FileExt = '.pif') then
        Items.Objects[i] := ExeBMP    { glyph for executable files }
      else Items.Objects[i] := UnknownBMP;  { glyph for everything else }
    end;
    Change;
  end;
end;

procedure TFileListBox.Click;
begin
  inherited Click;
  if FLastSel <> ItemIndex then
     Change;
end;

procedure TFileListBox.Change;
begin
  FLastSel := ItemIndex;
  if FFileEdit <> nil then
  begin
    if Length(GetFileName) = 0 then FileEdit.Text := Mask
    else FileEdit.Text := GetFileName;
    FileEdit.SelectAll;
  end;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TFileListBox.SetShowGlyphs(Value: Boolean);
begin
  if FShowGlyphs <> Value then
  begin
    FShowGlyphs := Value;
    if (FShowGlyphs = True) and (ItemHeight < (ExeBMP.Height + 1)) then
      ResetItemHeight;
    Invalidate;
  end;
end;

function TFileListBox.GetFileName: string;
var
  idx: Integer;
begin
      { if multi-select is turned on, then using ItemIndex
        returns a bogus value if nothing is selected   }
  idx  := ItemIndex;
  if (idx < 0)  or  (Items.Count = 0)  or  (Selected[idx] = FALSE)  then
    Result  := ''
  else
    Result  := Items[idx];
end;

procedure TFileListBox.SetFileName(const NewFile: string);
var
  Item: Integer;
begin
  if AnsiCompareText(NewFile, GetFileName) <> 0 then
  begin
       { change selected item }
    ItemIndex := -1;
    for Item := 0 to Items.Count - 1 do
    begin
      if AnsiCompareText(NewFile, Items[Item]) = 0 then
      begin
        ItemIndex := Item;
        break;
      end;
    end;
    Change;
  end;
end;

procedure TFileListBox.SetFileEdit(Value: TEdit);
begin
  FFileEdit := Value;
  if FFileEdit <> nil then
  begin
    if GetFileName <> '' then FFileEdit.Text := GetFileName
    else FFileEdit.Text := Mask;
  end;
end;

procedure TFileListBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  offset: Integer;
begin
  with Canvas do
  begin
    FillRect(Rect);
    offset := 2;
    Bitmap := TBitmap(Items.Objects[Index]);
    if (FShowGlyphs = True) and (Bitmap <> nil) then
    begin
      BrushCopy(Bounds(Rect.Left + 2,
                (Rect.Top + Rect.Bottom - Bitmap.Height) div 2,
                Bitmap.Width, Bitmap.Height),
                Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height),
                Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
      offset := Bitmap.width + 6;
    end;
    TextOut(Rect.Left + offset, Rect.Top, Items[Index])
  end;
end;

procedure TFileListBox.SetDrive(Value: char);
begin
  if (UpCase(Value) <> UpCase(FDirectory[1])) then
    ApplyFilePath (Format ('%s:', [Value]));
end;

procedure TFileListBox.SetDirectory(const NewDirectory: string);
begin
  if AnsiCompareText(NewDirectory, FDirectory) <> 0 then
  begin
       { go to old directory first, in case not complete pathname
         and curdir changed - probably not necessary }
    ChDir(FDirectory);
    ChDir(NewDirectory);     { exception raised if invalid dir }
    GetDir(0, FDirectory);   { store correct directory name }
    ReadFileNames;
  end;
end;

procedure TFileListBox.SetFileType(NewFileType: TFileType);
begin
  if NewFileType <> FFileType then
  begin
    FFileType := NewFileType;
    ReadFileNames;
  end;
end;

procedure TFileListBox.SetMask(const NewMask: string);
var
  TempMask: array[0..127] of Char;
begin
  if StrPas(FMask) <> NewMask then
  begin
    StrDispose(FMask);
    FMask := StrNew(StrPCopy(TempMask, NewMask));
    ReadFileNames;
  end;
end;

procedure TFileListBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  ResetItemHeight;
end;

procedure TFileListBox.ResetItemHeight;
var
  nuHeight: Integer;
begin
  nuHeight :=  GetItemHeight(Font);
  if (FShowGlyphs = True) and (nuHeight < (ExeBMP.Height + 1)) then
    nuHeight := ExeBmp.Height + 1;
  ItemHeight := nuHeight;
end;

procedure TFileListBox.ApplyFilePath(const EditText: string);
var
  DirPart: string;
  FilePart: String;
  NewDrive: Char;
begin
  if AnsiCompareText(FileName, EditText) = 0 then Exit;
  if Length (EditText) = 0 then Exit;
  ProcessPath (EditText, NewDrive, DirPart, FilePart);
  if FDirList <> nil then FDirList.Directory := (EditText)
  else
  begin
    DirPart := Format('%s:%s', [NewDrive, DirPart]);
    SetDirectory (DirPart);
  end;
  if (Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0) then
    SetMask (FilePart)
  else if Length(FilePart) > 0 then
  begin
    SetFileName (FilePart);
    if FileExists (FilePart) then
    begin
      if GetFileName = '' then
      begin
        SetMask(FilePart);
        SetFileName (FilePart);
      end;
    end
    else
      raise EInvalidOperation.Create(FmtLoadStr(SInvalidFileName, [EditText]));
  end;
end;

function TFileListBox.GetFilePath: string;
begin
  Result := '';
  if GetFileName <> '' then
  begin
    if FDirectory[Length(FDirectory)] = '\' then
      Result := Format ('%s%s', [FDirectory, GetFileName])
    else
      Result := Format ('%s\%s', [FDirectory, GetFileName])
  end;
end;

procedure TFileListBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
  begin
    if (AComponent = FFileEdit) then FFileEdit := nil
    else if (AComponent = FDirList) then FDirList := nil
    else if (AComponent = FFilterCombo) then FFilterCombo := nil;
  end;
end;

{ TFilterComboBox }

constructor TFilterComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Style := csDropDownList;
  FFilter := LoadStr (SDefaultFilter);
  MaskList := TStringList.Create;
end;

destructor TFilterComboBox.Destroy;
begin
  MaskList.Free;
  inherited Destroy;
end;

procedure TFilterComboBox.CreateWnd;
begin
  inherited CreateWnd;
  BuildList;
end;

function TFilterComboBox.IsFilterStored: Boolean;
begin
  Result := CompareStr(LoadStr(SDefaultFilter), FFilter) <> 0;
end;

function TFilterComboBox.GetFilter: string;
begin
  Result := FFilter;
end;

procedure TFilterComboBox.SetFilter(const NewFilter: string);
begin
  if AnsiCompareText(NewFilter, FFilter) <> 0 then
  begin
    FFilter := NewFilter;
    BuildList;
    Change;
  end;
end;

procedure TFilterComboBox.SetFileListBox (Value: TFileListBox);
begin
  if FFileList <> nil then FFileList.FFilterCombo := nil;
  FFileList := Value;
  if FFileList <> nil then FFileList.FFilterCombo := Self;
end;

procedure TFilterComboBox.Click;
begin
  inherited Click;
  Change;
end;

function TFilterComboBox.GetMask: string;
begin
  if ItemIndex < 0 then
    ItemIndex := Items.Count - 1;

  if ItemIndex >= 0 then
  begin
     Result := MaskList[ItemIndex];
  end
  else
     Result := '*.*';
end;

procedure TFilterComboBox.BuildList;
var
  AFilter, MaskName, Mask: string;
  BarPos: Integer;
begin
  Clear;
  MaskList.Clear;
  AFilter := Filter;
  while Pos('|', AFilter) <> 0 do
  begin
    BarPos := Pos('|', AFilter);
    MaskName := Copy(AFilter, 1, BarPos - 1);
    AFilter := Copy(AFilter, BarPos + 1, Length(AFilter));
    BarPos := Pos('|', AFilter);
    if BarPos > 0 then
    begin
      Mask := Copy(AFilter, 1, BarPos - 1);
      AFilter := Copy(AFilter, BarPos + 1, Length(AFilter));
    end
    else
    begin
      Mask := AFilter;
      AFilter := '';
    end;
    Items.Add(MaskName);
    MaskList.Add(Mask);
  end;
  ItemIndex := 0;
end;

procedure TFilterComboBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FFileList) then
    FFileList := nil;
end;

procedure TFilterComboBox.Change;
begin
  if FFileList <> nil then FFileList.Mask := Mask;
  if Assigned(FOnChange) then FOnChange(Self);
end;

{ TSelectDirDlg }
constructor TSelectDirDlg.Create(AOwner: TComponent);
begin
  inherited CreateNew(AOwner);
  Caption := LoadStr(SSelectDirCap);
  BorderStyle := bsDialog;
  ClientWidth := 424;
  ClientHeight := 255;
  Font.Name := 'MS Sans Serif';
  Font.Size := 8;
  Font.Style := [fsBold];
  Position := poScreenCenter;

  DirEdit := TEdit.Create(Self);
  with DirEdit do
  begin
    Parent := Self;
    SetBounds(8, 24, 313, 20);
    Visible := False;
    TabOrder := 1;
  end;

  with TLabel.Create(Self) do
  begin
    Parent := Self;
    SetBounds(8, 8, 92, 13);
    FocusControl := DirEdit;
    Caption := LoadStr(SDirNameCap);
  end;

  DriveList := TDriveComboBox.Create(Self);
  with DriveList do
  begin
    Parent := Self;
    SetBounds(232, 192, 185, 19);
    TabOrder := 2;
    OnChange := DriveListChange;
  end;

  with TLabel.Create(Self) do
  begin
    Parent := Self;
    SetBounds(232, 176, 41, 13);
    Caption := LoadStr(SDrivesCap);
    FocusControl := DriveList;
  end;

  DirLabel := TLabel.Create(Self);
  with DirLabel do
  begin
    Parent := Self;
    SetBounds(120, 8, 213, 13);
    AutoSize := False;
  end;

  DirList := TDirectoryListBox.Create(Self);
  with DirList do
  begin
    Parent := Self;
    SetBounds(8, 72, 213, 138);
    TabOrder := 0;
    TabStop := True;
    ItemHeight := 17;
    IntegralHeight := True;
    OnChange := DirListChange;
  end;

  with TLabel.Create(Self) do
  begin
    Parent := Self;
    SetBounds(8, 56, 66, 13);
    Caption := LoadStr(SDirsCap);
    FocusControl := DirList;
  end;

  FileList := TFileListBox.Create(Self);
  with FileList do
  begin
    Parent := Self;
    SetBounds(232, 72, 185, 93);
    TabOrder := 6;
    TabStop := True;
    FileType := [ftNormal];
    Mask := '*.*';
    Font.Color := clGrayText;
    ItemHeight := 13;
  end;

  with TLabel.Create(Self) do
  begin
    Parent := Self;
    SetBounds(232, 56, 57, 13);
    Caption := LoadStr(SFilesCap);
    FocusControl := FileList;
  end;

  NetButton := TButton.Create(Self);
  with NetButton do
  begin
    Parent := Self;
    SetBounds(8, 224, 77, 27);
    Visible := False;
    TabOrder := 3;
    Caption := LoadStr(SNetworkCap);
    OnClick := NetClick;
  end;

  OKButton := TBitBtn.Create(Self);
  with OKButton do
  begin
    Parent := Self;
    SetBounds(172, 224, 77, 27);
    TabOrder := 4;
    OnClick := OKClick;
    Kind := bkOK;
    Margin := 2;
    Spacing := -1;
  end;

  with TBitBtn.Create(Self) do
  begin
    Parent := Self;
    SetBounds(256, 224, 77, 27);
    Kind := bkCancel;
    TabOrder := 5;
    Margin := 2;
    Spacing := -1;
  end;

  with TBitBtn.Create(Self) do
  begin
    Parent := Self;
    SetBounds(340, 224, 77, 27);
    Kind := bkHelp;
    TabOrder := 7;
    Margin := 2;
    Spacing := -1;
  end;

  FormCreate(Self);
  ActiveControl := DirList;
end;

procedure TSelectDirDlg.DirListChange(Sender: TObject);
begin
  DirLabel.Caption := DirList.Directory;
  FileList.Directory := DirList.Directory;
  DirEdit.Text := DirLabel.Caption;
  DirEdit.SelectAll;
end;

procedure TSelectDirDlg.FormCreate(Sender: TObject);
const
  User = 'USER';
var
  UserHandle: THandle;
  NetDriver: THandle;
  WNetGetCaps: function (Flags: Word): Word;
begin
  { is network access enabled? }
  UserHandle := GetModuleHandle(User);
  @WNetGetCaps := GetProcAddress(UserHandle, 'WNETGETCAPS');
  if @WNetGetCaps <> nil then
  begin
    NetDriver := WNetGetCaps(Word(-1));
    if NetDriver <> 0 then
    begin
      @WNetConnectDialog := GetProcAddress(NetDriver, 'WNETCONNECTDIALOG');
      NetButton.Visible := @WNetConnectDialog <> nil;
    end;
  end;

  FAllowCreate := False;
  DirLabel.BoundsRect := DirEdit.BoundsRect;
  DirListChange(Self);
end;

procedure TSelectDirDlg.DriveListChange(Sender: TObject);
begin
  DirList.Drive := DriveList.Drive;
end;

procedure TSelectDirDlg.SetAllowCreate(Value: Boolean);
begin
  if Value <> FAllowCreate then
  begin
    FAllowCreate := Value;
    DirLabel.Visible := not FAllowCreate;
    DirEdit.Visible := FAllowCreate;
  end;
end;

procedure TSelectDirDlg.SetDirectory(const Value: string);
var
  Temp: TFileName;
begin
  if Value > '' then
  begin
    Temp := Value;
    if Temp[Length(Temp)] = '\' then Dec(Temp[0]);
    Temp := ExpandFileName(Temp + '\*.*');
    if (Length(Temp) >= 3) and (Temp[2] = ':') then
    begin
      DriveList.Drive := Temp[1];
      Temp := ExtractFilePath(Temp);
      try
        DirList.Directory := Copy(Temp, 1, Length(Temp) - 1);
      except
        on EInOutError do
        begin
          GetDir(0, Temp);
          DriveList.Drive := Temp[1];
          DirList.Directory := Temp;
        end;
      end;
    end;
  end;
end;

function TSelectDirDlg.GetDirectory: string;
begin
  if FAllowCreate then Result := DirEdit.Text
  else Result := DirLabel.Caption;
end;

procedure TSelectDirDlg.NetClick(Sender: TObject);
begin
  if @WNetConnectDialog <> nil then
    WNetConnectDialog(Handle, WNTYPE_DRIVE);
end;

procedure TSelectDirDlg.OKClick(Sender: TObject);
begin
  if AllowCreate and Prompt and (not DirectoryExists(Directory)) and
    (MessageDlg(LoadStr(SConfirmCreateDir), mtConfirmation, [mbYes, mbNo],
      0) <> mrYes) then
    ModalResult := 0;
end;

function SelectDirectory(var Directory: string;
  Options: TSelectDirOpts; HelpCtx: Longint): Boolean;
var
  D: TSelectDirDlg;
  DoCreate: Boolean;
begin
  Result := False;
  D := TSelectDirDlg.Create(Application);
  try
    D.Directory := Directory;
    D.AllowCreate := sdAllowCreate in Options;
    D.Prompt := sdPrompt in Options;

    { scale to screen res }
    if Screen.PixelsPerInch <> 96 then
    begin
      D.ScaleBy(Screen.PixelsPerInch, 96);

      { The ScaleBy method does not scale the font well, so set the
        font back to the original info. }
      D.FileList.ParentFont := True;
      D.Font.Name := 'MS Sans Serif';
      D.Font.Size := 8;
      D.Font.Style := [fsBold];
      D.Left := (Screen.Width div 2) - (D.Width div 2);
      D.Top := (Screen.Height div 2) - (D.Height div 2);
      D.FileList.Font.Color := clGrayText;
    end;

    D.HelpContext := HelpCtx;

    Result := D.ShowModal = mrOK;
    if Result then
    begin
      Directory := AnsiUpperCase(D.Directory);
      if sdPerformCreate in Options then
        ForceDirectories(Directory);
    end;
  finally
    D.Free;
  end;
end;

function DirectoryExists(Name: string): Boolean;
var
  SR: TSearchRec;
begin
  if Name[Length(Name)] = '\' then Dec(Name[0]);
  if (Length(Name) = 2) and (Name[2] = ':') then
    Name := Name + '\*.*';
  Result := FindFirst(Name, faDirectory, SR) = 0;
  Result := Result and (SR.Attr and faDirectory <> 0);
end;

procedure ForceDirectories(Dir: string);
begin
  if Dir[Length(Dir)] = '\' then Dec(Dir[0]);
  if (Length(Dir) < 3) or DirectoryExists(Dir) then Exit;
  ForceDirectories(ExtractFilePath(Dir));
  MkDir(Dir);
end;

end.

