tntfilectrl2.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

    //ChDir(NewDirectory);     { exception raised if invalid dir }
    SetCurrFilePath (NewDirectory);
    //GetDir(0, FDirectory);   { store correct directory name }
    FDirectory := CurrFilePath;
    ReadFileNames;
  end;
end;

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

procedure TTntFileListBox.SetMask(const NewMask: WideString);
begin
  if FMask <> NewMask then
  begin
    FMask := NewMask;
    ReadFileNames;
  end;
end;

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

procedure TTntFileListBox.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 TTntFileListBox.ApplyFilePath(const EditText: WideString);
var
  DirPart: WideString;
  FilePart: WideString;
  NewDrive: Char;
begin
  if WideCompareText(FileName, EditText) = 0 then Exit;
  if Length (EditText) = 0 then Exit;
  ProcessPath (EditText, NewDrive, DirPart, FilePart);
  if FDirList <> nil then
    FDirList.Directory := EditText
  else
    if NewDrive <> #0 then
      SetDirectory(WideFormat('%s:%s', [NewDrive, DirPart]))
    else
      SetDirectory(DirPart);
  if (Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0) then
    SetMask (FilePart)
  else if Length(FilePart) > 0 then
  begin
    SetFileName (FilePart);
    if WideFileExists (FilePart) then
    begin
      if GetFileName = '' then
      begin
        SetMask(FilePart);
        SetFileName (FilePart);
      end;
    end
    else
      raise EInvalidOperation.CreateFmt(SInvalidFileName, [EditText]);
  end;
end;

function TTntFileListBox.GetFilePath: WideString;
begin
  Result := '';
  if GetFileName <> '' then
    Result := SlashSep(FDirectory, GetFileName);
end;

procedure TTntFileListBox.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;

{ TTntFilterComboBox }

constructor TTntFilterComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Style := csDropDownList;
  FFilter := SDefaultFilter;
  MaskList := TTntStringList.Create;
end;

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

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

function TTntFilterComboBox.IsFilterStored: Boolean;
begin
  Result := SDefaultFilter <> FFilter;
end;

procedure TTntFilterComboBox.SetFilter(const NewFilter: WideString);
begin
  if WideCompareText(NewFilter, FFilter) <> 0 then
  begin
    FFilter := NewFilter;
    if HandleAllocated then BuildList;
    Change;
  end;
end;

procedure TTntFilterComboBox.SetFileListBox (Value: TTntFileListBox);
begin
  if FFileList <> nil then FFileList.FFilterCombo := nil;
  FFileList := Value;
  if FFileList <> nil then
  begin
    FFileList.FreeNotification(Self);
    FFileList.FFilterCombo := Self;
  end;
end;

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

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

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

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

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

procedure TTntFilterComboBox.Change;
begin
  if FFileList <> nil then FFileList.Mask := Mask;
  inherited Change;
end;

{ TTntSelectDirDlg }
constructor TTntSelectDirDlg.Create(AOwner: TComponent);
begin
  inherited CreateNew(AOwner);
  Caption := SSelectDirCap;
  BorderStyle := bsDialog;
  ClientWidth := 424;
  ClientHeight := 255;
  Position := poScreenCenter;

  DirEdit := TTntEdit.Create(Self);
  with DirEdit do
  begin
    Parent := Self;
    Visible := False;
    TabOrder := 1;
  end;

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

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

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

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

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

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

  FileList := TTntFileListBox.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 TTntLabel.Create(Self) do
  begin
    Parent := Self;
    SetBounds(232, 56, 57, 13);
    Caption := SFilesCap;
    FocusControl := FileList;
  end;

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

  OKButton := TTntButton.Create(Self);
  with OKButton do
  begin
    Parent := Self;
    SetBounds(172, 224, 77, 27);
    TabOrder := 4;
    OnClick := OKClick;
    Caption := SOKButton;
    ModalResult := 1;
    Default := True;
  end;

  CancelButton := TTntButton.Create(Self);
  with CancelButton do
  begin
    Parent := Self;
    SetBounds(256, 224, 77, 27);
    TabOrder := 5;
    Cancel := True;
    Caption := SCancelButton;
    ModalResult := 2;
  end;

  HelpButton := TTntButton.Create(Self);
  with HelpButton do
  begin
    Parent := Self;
    SetBounds(340, 224, 77, 27);
    TabOrder := 7;
    Caption := SHelpButton;
    OnClick := HelpButtonClick;
  end;

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

procedure TTntSelectDirDlg.HelpButtonClick(Sender: TObject);
begin
  Application.HelpContext(HelpContext);
end;

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

procedure TTntSelectDirDlg.FormCreate(Sender: TObject);
var
  UserHandle: THandle;
  NetDriver: THandle;
  WNetGetCaps: function (Flags: Word): Word;
begin
  { is network access enabled? }
  UserHandle := GetModuleHandle(User32);
  @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;
  if NetButton.Visible
  then  DirEdit.SetBounds(8, 24, 313, 20)
  else  DirEdit.SetBounds(8, 24, ClientWidth-16, 20);
  DirLabel.BoundsRect := DirEdit.BoundsRect;
  if UseRightToLeftAlignment
  then  FlipChildren (True);
  DirListChange(Self);
end;

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

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

procedure TTntSelectDirDlg.SetDirectory(const Value: WideString);
var
  Temp: WideString;
begin
  if Value <> '' then
  begin
    Temp := WideExpandFileName(SlashSep(Value,'*.*'));
    if (Length(Temp) >= 3) and (Temp[2] = ':') then
    begin
      DriveList.Drive := Char(Temp[1]);
      Temp := WideExtractFilePath(Temp);
      try
        DirList.Directory := Copy(Temp, 1, Length(Temp) - 1);
      except
        on EInOutError do
        begin
          //GetDir(0, Temp);
          Temp := CurrFilePath;
          DriveList.Drive := Char(Temp[1]);
          DirList.Directory := Temp;
        end;
      end;
    end;
  end;
end;

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

procedure TTntSelectDirDlg.NetClick(Sender: TObject);
begin
  if Assigned(WNetConnectDialog) then
    WNetConnectDialog(Handle, WNTYPE_DRIVE);
end;

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

function WideSelectDirectory3 (var Directory: WideString;
  Options: TSelectDirOpts; HelpCtx: Longint; DialogFont: TFont): Boolean;
var
  D: TTntSelectDirDlg;
begin
  D := TTntSelectDirDlg.Create(Application);
  try
    D.Directory := Directory;
    D.AllowCreate := sdAllowCreate in Options;
    D.Prompt := sdPrompt in Options;
    if  Assigned (DialogFont)
    then  D.Font.Assign (DialogFont);

    { scale to screen res }
    if Screen.PixelsPerInch <> 96 then
    begin
      D.ScaleBy(Screen.PixelsPerInch, 96);
      D.FileList.ParentFont := True;
      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;

    if HelpCtx = 0 then
    begin
      D.HelpButton.Visible := False;
      D.OKButton.Left := D.CancelButton.Left;
      D.CancelButton.Left := D.HelpButton.Left;
    end
    else D.HelpContext := HelpCtx;

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

function WideSelectDirectory2 (var Directory: WideString;
  Options: TSelectDirOpts; HelpCtx: Longint): Boolean;
begin
  Result := WideSelectDirectory3 (Directory, Options, HelpCtx, nil);
end;

end.