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