unit ehXDeviceChange;
{
ehXDeviceChange
################
Component for event notification when a system volume has been mounted or unmounted
(e.g. removable drives or media)
Author: blackFin
Email: blackfin@elfenherz.de
For: The "Delphi Praxis" community (http://www.delphipraxis.net/)
Date of creation: 15.08.2011
License:
Do what you want with it, but there is one thing that always makes me happy:
##############################################################################
If you modify the source and / or enhance this component,
pleeeease, send your modified source code back to me via email.
##############################################################################
}
interface
uses
Windows,Messages,SysUtils,Classes,Forms
;
type
// Events
TehXDeviceMountedEvent =
procedure(ADrive: Char; ADriveName:
string)
of object ;
TehXDeviceUnmountedEvent =
procedure(ADrive: Char; ADriveName:
string)
of object ;
// Class declaration of device change notifier
TehXDeviceChangeNotifier =
class(TComponent)
private
FDriveList :
array of array[0..1]
of string ;
FMessageHook : boolean ;
FVolumesMapped : boolean ;
FOnDeviceMounted : TehXDeviceMountedEvent ;
FOnDeviceUnmounted : TehXDeviceUnmountedEvent ;
function FDoMessageHook(
var Msg: TMessage): boolean ;
procedure FOnWMDeviceChange(
var Msg: TMessage);
function FGetVolumeName(FDrive: Char):
string;
protected
public
constructor Create(AOwner: TComponent) ;
override ;
destructor Destroy() ;
override ;
procedure CreateVolumeMapping() ;
function GetVolumeName(FDrive: char):
string;
published
property OnDeviceMounted: TehXDeviceMountedEvent
read FOnDeviceMounted
write FOnDeviceMounted ;
property OnDeviceUnmounted: TehXDeviceUnmountedEvent
read FOnDeviceUnmounted
write FOnDeviceUnmounted ;
end;
procedure Register;
implementation
const
DRIVE_UNKNOWN = 0;
DRIVE_NO_ROOT_DIR = 1;
DRIVE_REMOVABLE = 2;
DRIVE_FIXED = 3;
DRIVE_REMOTE = 4;
DRIVE_CDROM = 5;
DRIVE_RAMDISK = 6;
// CONSTRUKTOR
constructor TehXDeviceChangeNotifier.Create(AOwner: TComponent) ;
begin
inherited Create(AOwner) ;
FVolumesMapped := false ;
if not (csDesigning
in ComponentState)
then
begin
Application.HookMainWindow(FDoMessageHook);
FMessageHook := True;
self.CreateVolumeMapping() ;
end;
end;
// DESTRUCTOR
destructor TehXDeviceChangeNotifier.Destroy() ;
begin
SetLength(FDriveList,0) ;
if FMessageHook
then Application.UnhookMainWindow(FDoMessageHook);
inherited Destroy() ;
end;
// message hook from main window
function TehXDeviceChangeNotifier.FDoMessageHook(
var Msg: TMessage): boolean;
begin
Result := False;
case Msg.Msg
of
WM_DEVICECHANGE:
begin
FOnWMDeviceChange(Msg);
Result := true ;
end;
end;
end;
// on device change
procedure TehXDeviceChangeNotifier.FOnWMDeviceChange(
var Msg: TMessage);
type
PDevBroadcastHdr = ^TDevBroadcastHdr;
TDevBroadcastHdr =
packed record
dbcd_size, dbcd_devicetype, dbcd_reserved: DWORD;
end;
PDevBroadcastVolume = ^TDevBroadcastVolume;
TDevBroadcastVolume =
packed record
dbcv_size, dbcv_devicetype, dbcv_reserved, dbcv_unitmask: DWORD;
dbcv_flags: Word;
end;
function GetDrive(pDBVol: PDevBroadcastVolume):
string;
var
i: Byte;
VolumeMask: DWORD;
begin
case (pDBVol^.dbcv_flags)
of
// removable MEDIA
0:
begin
// todo: do something with this information
end;
// removable DRIVE
1:
begin
// todo: do something with this information
end;
end;
VolumeMask := pDBVol^.dbcv_unitmask;
for i := 0
to 25
do
begin
if (VolumeMask
and 1) = 1
then Result := Char(i + Ord('
A')) + '
: ';
VolumeMask := VolumeMask
shr 1;
end;
end;
var Drive,DriveName:
String;
begin
case Msg.wParam
of
// drive has been mounted
$8000:
if PDevBroadcastHdr(Msg.lParam)^.dbcd_devicetype = $0002
then
begin
Drive := GetDrive(PDevBroadcastVolume(Msg.lParam));
DriveName := FGetVolumeName(Drive[1]) ;
self.CreateVolumeMapping() ;
if Assigned(FOnDeviceMounted)
then FOnDeviceMounted(Drive[1],DriveName) ;
end;
// drive has been unmounted
$8004:
if PDevBroadcastHdr(Msg.lParam)^.dbcd_devicetype = $0002
then
begin
Drive := GetDrive(PDevBroadcastVolume(Msg.lParam));
if Assigned(FOnDeviceUnmounted)
then FOnDeviceUnmounted(Drive[1],self.GetVolumeName(Drive[1])) ;
self.CreateVolumeMapping() ;
end;
end;
end;
// get the name of a volume (internally, from sytem)
function TehXDeviceChangeNotifier.FGetVolumeName(FDrive: Char):
string;
var
max, Flags: DWORD;
Buf:
array [0..MAX_PATH]
of Char;
SN: DWORD;
FileSys:
Array[0..MAX_PATH]
of Char;
begin
try
GetVolumeInformation(PChar(
string(FDrive + '
:')), @Buf[0], sizeof(Buf), @SN, max, Flags, @FileSys, 0);
Result := Buf;
except
result := '
';
end;
end;
// get the name of a volume (from volume mapping)
function TehXDeviceChangeNotifier.GetVolumeName(FDrive: char):
string;
var
i: Integer ;
begin
if (
not FVolumesMapped)
then self.CreateVolumeMapping() ;
Result := '
' ;
for i := 0
to High(FDriveList)
do
begin
if FDriveList[i][0] = FDrive
then
begin
Result := FDriveList[i][1] ;
break ;
end;
end;
end;
// get all currently available volume names
procedure TehXDeviceChangeNotifier.CreateVolumeMapping() ;
var
r: LongWord;
Drives:
array[0..128]
of char;
pDrive: PChar;
begin
SetLength(FDriveList,0) ;
r := GetLogicalDriveStrings(SizeOf(Drives), Drives);
if r = 0
then Exit;
if r > SizeOf(Drives)
then
raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));
pDrive := Drives;
while pDrive^ <> #0
do
begin
case GetDriveType(pDrive)
of
DRIVE_FIXED,
DRIVE_CDROM,
DRIVE_REMOVABLE:
begin
// Anyone that uses still floppy drives? No, Tux SysAdmins, not you! :-)
// Well, I've skipped reading the mapping on floppy drives A:\ and B:\ because reading the volume names of floppy drives is sooo slow :-(
// Unfortunately, floppy drives have no own DriveType, they are listed as DRIVE_REMOVABLE, so extra handling of those is not clearly possible.
// (comment out next line if you want to enable volume mapping on floppy dives A:\ and B:\, too)
if ( (pDrive <> '
A:\')
and (pDrive <> '
B:\') )
then
begin
SetLength(FDriveList,High(FDriveList)+2) ;
FDriveList[High(FDriveList)][0] :=
string(pDrive[0]) ;
FDriveList[High(FDriveList)][1] := self.FGetVolumeName(pDrive[0]) ;
end;
end;
end;
Inc(pDrive,4);
end;
FVolumesMapped := true ;
end;
// Register component in ehX Toolbar
procedure Register;
begin
RegisterComponents('
ehX', [TehXDeviceChangeNotifier]);
end;
end.