今週末は、プロッピー三昧でした。
みなさまにもお裾分けを。
ほとんどFDELPHIの過去ログにあった物を
アレンジしただけですが。

type
  TRemovableDiskState = (
    reOK,
    reProtect,
    reUnInserting,
    reUnFormatting,
    reNotRemovable,
    reUnknownError
  );

function RemovableState(const ADrive: Char): TRemovableDiskState;
function FloppyState: TRemovableDiskState;
procedure DeleteFloppy;
procedure DeleteFiles(const Dir: string); overload;
procedure DeleteFiles(const Dir, FindStr: string); overload;
function IsRemovable(const ADrive: Char): Boolean;
function IsFDDrive(const ADrive: Char): Boolean;
function FDDriveStr: string;
function FDDriveIndex: Byte;

implementation

uses ShellAPI, FileCtrl;//他にも必要かも？

function RemovableState(const ADrive: Char): TRemovableDiskState;
var
  rc, er: HFILE;
  sa: TSecurityAttributes;
  dummy: string;
  defMode: UINT;
begin
  if not IsRemovable(ADrive) then
  begin
    Result := reNotRemovable;
    Exit;
  end;

  repeat
    dummy := Format(ADrive + ':\%.3f', [Time * 100000000]);
  until not FileExists(dummy);

  rc := 0;
  defMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    sa.nLength := SizeOf(TSecurityAttributes);
    sa.lpSecurityDescriptor := nil;
    sa.bInheritHandle := True;
    rc := CreateFile(PChar(dummy), GENERIC_WRITE, 0, @sa,
      CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
    er := GetLastError;
    if er <> 0 then
    begin
      case er of
        19  : Result := reProtect;
        21  : Result := reUnInserting;
        1005: Result := reUnFormatting;
      else
        Result := reUnknownError;
      end;
    end
    else
      Result := reOK;
  finally
    if rc <> 0 then
      CloseHandle(rc);
    DeleteFile(dummy);
    SetErrorMode(defMode);
  end;
end;

function FloppyState: TRemovableDiskState;
var
  b: Byte;
begin
  b := FDDriveIndex;
  if b = 0 then
    Result := reUnknownError
  else
    Result := RemovableState(Char(Ord('A') + b - 1));
end;

procedure DeleteFloppy;
var
  d: string;
begin
  d := FDDriveStr;
  if d = '' then
    raise Exception.Create('フロッピードライブが見つかりません。');
  DeleteFiles(d);
end;

procedure DeleteFiles(const Dir: string);
begin
  DeleteFiles(Dir, '*');
end;

procedure DeleteFiles(const Dir, FindStr: string);
  procedure Del(const Dir: string);
  var
    sr: TSearchRec;
    d,f: string;
  begin
    d := IncludeTrailingBackslash(Dir);

    if FindFirst(d + FindStr, faAnyFile, sr) = 0 then
      try
        repeat
          f := d + sr.Name;
          if (sr.Attr and faReadOnly) > 0 then
            FileSetAttr(f, sr.Attr - faReadOnly);
          if (sr.Attr and faDirectory) > 0 then
          begin
            if (sr.Name <> '.') and (sr.Name <> '..') then
            begin
              Del(f);
              RemoveDir(f);
            end;
          end
          else
            Deletefile(f);
        until FindNext(sr) <> 0;
      finally
        FindClose(sr);
      end;
  end;
begin
  Del(Dir);
end;

function IsFDDrive(const ADrive: Char): Boolean;
var
  d: string;
  fi: TSHFileInfo;
begin
  d := ADrive + ':\';
  Result := (GetDriveType(PChar(d)) = DRIVE_REMOVABLE)
    and (SHGetFileInfo(PChar(d), 0, fi, SizeOf(fi), SHGFI_DISPLAYNAME) <> 0)
    and (Pos(' FD (', UpperCase(fi.szDisplayName)) > 0);
end;

function IsRemovable(const ADrive: Char): Boolean;
begin
  Result := GetDriveType(PChar(ADrive + ':\')) = DRIVE_REMOVABLE;
end;

function FDDriveIndex: Byte;
var
  x: DWORD;
  i: Integer;
begin
  Result := 0;
  x := GetLogicalDrives;
  for i := 0 to Ord('Z') - Ord('A') do
    if LongBool(x and ($0001 shl i)) then
      if IsFDDrive(Char(Ord('A') + i)) then
      begin
        Result := i + 1;
        Exit;
      end;
end;

function FDDriveStr: string;
var
  b: Byte;
begin
  b := FDDriveIndex;
  if b > 0 then
    Result := Char(Ord('A') + b - 1) + ':\'
  else
    Result := '';
end;

                                     02/04/21(日)  かつぼー(CQU00157)
 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 02/04/23 -

Original document by かつぼー        氏 ID:(CQU00157)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。