tntfilectrl2.pas

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

    else
      S := '';
    if Root then
      S := ''' + S;
  end;
end;

function MinimizeName(const Filename: TWideFileName; Canvas: TCanvas;
  MaxLen: Integer): TWideFileName;
var
  Drive: TWideFileName;
  Dir: TWideFileName;
  Name: TWideFileName;
begin
  Result := FileName;
  Dir := WideExtractFilePath(Result);
  Name := WideExtractFileName(Result);

  if (Length(Dir) >= 2) and (Dir[2] = ':') then
  begin
    Drive := Copy(Dir, 1, 2);
    Delete(Dir, 1, 2);
  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;
  end;
end;

function VolumeID(DriveChar: Char): string;
var
  OldErrorMode: Integer;
  NotUsed, VolFlags: DWORD;
  Buf: array [0..MAX_PATH] of Char;
begin
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    Buf[0] := #$00;
    if GetVolumeInformation(PChar(DriveChar + ':''), Buf, DWORD(sizeof(Buf)),
      nil, NotUsed, VolFlags, nil, 0) then
      SetString(Result, Buf, StrLen(Buf))
    else Result := '';
    if DriveChar < 'a' then
      Result := AnsiUpperCaseFileName(Result)
    else
      Result := AnsiLowerCaseFileName(Result);
    Result := WideFormat('[%s]',[Result]);
  finally
    SetErrorMode(OldErrorMode);
  end;
end;

function NetworkVolume(DriveChar: Char): string;
var
  Buf: Array [0..MAX_PATH] of Char;
  DriveStr: array [0..3] of Char;
  BufferSize: DWORD;
begin
  BufferSize := sizeof(Buf);
  DriveStr[0] := UpCase(DriveChar);
  DriveStr[1] := ':';
  DriveStr[2] := #0;
  if WNetGetConnection(DriveStr, Buf, BufferSize) = WN_SUCCESS then
  begin
    SetString(Result, Buf, BufferSize);
    if DriveChar < 'a' then
      Result := AnsiUpperCaseFileName(Result)
    else
      Result := AnsiLowerCaseFileName(Result);
  end
  else
    Result := VolumeID(DriveChar);
end;

procedure ProcessPath (const EditText: WideString; var Drive: Char;
  var DirPart: WideString; var FilePart: WideString);
var
  SaveDir, Root: WideString;
begin
  //GetDir(0, SaveDir);
  SaveDir := CurrFilePath;
  Drive := Char (SaveDir[1]);
  DirPart := EditText;
  if (DirPart[1] = '[') and (AnsiLastChar(DirPart)^ = ']') then
    DirPart := Copy(DirPart, 2, Length(DirPart) - 2)
  else
  begin
    Root := WideExtractFileDrive(DirPart);
    if Length(Root) = 0 then
      Root := WideExtractFileDrive(SaveDir)
    else
      Delete(DirPart, 1, Length(Root));
    if (Length(Root) >= 2) and (Root[2] = ':') then
      Drive := Char (Root[1])
    else
      Drive := #0;
  end;

  try
    if WideDirectoryExists(Root) then
      //ChDir(Root);
      FCurrFilePath := Root;
    FilePart := WideExtractFileName (DirPart);
    if Length(DirPart) = (Length(FilePart) + 1) then
      DirPart := '''
    else if Length(DirPart) > Length(FilePart) then
      SetLength(DirPart, Length(DirPart) - Length(FilePart) - 1)
    else
    begin
      //GetDir(0, DirPart);
      DirPart := CurrFilePath;
      Delete(DirPart, 1, Length(WideExtractFileDrive(DirPart)));
      if Length(DirPart) = 0 then
        DirPart := ''';
    end;
    if Length(DirPart) > 0 then
      //ChDir (DirPart);  {first go to our new directory}
      SetCurrFilePath (DirPart);
    if (Length(FilePart) > 0) and not
       (((Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0)) or
       WideFileExists(FilePart)) then
    begin
      //ChDir(FilePart);
      SetCurrFilePath (FilePart);
      if Length(DirPart) = 1 then
        DirPart := ''' + FilePart
      else
        DirPart := DirPart + ''' + FilePart;
      FilePart := '';
    end;
    if Drive = #0 then
      DirPart := Root + DirPart;
  finally
    if WideDirectoryExists(SaveDir) then
      //ChDir(SaveDir);  { restore original directory }
      FCurrFilePath := SaveDir;
  end;
end;

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

{ TTntDriveComboBox }

constructor TTntDriveComboBox.Create(AOwner: TComponent);
var
  Temp: ShortString;
begin
  inherited Create(AOwner);
  Style := csOwnerDrawFixed;
  ReadBitmaps;
  //GetDir(0, Temp);
  Temp := CurrFilePath;
  FDrive := Temp[1]; { make default drive selected }
  if FDrive = ''' then FDrive := #0;
  ResetItemHeight;
end;

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

procedure TTntDriveComboBox.BuildList;
var
  DriveNum: Integer;
  DriveChar: Char;
  DriveType: TDriveType;
  DriveBits: set of 0..25;

  procedure AddDrive(const VolName: WideString; Obj: TObject);
  begin
    Items.AddObject(WideFormat('%s: %s',[DriveChar, VolName]), Obj);
  end;

begin
  { fill list }
  Clear;
  Integer(DriveBits) := GetLogicalDrives;
  for DriveNum := 0 to 25 do
  begin
    if not (DriveNum in DriveBits) then Continue;
    DriveChar := Char(DriveNum + Ord('a'));
    DriveType := TDriveType(GetDriveType(PChar(DriveChar + ':'')));
    if TextCase = tcUpperCase then
      DriveChar := Upcase(DriveChar);

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

procedure TTntDriveComboBox.SetDrive(NewDrive: Char);
var
  Item: Integer;
  drv: string;
begin
  if (ItemIndex < 0) or (UpCase(NewDrive) <> UpCase(FDrive)) then
  begin
    if NewDrive = #0 then
    begin
      FDrive := NewDrive;
      ItemIndex := -1;
    end
    else
    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;
    end;
    if FDirList <> nil then FDirList.DriveChange(Drive);
    Change;
  end;
end;

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

procedure TTntDriveComboBox.SetDirListBox (Value: TTntDirectoryListBox);
begin
  if FDirList <> nil then FDirList.FDriveCombo := nil;
  FDirList := Value;
  if FDirList <> nil then
  begin
    FDirList.FDriveCombo := Self;
    FDirList.FreeNotification(Self);
  end;
end;

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

procedure TTntDriveComboBox.DrawItem(Index: Integer; Rect: TRect;
  State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  bmpWidth: Integer;
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   }
    Rect.Left := Rect.Left + bmpWidth + 6;
    Tnt_DrawTextW(Canvas.Handle, PWideChar(Items[Index]), -1, Rect,
             DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
  end;
end;

procedure TTntDriveComboBox.Click;
begin
  inherited Click;
  if ItemIndex >= 0 then
    Drive := Char (Items[ItemIndex][1]);
end;

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

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

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

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

{ TTntDirectoryListBox }

function DirLevel(const PathName: WideString): Integer;  { counts ''' in path }
var
  P: PWideChar;
begin
  Result := 0;
  P := WStrScan(PWideChar(PathName), ''');
  while P <> nil do
  begin
    Inc(Result);
    Inc(P);
    P := WStrScan(P, ''');
  end;
end;

constructor TTntDirectoryListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 145;
  Style := lbOwnerDrawFixed;
  Sorted := False;
  ReadBitmaps;
  //GetDir(0, FDirectory); { initially use current dir on default drive }
  FDirectory := CurrFilePath;
  ResetItemHeight;
end;

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

procedure TTntDirectoryListBox.DriveChange(NewDrive: Char);
begin
  if (UpCase(NewDrive) <> UpCase(Drive)) then
  begin
    if NewDrive <> #0 then
    begin
      //ChDir(NewDrive + ':');
      SetCurrFilePath (NewDrive + ':');
      //GetDir(0, FDirectory);  { store correct directory name }
      FDirectory := CurrFilePath;
    end;
    if not FInSetDir then
    begin
      BuildList;
      Change;
    end;
  end;
end;

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

procedure TTntDirectoryListBox.SetDirLabel (Value: TTntLabel);
begin
  FDirLabel := Value;
  if Value <> nil then Value.FreeNotification(Self);
  SetDirLabelCaption;
end;

procedure TTntDirectoryListBox.SetDir(const NewDirectory: WideString);
begin
     { go to old directory first, in case of incomplete pathname
       and curdir changed - probably not necessary }
  if WideDirectoryExists(FDirectory) then
    //ChDir(FDirectory);
    FCurrFilePath := FDirectory;
  //ChDir(NewDirectory);     { exception raised if invalid dir }
  SetCurrFilePath (NewDirectory);
  //GetDir(0, FDirectory);   { store correct directory name }
  FDirectory := CurrFilePath;
  BuildList;
  Change;
end;

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

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

function TTntDirectoryListBox.DisplayCase(const S: WideString): WideString;
begin
  if FPreserveCase or FCaseSensitive then
    Result := S
  else
    Result := WideLowerCase(S);
end;

function TTntDirectoryListBox.FileCompareText(const A,B: WideString): Integer;
begin
  if FCaseSensitive then
    Result := WideCompareStr(A,B)
  else
    Result := WideCompareText(A,B);
end;

  {
    Reads all directories in ParentDirectory, adds their paths to
    DirectoryList,and returns the number added
  }
function TTntDirectoryListBox.ReadDirectoryNames(const ParentDirectory: WideString;
  DirectoryList: TTntStringList): Integer;
var
  Status: Integer;
  SearchRec: TSearchRecW;
begin
  Result := 0;
  Status := WideFindFirst(SlashSep(ParentDirectory, '*.*'), faDirectory, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.Attr and faDirectory = faDirectory) then
      begin
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
        begin
          DirectoryList.Add(SearchRec.Name);
          Inc(Result);
        end;
      end;
      Status := WideFindNext(SearchRec);
    end;