disqlite3_drive_catalog_form_add.pas

来自「DELPHI 访问SQLITE3 数据库的VCL控件」· PAS 代码 · 共 342 行

{ Visit the DISQLite3 Internet site for latest information and updates:

    http://www.yunqa.de/delphi/

  Copyright (c) 2005-2007 Ralf Junker, The Delphi Inspiration <[e-mail]>

------------------------------------------------------------------------------ }

unit DISQLite3_Drive_Catalog_Form_Add;

{$I DI.inc}
{$I DISQLite3.inc}

interface

uses
  Classes, Controls, Forms, StdCtrls, ShlObj,
  TntForms, TntStdCtrls,
  DISHChangeNotify,
  DISQLite3_Drive_Catalog_DB;

type

  { }
  TScanState = (ssReady, ssRunning, ssCancelled);

  { }
  TAutoUpdate = (auNone, auEmpty, auForce);

  //------------------------------------------------------------------------------
  // TfrmAdd Form
  //------------------------------------------------------------------------------

  { }
  TfrmAdd = class(TTntForm)
    edtRootFolder: TTntEdit;
    lblRootFolder: TTntLabel;
    lblName: TTntLabel;
    edtName: TTntEdit;
    btnClose: TTntButton;
    btnStartStop: TTntButton;
    btnBrowse: TTntButton;
    lblProgress: TTntLabel;
    btnUpdate: TTntButton;
    procedure btnStartStop_Click(Sender: TObject);
    procedure edtRootFolderChange(Sender: TObject);
    procedure Form_Create(Sender: TObject);
    procedure btnBrowseClick(Sender: TObject);
    procedure edtNameChange(Sender: TObject);
    procedure btnClose_Click(Sender: TObject);
    procedure Form_CloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure btnUpdateClick(Sender: TObject);
    procedure Form_Destroy(Sender: TObject);
    procedure Form_KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    FDB: TDriveCatalogDB;
    FAutoName: Boolean;
    FNotify: TDISHChangeNotify;
    FState: TScanState;
    procedure AddDriveCallback(const AFolder: WideString; var AAbort: Boolean);
    procedure ShChangeNotify(
      const ASender: TDICustomSHChangeNotify;
      const AEvent: Cardinal;
      const APidl1, APidl2: PItemIDList);
  protected
    procedure UpdateName(const AUpdate: TAutoUpdate);
  public
    function GetRootFolder: WideString;
    property DB: TDriveCatalogDB read FDB write FDB;
  end;

implementation

uses
  Windows, {$IFDEF COMPILER_9_UP}WideStrUtils, {$ENDIF}
  TntWindows, TntSysUtils, TntFileCtrl, {$IFNDEF COMPILER_9_UP}TntWideStrUtils, {$ENDIF}
  DISQLite3_Drive_Catalog_Form_Main;

{$R *.dfm}

//------------------------------------------------------------------------------
// Helpers
//------------------------------------------------------------------------------

function GetVolumeName(AFolder: WideString): WideString;
var
  lpMaximumComponentLength: Cardinal;
  lpFileSystemFlags: Cardinal;
begin
  AFolder := WideIncludeTrailingPathDelimiter(WideExtractFileDrive(AFolder));
  if AFolder <> '' then
    begin
      SetString(Result, nil, MAX_PATH);
      if Tnt_GetVolumeInformationW(
        PWideChar(AFolder),
        Pointer(Result),
        MAX_PATH,
        nil,
        lpMaximumComponentLength,
        lpFileSystemFlags,
        nil,
        0) then
        begin
          SetLength(Result, WStrLen(Pointer(Result)));
          Exit;
        end;
    end;
  Result := '';
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.Form_Create(Sender: TObject);
begin
  btnStartStop.Enabled := False;
  FNotify := TDISHChangeNotify.Create(nil);
  FNotify.Events :=
    SHCNE_RMDIR or
    SHCNE_MEDIAINSERTED or
    SHCNE_MEDIAREMOVED or
    SHCNE_DRIVEREMOVED or
    SHCNE_DRIVEADD;
  FNotify.OnNotify := ShChangeNotify;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.Form_Destroy(Sender: TObject);
begin
  FNotify.Free;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.Form_CloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := FState = ssReady;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.Form_KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_F5 then
    UpdateName(auForce);
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.AddDriveCallback(
  const AFolder: WideString;
  var AAbort: Boolean);
begin
  lblProgress.Caption := AFolder;
  Application.ProcessMessages;
  if FState = ssCancelled then
    AAbort := True;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.btnStartStop_Click(Sender: TObject);
var
  NewID: Int64;
begin
  case FState of

    ssReady:
      try
        FState := ssRunning;
        btnStartStop.Caption := 'Stop';
        btnClose.Enabled := False;
        NewID := FDB.AddVolume(edtName.Text, GetRootFolder, AddDriveCallback);
        if FState = ssCancelled then
          lblProgress.Caption := 'Cancelled'
        else
          begin
            lblProgress.Caption := 'Done';
            if Owner is TfrmMain then
              (Owner as TfrmMain).folderTree_AddVolume(NewID);
          end;
      finally
        if FState <> ssCancelled then
          FAutoName := True;
        btnStartStop.Caption := 'Start';
        btnClose.Enabled := True;
        FState := ssReady;
      end;

    ssRunning:
      begin
        FState := ssCancelled;
      end;
  end;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.btnClose_Click(Sender: TObject);
begin
  if FState = ssReady then
    ModalResult := mrCancel;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.btnBrowseClick(Sender: TObject);
var
  s: WideString;
begin
  if WideSelectDirectory('Select the root Drive or Folder:', '', s) then
    edtRootFolder.Text := s;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.btnUpdateClick(Sender: TObject);
begin
  UpdateName(auForce);
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.edtNameChange(Sender: TObject);
begin
  FAutoName := False;
  UpdateName(auNone);
end;

//------------------------------------------------------------------------------

function TfrmAdd.GetRootFolder: WideString;
begin
  Result := edtRootFolder.Text;
  if Length(Result) = 1 then
    case Result[1] of
      'A'..'Z', 'a'..'z':
        Result := Result + ':';
    end;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.ShChangeNotify(
  const ASender: TDICustomSHChangeNotify;
  const AEvent: Cardinal;
  const APidl1, APidl2: PItemIDList);
begin
  case AEvent of
    SHCNE_RMDIR, SHCNE_MEDIAREMOVED, SHCNE_DRIVEREMOVED:
      UpdateName(auEmpty);
    SHCNE_MEDIAINSERTED, SHCNE_DRIVEADD:
      UpdateName(auEmpty);
  end;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.UpdateName(const AUpdate: TAutoUpdate);
var
  DirExists: Boolean;
  OldErrorMode: Cardinal;
  rf: WideString;
begin
  rf := GetRootFolder;

  { Suppress the message box which is displayed by GetFileAttributes (called by
    WideDirectoryExists below) on WinNT4 if a removable drive has no media.

    The following explanation is from Win32 Help, GetVolumeInformation:

    If you are attempting to obtain information about a floppy drive that does
    not have a floppy disk or a CD-ROM drive that does not have a compact disc,
    the system displays a message box asking the user to insert a floppy disk or
    a compact disc, respectively. To prevent the system from displaying this
    message box, call the SetErrorMode function with SEM_FAILCRITICALERRORS. }
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    DirExists := WideDirectoryExists(rf);

    if (AUpdate = auForce) or
      ((AUpdate = auEmpty) and (edtName.Text = '')) or
      FAutoName then
      if DirExists then
        begin
          edtName.Text := GetVolumeName(rf);
          FAutoName := True;
        end
      else
        edtName.Text := '';

    btnStartStop.Enabled := DirExists and (edtName.Text <> '')
  finally
    SetErrorMode(OldErrorMode);
  end;
end;

//------------------------------------------------------------------------------

procedure TfrmAdd.edtRootFolderChange(Sender: TObject);
var
  rf: WideString;
  OldErrorMode: Cardinal;
  OldPidl, NewPidl: PItemIDList;
begin
  OldPidl := FNotify.NotifyPidl;

  rf := GetRootFolder;
  { Check if directory exists first, because PathToPidl can take a long time
    on networks. }
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if WideDirectoryExists(rf) then
      NewPidl := PathToPidl(rf)
    else
      NewPidl := nil;
  finally
    SetErrorMode(OldErrorMode);
  end;

  if Assigned(NewPidl) then
    begin
      FNotify.NotifyPidl := NewPidl;
      FNotify.Active := True;
    end
  else
    begin
      FNotify.Active := False;
      FNotify.NotifyPidl := nil;
    end;

  FreePidl(OldPidl);

  UpdateName(auEmpty);
end;

//------------------------------------------------------------------------------

end.