tntfilectrl2.pas

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

  finally
    WideFindClose(SearchRec);
  end;
end;

procedure TTntDirectoryListBox.BuildList;
var
  TempPath: WideString;
  DirName: WideString;
  IndentLevel, BackSlashPos: Integer;
  VolFlags: DWORD;
  I: Integer;
  Siblings: TTntStringList;
  NewSelect: Integer;
  Root: WideString;
begin
  try
    Items.BeginUpdate;
    Items.Clear;
    IndentLevel := 0;
    Root := WideExtractFileDrive(Directory)+''';
    GetVolumeInformationW(PWideChar(Root), nil, 0, nil, DWORD(i), VolFlags, nil, 0);
    FPreserveCase := VolFlags and (FS_CASE_IS_PRESERVED or FS_CASE_SENSITIVE) <> 0;
    FCaseSensitive := (VolFlags and FS_CASE_SENSITIVE) <> 0;
    if (Length(Root) >= 2) and (Root[2] = ''') then
    begin
      Items.AddObject(Root, OpenedBMP);
      Inc(IndentLevel);
      TempPath := Copy(Directory, Length(Root)+1, Length(Directory));
    end
    else
      TempPath := Directory;
    if (Length(TempPath) > 0) then
    begin
      if  TntWideLastChar(TempPath) <> ''' then
      begin
        BackSlashPos := Pos(''', TempPath);
        while BackSlashPos <> 0 do
        begin
          DirName := Copy(TempPath, 1, BackSlashPos - 1);
          if IndentLevel = 0 then DirName := DirName + ''';
          Delete(TempPath, 1, BackSlashPos);
          Items.AddObject(DirName, OpenedBMP);
          Inc(IndentLevel);
          BackSlashPos := Pos(''', TempPath);
        end;
      end;
      Items.AddObject(TempPath, CurrentBMP);
    end;
    NewSelect := Items.Count - 1;
    Siblings := TTntStringList.Create;
    try
      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 TTntDirectoryListBox.ReadBitmaps;
begin
  OpenedBMP := TBitmap.Create;
  OpenedBMP.LoadFromResourceName(FindClassHInstance(TDirectoryListBox), 'OPENFOLDER');
  ClosedBMP := TBitmap.Create;
  ClosedBMP.LoadFromResourceName(FindClassHInstance(TDirectoryListBox), 'CLOSEDFOLDER');
  CurrentBMP := TBitmap.Create;
  CurrentBMP.LoadFromResourceName(FindClassHInstance(TDirectoryListBox), 'CURRENTFOLDER');
end;

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

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

procedure TTntDirectoryListBox.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;
    WideCanvasTextOut (Canvas, Rect.Left + bmpWidth + dirOffset + 4, Rect.Top, DisplayCase(Items[Index]));
  end;
end;

function TTntDirectoryListBox.GetItemPath (Index: Integer): WideString;
var
  CurDir: WideString;
  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 := WideExtractFileDrive(CurDir)+'''
    else if Bitmap = ClosedBMP then
      Result := SlashSep(CurDir,Items[Index])
    else if Bitmap = CurrentBMP then
      Result := CurDir
    else
    begin
      i   := 0;
      j   := 0;
      Delete(CurDir, 1, Length(WideExtractFileDrive(CurDir)));
      while j <> (Index + 1) do
      begin
        Inc(i);
        if i > Length (CurDir) then
          break;
        if  Char (CurDir[i]) in LeadBytes then
          Inc(i)
        else if CurDir[i] = ''' then
          Inc(j);
      end;
      Result := WideExtractFileDrive(Directory) + Copy(CurDir, 1, i - 1);
    end;
  end;
end;

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

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

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

function TTntDirectoryListBox.GetDrive: char;
begin
  Result := Char (FDirectory[1]);
end;

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

procedure TTntDirectoryListBox.SetDirectory(const NewDirectory: WideString);
var
  DirPart: WideString;
  FilePart: WideString;
  NewDrive: Char;
begin
  if Length (NewDirectory) = 0 then Exit;
  if (FileCompareText(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);
  SetDir(Concat (NewDrive, ':', DirPart));
end;

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

procedure TTntDirectoryListBox.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 TTntDirectoryListBox.SetDirLabelCaption;
var
  DirWidth: Integer;
begin
  if FDirLabel <> nil then
  begin
    DirWidth := Width;
    if not FDirLabel.AutoSize then DirWidth := FDirLabel.Width;
    FDirLabel.Caption := MinimizeName(Directory, FDirLabel.Canvas, DirWidth);
  end;
end;

{ TTntFileListBox }

const
  DefaultMask = '*.*';

constructor TTntFileListBox.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 }
  FDirectory := CurrFilePath;

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

destructor TTntFileListBox.Destroy;
begin
  ExeBMP.Free;
  DirBMP.Free;
  UnknownBMP.Free;
  inherited Destroy;
end;

procedure TTntFileListBox.Update;
begin
  ReadFileNames;
end;

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

function TTntFileListBox.IsMaskStored: Boolean;
begin
  Result := DefaultMask <> FMask;
end;

function TTntFileListBox.GetDrive: char;
begin
  Result := Char (FDirectory[1]);
end;

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

procedure TTntFileListBox.ReadFileNames;
var
  AttrIndex: TFileAttr;
  I: Integer;
  FileExt: WideString;
  MaskPtr: PWideChar;
  Ptr: PWideChar;
  AttrWord: Word;
  FileInfo: TSearchRecW;
  SaveCursor: TCursor;
  Glyph: TBitmap;
const
   Attributes: array[TFileAttr] of Word = (faReadOnly, faHidden, faSysFile,
     faVolumeID, faDirectory, faArchive, 0);
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];

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

    I := 0;
    SaveCursor := Screen.Cursor;
    try
      MaskPtr := PWideChar(FMask);
      while MaskPtr <> nil do
      begin
        Ptr := WStrScan (MaskPtr, ';');
        if Ptr <> nil then
          Ptr^ := #0;
        if WideFindFirst(FCurrFilePath + '''+ MaskPtr, AttrWord, FileInfo) = 0 then
        begin
          repeat            { exclude normal files if ftNormal not set }
            if (ftNormal in FileType) or (FileInfo.Attr and AttrWord <> 0) then
              if FileInfo.Attr and faDirectory <> 0 then
              begin
                I := Items.Add(WideFormat('[%s]',[FileInfo.Name]));
                if ShowGlyphs then
                  Items.Objects[I] := DirBMP;
              end
              else
              begin
                FileExt := AnsiLowerCase(WideExtractFileExt(FileInfo.Name));
                Glyph := UnknownBMP;
                if (FileExt = '.exe') or (FileExt = '.com') or
                  (FileExt = '.bat') or (FileExt = '.pif') then
                  Glyph := ExeBMP;
                I := Items.AddObject(FileInfo.Name, Glyph);
              end;
            if I = 100 then
              Screen.Cursor := crHourGlass;
          until WideFindNext(FileInfo) <> 0;
          WideFindClose(FileInfo);
        end;
        if Ptr <> nil then
        begin
          Ptr^ := ';';
          Inc (Ptr);
        end;
        MaskPtr := Ptr;
      end;
    finally
      Screen.Cursor := SaveCursor;
    end;
    Change;
  end;
end;

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

procedure TTntFileListBox.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 TTntFileListBox.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 TTntFileListBox.GetFileName: WideString;
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 TTntFileListBox.SetFileName(const NewFile: WideString);
begin
  if WideCompareText(NewFile, GetFileName) <> 0 then
  begin
    if not Win32PlatformIsUnicode then  begin
      ItemIndex := SendMessageA(Handle, LB_FindStringExact, 0,
        Longint(PAnsiChar(AnsiString(NewFile))));
    end
    else  begin
      ItemIndex := SendMessageW(Handle, LB_FindStringExact, 0,
        Longint(PWideChar(NewFile)));
    end;
    Change;
  end;
end;

procedure TTntFileListBox.SetFileEdit(Value: TTntEdit);
begin
  FFileEdit := Value;
  if FFileEdit <> nil then
  begin
    FFileEdit.FreeNotification(Self);
    if GetFileName <> '' then
      FFileEdit.Text := GetFileName
    else
      FFileEdit.Text := Mask;
  end;
end;

procedure TTntFileListBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  offset: Integer;
begin
  with Canvas do
  begin
    FillRect(Rect);
    offset := 2;
    if ShowGlyphs then
    begin
      Bitmap := TBitmap(Items.Objects[Index]);
      if Assigned(Bitmap) 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;
    end;
    WideCanvasTextOut (Canvas, Rect.Left + offset, Rect.Top, Items[Index]);
  end;
end;

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

procedure TTntFileListBox.SetDirectory(const NewDirectory: WideString);
begin
  if WideCompareText(NewDirectory, FDirectory) <> 0 then
  begin
       { go to old directory first, in case not complete pathname
         and curdir changed - probably not necessary }
    if WideDirectoryExists(FDirectory) then
      //ChDir(FDirectory);
      FCurrFilePath := FDirectory;