unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Windows, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 =
class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
OldWProc: WNDPROC;
implementation
{$R *.lfm}
{ TForm1 }
const DBT_DEVICEARRIVAL = $8000;
//const DBT_DEVICEQUERYREMOVE = $8001;
//const DBT_DEVICEQUERYREMOVEFAILED = $8002;
//const DBT_DEVICEREMOVEPENDING = $8003;
const DBT_DEVICEREMOVECOMPLETE = $8004;
//const DBT_DEVICETYPESPECIFIC = $8005;
//const DBT_CONFIGCHANGED = $0018;
procedure MM(s:
string);
begin Form1.Memo1.lines.add(s);
end;
procedure FindDrives;
var
Drive: Char;
DriveLetter:
string;
begin
MM('
The following drives were found in this computer:');
MM('
');
// Search all drive letters
for Drive := '
A'
to '
Z'
do
begin
DriveLetter := Drive + '
:\';
case GetDriveType(PChar(DriveLetter))
of
DRIVE_REMOVABLE: MM(DriveLetter + '
USB Stick/Drive');
DRIVE_FIXED: MM(DriveLetter + '
Fixed Drive');
DRIVE_REMOTE: MM(DriveLetter + '
Network Drive');
DRIVE_CDROM: MM(DriveLetter + '
CD/DVD/BR Drive');
DRIVE_RAMDISK: MM(DriveLetter + '
RAM Disk');
end;
end;
MM('
------------------------------------------------');
end;
function MyWndProc(hWnd: HWND; uiMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
stdcall;
begin
case uiMsg
of
WM_DEVICECHANGE:
case wParam
of
DBT_DEVICEARRIVAL:
begin
Windows.Beep(1000,250); Windows.Beep(1500,250);
Form1.Memo1.clear;
MM('
DEVICECHANGE: Drive added.');
FindDrives;
Exit;
end;
DBT_DEVICEREMOVECOMPLETE:
begin
Windows.Beep(2000,250); Windows.Beep(1500,250);
Form1.Memo1.clear;
MM('
DEVICECHANGE: Drive removed.');
FindDrives;
Exit;
end;
end;
end;
Result := CallWindowProc(OldWProc, hWnd, uiMsg, wParam, lParam);
end;
procedure SetMyWndProc(
Handle : THandle);
begin
OldWProc := WNDPROC(SetWindowLongPtr(
Handle, GWL_WNDPROC, LONG_PTR(@MyWndProc)));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SetMyWndProc(
Handle);
FindDrives;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.clear;
FindDrives;
end;
end.