bsfilectrl.pas

Delphi开发的图象处理软件

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 2.74                                                }
{                                                                   }
{       Copyright (c) 2000-2004 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

unit bsfilectrl;

{$R-,T-,H+,X+}

interface

uses Windows, Messages, SysUtils, Classes, Controls, Graphics, Forms,
  Menus, StdCtrls, Buttons, bsSkinBoxCtrls, bsSkinCtrls;

type
  TFileAttr = (ftReadOnly, ftHidden, ftSystem, ftVolumeID, ftDirectory,
    ftArchive, ftNormal);
  TFileType = set of TFileAttr;

  TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
    dtRAM);

  TbsSkinDirectoryListBox = class;
  TbsSkinFilterComboBox = class;
  TbsSkinDriveComboBox = class;

{ TbsSkinFileListBox }

  TbsSkinFileListBox = class(TbsSkinListBox)
  private
    function GetDrive: char;
    function GetFileName: string;
    function IsMaskStored: Boolean;
    procedure SetDrive(Value: char);
    procedure SetFileEdit(Value: TEdit);
    procedure SetDirectory(const NewDirectory: string);
    procedure SetFileType(NewFileType: TFileType);
    procedure SetMask(const NewMask: string);
    procedure SetFileName(const NewFile: string);
  protected
    FDirectory: string;
    FMask: string;
    FFileType: TFileType;
    FFileEdit: TEdit;
    FDirList: TbsSkinDirectoryListBox;
    FFilterCombo: TbsSkinFilterComboBox;
    FOnChange: TNotifyEvent;
    FLastSel: Integer;
    procedure CreateWnd; override;
    procedure ListBoxClick; override;
    procedure Change; virtual;
    procedure ReadFileNames; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetFilePath: string; virtual;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update; reintroduce;
    procedure ApplyFilePath (const EditText: string); virtual;
    property Drive: char read GetDrive write SetDrive;
    property Directory: string read FDirectory write ApplyFilePath;
    property FileName: string read GetFilePath write ApplyFilePath;
  published
    property Align;
    property Anchors;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FileEdit: TEdit read FFileEdit write SetFileEdit;
    property FileType: TFileType read FFileType write SetFileType default [ftNormal];
    property Font;
    property ImeMode;
    property ImeName;
    property Mask: string read FMask write SetMask stored IsMaskStored;
    property MultiSelect;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

{ TbsDirectoryListBox }

  TbsSkinDirectoryListBox = class(TbsSkinListBox)
  private
    FFileList: TbsSkinFileListBox;
    FDriveCombo: TbsSkinDriveComboBox;
    FDirLabel: TbsSkinStdLabel;
    FInSetDir: Boolean;
    FPreserveCase: Boolean;
    FCaseSensitive: Boolean;
    function GetDrive: char;
    procedure SeTbsSkinFileListBox(Value: TbsSkinFileListBox);
    procedure SetDirLabel(Value: TbsSkinStdLabel);
    procedure SetDirLabelCaption;
    procedure SetDrive(Value: char);
    procedure DriveChange(NewDrive: Char);
    procedure SetDir(const NewDirectory: string);
    procedure SetDirectory(const NewDirectory: string); virtual;
  protected
    ClosedBMP, OpenedBMP, CurrentBMP: TBitmap;
    FDirectory: string;
    FOnChange: TNotifyEvent;
    procedure Change; virtual;
    procedure ListBoxDblClick; override;
    procedure ReadBitmaps; virtual;
    procedure CreateWnd; override;
    procedure DrawItem(Cnvs: TCanvas; Index: Integer;
       ItemWidth, ItemHeight: Integer; TextRect: TRect; State: TOwnerDrawState);
    function  ReadDirectoryNames(const ParentDirectory: string;
      DirectoryList: TStringList): Integer;
    procedure BuildList; virtual;
    procedure ListBoxKeyPress(var Key: Char); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Loaded; override;
    function GetFullItemWidth(Index: Integer; ACnvs: TCanvas): Integer; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function  DisplayCase(const S: String): String;
    function  FileCompareText(const A, B: String): Integer;
    function GetItemPath(Index: Integer): string;
    procedure OpenCurrent;
    procedure Update; reintroduce;
    property Drive: Char read GetDrive write SetDrive;
    property Directory: string read FDirectory write SetDirectory;
    property PreserveCase: Boolean read FPreserveCase;
    property CaseSensitive: Boolean read FCaseSensitive;
  published
    property Align;
    property Anchors;
    property Color;
    property Columns;
    property Constraints;
    property Ctl3D;
    property DirLabel: TbsSkinStdLabel read FDirLabel write SetDirLabel;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FileList: TbsSkinFileListBox read FFileList write SeTbsSkinFileListBox;
    property Font;
    property ImeMode;
    property ImeName;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

{ TbsSkinDriveComboBox }

  TTextCase = (tcLowerCase, tcUpperCase);

  TbsSkinDriveComboBox = class(TbsSkinComboBox)
  private
    FDirList: TbsSkinDirectoryListBox;
    FDrive: Char;
    FTextCase: TTextCase;
    procedure SetDirListBox (Value: TbsSkinDirectoryListBox);
    procedure SetDrive(NewDrive: Char);
    procedure SetTextCase(NewTextCase: TTextCase);
    procedure ReadBitmaps;
  protected
    FloppyBMP, FixedBMP, NetworkBMP, CDROMBMP, RAMBMP: TBitmap;
    procedure CreateWnd; override;
    procedure DrawItem(Cnvs: TCanvas; Index: Integer;
       ItemWidth, ItemHeight: Integer; TextRect: TRect; State: TOwnerDrawState);
    procedure NewChange(Sender: TObject);
    procedure BuildList; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text;
    property Drive: Char read FDrive write SetDrive;
  published
    property Anchors;
    property Color;
    property Constraints;
    property Ctl3D;
    property DirList: TbsSkinDirectoryListBox read FDirList write SetDirListBox;
    property DragMode;
    property DragCursor;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property TextCase: TTextCase read FTextCase write SetTextCase default tcLowerCase;
    property Visible;
    property OnChange;
  end;

{ TFilterComboBox }

  TbsSkinFilterComboBox = class(TbsSkinComboBox)
  private
    FFilter: string;
    FFileList: TbsSkinFileListBox;
    MaskList: TStringList;
    function IsFilterStored: Boolean;
    function GetMask: string;
    procedure SetFilter(const NewFilter: string);
    procedure SeTbsSkinFileListBox (Value: TbsSkinFileListBox);
  protected
    procedure Change; override;
    procedure CreateWnd; override;
    procedure Click; override;
    procedure BuildList;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Mask: string read GetMask;
    property Text;
  published
    property Anchors;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragMode;
    property DragCursor;
    property Enabled;
    property FileList: TbsSkinFileListBox read FFileList write SeTbsSkinFileListBox;
    property Filter: string read FFilter write SetFilter stored IsFilterStored;
    property Font;
    property ImeName;
    property ImeMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange;
    property OnClick;
  end;

procedure ProcessPath (const EditText: string; var Drive: Char;
  var DirPart: string; var FilePart: string);

function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  MaxLen: Integer): TFileName;

const
  WNTYPE_DRIVE = 1;

type
  TSelectDirOpt = (sdAllowCreate, sdPerformCreate, sdPrompt);
  TSelectDirOpts = set of TSelectDirOpt;

function DirectoryExists(const Name: string): Boolean;
function ForceDirectories(Dir: string): Boolean;

implementation

uses Consts, Dialogs, bsUtils;

{$R bsfilectrl}

function DirectoryExists(const Name: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Name));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

function ForceDirectories(Dir: string): Boolean;
begin
  Result := True;
  Dir := ExcludeTrailingBackslash(Dir);
  if (Length(Dir) < 3) or DirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit;
  Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;

function SlashSep(const Path, S: String): String;
begin
  if AnsiLastChar(Path)^ <> '\' then
    Result := Path + '\' + S
  else
    Result := Path + S;
end;

{ TbsSkinDriveComboBox }

procedure CutFirstDirectory(var S: TFileName);
var
  Root: Boolean;
  P: Integer;
begin
  if S = '\' then
    S := ''
  else
  begin
    if S[1] = '\' then
    begin
      Root := True;
      Delete(S, 1, 1);
    end
    else
      Root := False;
    if S[1] = '.' then
      Delete(S, 1, 4);
    P := AnsiPos('\',S);
    if P <> 0 then
    begin
      Delete(S, 1, P);
      S := '...\' + S;
    end
    else
      S := '';
    if Root then
      S := '\' + S;
  end;
end;

function MinimizeName(const Filename: TFileName; Canvas: TCanvas;
  MaxLen: Integer): TFileName;
var
  Drive: TFileName;
  Dir: TFileName;
  Name: TFileName;
begin
  Result := FileName;
  Dir := ExtractFilePath(Result);
  Name := ExtractFileName(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 := Format('[%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: string; var Drive: Char;
  var DirPart: string; var FilePart: string);
var
  SaveDir, Root: string;
begin
  GetDir(0, SaveDir);
  Drive := SaveDir[1];
  DirPart := EditText;
  if (DirPart[1] = '[') and (AnsiLastChar(DirPart)^ = ']') then
    DirPart := Copy(DirPart, 2, Length(DirPart) - 2)
  else
  begin
    Root := ExtractFileDrive(DirPart);
    if Length(Root) = 0 then
      Root := ExtractFileDrive(SaveDir)
    else
      Delete(DirPart, 1, Length(Root));
    if (Length(Root) >= 2) and (Root[2] = ':') then
      Drive := Root[1]
    else
      Drive := #0;
  end;

  try
    if DirectoryExists(Root) then
      ChDir(Root);
    FilePart := ExtractFileName (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);
      Delete(DirPart, 1, Length(ExtractFileDrive(DirPart)));
      if Length(DirPart) = 0 then
        DirPart := '\';
    end;
    if Length(DirPart) > 0 then
      ChDir (DirPart);  {first go to our new directory}
    if (Length(FilePart) > 0) and not
       (((Pos('*', FilePart) > 0) or (Pos('?', FilePart) > 0)) or
       FileExists(FilePart)) then
    begin
      ChDir(FilePart);
      if Length(DirPart) = 1 then
        DirPart := '\' + FilePart
      else
        DirPart := DirPart + '\' + FilePart;
      FilePart := '';
    end;
    if Drive = #0 then
      DirPart := Root + DirPart;
  finally
    if DirectoryExists(SaveDir) then
      ChDir(SaveDir);  { restore original directory }
  end;
end;

{ TbsSkinDriveComboBox }

constructor TbsSkinDriveComboBox.Create(AOwner: TComponent);