bsfilectrl.pas

Delphi开发的图象处理软件

var
  Temp: ShortString;
begin
  inherited Create(AOwner);
  OnChange := NewChange;
  OnListBoxDrawItem := DrawItem;
  OnComboBoxDrawItem := DrawItem;
  ReadBitmaps;
  GetDir(0, Temp);
  FDrive := Temp[1]; { make default drive selected }
  if FDrive = '\' then FDrive := #0;
end;

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

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

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

begin
  { fill list }
  Items.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 TbsSkinDriveComboBox.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 TbsSkinDriveComboBox.SetTextCase(NewTextCase: TTextCase);
var
  OldDrive: Char;
begin
  FTextCase := NewTextCase;
  OldDrive := FDrive;
  BuildList;
  SetDrive (OldDrive);
end;

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

procedure TbsSkinDriveComboBox.Loaded;
var
  Temp: String;
begin
  inherited;
  if (csDesigning in ComponentState)
  then
    begin
      GetDir(0, Temp);
      FDrive := Temp[1]; { make default drive selected }
      if FDrive = '\' then FDrive := #0;
      BuildList;
      SetDrive (FDrive);
    end;  
end;

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

procedure TbsSkinDriveComboBox.DrawItem;
var
  Bitmap: TBitmap;
  bmpWidth: Integer;
begin
  Bitmap := TBitmap(Items.Objects[Index]);
  if Bitmap <> nil then
  begin
    bmpWidth := Bitmap.Width;
    Cnvs.BrushCopy(Bounds(TextRect.Left,
               (TextRect.Top + TextRect.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
  else
    bmpWidth := 0;
  Cnvs.TextOut(TextRect.Left + bmpWidth + 6,
               TextRect.Top + RectHeight(TextRect) div 2 - Cnvs.TextHeight('Wg') div 2,
               Items[Index]);
end;

procedure TbsSkinDriveComboBox.NewChange(Sender: TObject);
begin
  if ItemIndex >= 0 then
    Drive := Items[ItemIndex][1];
end;

procedure TbsSkinDriveComboBox.ReadBitmaps;
begin
  { assign bitmap glyphs }
  FloppyBMP := TBitmap.Create;
  FloppyBMP.Handle := LoadBitmap(HInstance, 'BS_FLOPPY');
  FixedBMP := TBitmap.Create;
  FixedBMP.Handle := LoadBitmap(HInstance, 'BS_HARD');
  NetworkBMP := TBitmap.Create;
  NetworkBMP.Handle := LoadBitmap(HInstance, 'BS_NETWORK');
  CDROMBMP := TBitmap.Create;
  CDROMBMP.Handle := LoadBitmap(HInstance, 'BS_CDROM');
  RAMBMP := TBitmap.Create;
  RAMBMP.Handle := LoadBitmap(HInstance, 'BS_RAM');
end;

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

{ TbsSkinDirectoryListBox }

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

constructor TbsSkinDirectoryListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  OnDrawItem := DrawItem;
  Width := 145;
  Sorted := False;
  ReadBitmaps;
  GetDir(0, FDirectory);
end;

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

procedure TbsSkinDirectoryListBox.DriveChange(NewDrive: Char);
begin
  if (UpCase(NewDrive) <> UpCase(Drive)) then
  begin
    if NewDrive <> #0 then
    begin
      {$I-}
      ChDir(NewDrive + ':');
      {$I+}
      if IOResult = 0 then GetDir(0, FDirectory);
    end;
    if (not FInSetDir) and (IOResult = 0) then
    begin
      BuildList;
      Change;
    end;
  end;
end;

procedure TbsSkinDirectoryListBox.SeTbsSkinFileListBox (Value: TbsSkinFileListBox);
begin
  if FFileList <> nil then FFileList.FDirList := nil;
  FFileList := Value;
  if FFileList <> nil then
  begin
    FFileList.FDirList := Self;
    FFileList.FreeNotification(Self);
  end;
end;

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

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

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

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

function TbsSkinDirectoryListBox.DisplayCase(const S: String): String;
begin
  if FPreserveCase or FCaseSensitive then
    Result := S
  else
    Result := AnsiLowerCase(S);
end;

function TbsSkinDirectoryListBox.FileCompareText(const A,B: String): Integer;
begin
  if FCaseSensitive then
    Result := AnsiCompareStr(A,B)
  else
    Result := AnsiCompareFileName(A,B);
end;

  {
    Reads all directories in ParentDirectory, adds their paths to
    DirectoryList,and returns the number added
  }
function TbsSkinDirectoryListBox.ReadDirectoryNames(const ParentDirectory: string;
  DirectoryList: TStringList): Integer;
var
  Status: Integer;
  SearchRec: TSearchRec;
begin
  Result := 0;
  Status := FindFirst(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 := FindNext(SearchRec);
    end;
  finally
    FindClose(SearchRec);
  end;
end;

procedure TbsSkinDirectoryListBox.BuildList;
var
  TempPath: string;
  DirName: string;
  IndentLevel, BackSlashPos: Integer;
  VolFlags: DWORD;
  I: Integer;
  Siblings: TStringList;
  NewSelect: Integer;
  Root: string;
begin
  FStopUpDateHScrollBar := True;
  try
    Items.BeginUpdate;
    Items.Clear;
    IndentLevel := 0;
    Root := ExtractFileDrive(Directory)+'\';
    GetVolumeInformation(PChar(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
      ListBox.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 AnsiLastChar(TempPath)^ <> '\' then
      begin
        BackSlashPos := AnsiPos('\', TempPath);
        while BackSlashPos <> 0 do
        begin
          DirName := Copy(TempPath, 1, BackSlashPos - 1);
          if IndentLevel = 0 then DirName := DirName + '\';
          Delete(TempPath, 1, BackSlashPos);
          ListBox.Items.AddObject(DirName, OpenedBMP);
          Inc(IndentLevel);
          BackSlashPos := AnsiPos('\', TempPath);
        end;
      end;
      Items.AddObject(TempPath, CurrentBMP);
    end;
    NewSelect := Items.Count - 1;
    Siblings := TStringList.Create;
    try
      Siblings.Sorted := True;
        { read all the dir names into Siblings }
      ReadDirectoryNames(Directory, Siblings);
      for i := 0 to Siblings.Count - 1 do
        ListBox.Items.AddObject(Siblings[i], ClosedBMP);
    finally
      Siblings.Free;
    end;
  finally
    Items.EndUpdate;
  end;
  FStopUpDateHScrollBar := False;
  if HandleAllocated then
  begin
    ItemIndex := NewSelect;
    UpDateScrollbar;
  end;
end;

procedure TbsSkinDirectoryListBox.ReadBitmaps;
begin
  OpenedBMP := TBitmap.Create;
  OpenedBMP.LoadFromResourceName(HInstance, 'BS_OPENFOLDER');
  ClosedBMP := TBitmap.Create;
  ClosedBMP.LoadFromResourceName(HInstance, 'BS_CLOSEDFOLDER');
  CurrentBMP := TBitmap.Create;
  CurrentBMP.LoadFromResourceName(HInstance, 'BS_CURRENTFOLDER');
end;

procedure TbsSkinDirectoryListBox.ListBoxDblClick;
begin
  inherited;
  OpenCurrent;
end;

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

function TbsSkinDirectoryListBox.GetFullItemWidth(Index: Integer; ACnvs: TCanvas): Integer;
var
  bmpWidth, dirOffset: Integer;
  BitMap: TBitMap;
begin
  Result := inherited GetFullItemWidth(Index, ACnvs);
  bmpWidth  := 16;
  dirOffset := Index * 4 + 2;
  Bitmap := TBitmap(ListBox.Items.Objects[Index]);
  if Bitmap <> nil
  then
    begin
      if Bitmap = ClosedBMP then
         dirOffset := (DirLevel (Directory) + 1) * 4 + 2;
      bmpWidth := Bitmap.Width;   
    end;
  Result := Result + DirOffset + bmpWidth + 4;
end;

procedure TbsSkinDirectoryListBox.DrawItem(Cnvs: TCanvas; Index: Integer;
       ItemWidth, ItemHeight: Integer; TextRect: TRect; State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  bmpWidth: Integer;
  dirOffset: Integer;
  R: TRect;
begin
  bmpWidth  := 16;
  dirOffset := Index * 4 + 2;
  Bitmap := TBitmap(ListBox.Items.Objects[Index]);
  if Bitmap <> nil then
  begin
    if Bitmap = ClosedBMP then
       dirOffset := (DirLevel (Directory) + 1) * 4 + 2;
    bmpWidth := Bitmap.Width;
    Cnvs.BrushCopy(Bounds(TextRect.Left + dirOffset - ListBox.HorizontalExtentValue,
               (TextRect.Top + TextRect.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;
  R := TextRect;
  Cnvs.Brush.Style := bsClear;
  BSDrawText3(Cnvs, Items[Index], R, bmpWidth + dirOffset + 4 - ListBox.HorizontalExtentValue);
end;

function TbsSkinDirectoryListBox.GetItemPath (Index: Integer): string;
var
  CurDir: string;
  i, j: Integer;
  Bitmap: TBitmap;
begin
  Result := '';
  if Index < Items.Count then
  begin
    CurDir := Directory;
    Bitmap := TBitmap(Items.Objects[Index]);
    if Index = 0 then
      Result := ExtractFileDrive(CurDir)+'\'
    else if Bitmap = ClosedBMP then
      Result := SlashSep(CurDir,Items[Index])
    else if Bitmap = CurrentBMP then
      Result := CurDir
    else
    begin
      i   := 0;