Kopiuj
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: François PIETTE @ www.overbyte.be
Creation: March 17, 2013
Description: Worker thread having a message pump, working mostly like
the main thread. Intended to be the base class for your own
worker threads: all methods are virtual.
Version: 1.00
History:
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit MsgHandlingWorkerThread;
interface
uses
Windows, Messages, Classes, SysUtils;
type
TMsgHandlingWorkerThread = class(TThread)
protected
FHandle : HWND;
procedure AllocateHWnd; virtual;
procedure DeallocateHWnd; virtual;
procedure MessageLoop; virtual;
function GetHandle: HWND; virtual;
public
constructor Create(Suspended : Boolean); virtual;
procedure Execute; override;
procedure WndProc(var MsgRec: TMessage); virtual;
property Handle : HWND read GetHandle;
end;
implementation
var
GWndHandleCount : Integer;
GWndHandlerCritSect : TRTLCriticalSection;
const
WinThreadWindowClassName = 'WinThreadWindowClass';
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Forward declaration for our Windows callback function
function WndControlWindowsProc(
ahWnd : HWND;
auMsg : UINT;
awParam : WPARAM;
alParam : LPARAM): LRESULT; stdcall; forward;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMsgHandlingWorkerThread.AllocateHWnd;
var
TempClass : TWndClass;
WinThreadWindowClass : TWndClass;
ClassRegistered : Boolean;
begin
// Nothing to do if hidden window is already created
if FHandle <> INVALID_HANDLE_VALUE then
Exit;
// We use a critical section to be sure only one thread can check if a
// class is registered and register it if needed.
// We must also be sure that the class is not unregistered by another
// thread which just destroyed a previous window.
EnterCriticalSection(GWndHandlerCritSect);
try
// Check if the window class is already registered
WinThreadWindowClass.hInstance := HInstance;
WinThreadWindowClass.lpszClassName := WinThreadWindowClassName;
ClassRegistered := GetClassInfo(HInstance,
WinThreadWindowClass.lpszClassName,
TempClass);
if not ClassRegistered then begin
// Not registered yet, do it right now !
WinThreadWindowClass.style := 0;
WinThreadWindowClass.lpfnWndProc := @WndControlWindowsProc;
WinThreadWindowClass.cbClsExtra := 0;
WinThreadWindowClass.cbWndExtra := SizeOf(Pointer);
WinThreadWindowClass.hIcon := 0;
WinThreadWindowClass.hCursor := 0;
WinThreadWindowClass.hbrBackground := 0;
WinThreadWindowClass.lpszMenuName := nil;
if Windows.RegisterClass(WinThreadWindowClass) = 0 then
raise Exception.Create(
'Unable to register hidden window class.' +
' Error #' + IntToStr(GetLastError) + '.');
end;
// Now we are sure the class is registered, we can create a window using it
FHandle := CreateWindowEx(WS_EX_TOOLWINDOW,
WinThreadWindowClass.lpszClassName,
'', // Window name
WS_POPUP, // Window Style
0, 0, // X, Y
0, 0, // Width, Height
0, // hWndParent
0, // hMenu
HInstance, // hInstance
nil); // CreateParam
if FHandle = 0 then
raise Exception.Create(
'Unable to create hidden window. ' +
' Error #' + IntToStr(GetLastError) + '.');
// We have a window. In the associated data, we record a reference
// to our object. This will later allow to call the WndProc method to
// handle messages sent to the window.
{$IFDEF WIN64}
SetWindowLongPtr(FHandle, 0, INT_PTR(Self));
{$ELSE}
SetWindowLong(FHandle, 0, Longint(Self));
{$ENDIF}
Inc(GWndHandleCount);
finally
LeaveCriticalSection(GWndHandlerCritSect);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TMsgHandlingWorkerThread.Create(Suspended: Boolean);
begin
FHandle := INVALID_HANDLE_VALUE;
inherited Create(Suspended);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMsgHandlingWorkerThread.DeallocateHWnd;
begin
// No handle, nothing to do
if FHandle = INVALID_HANDLE_VALUE then
Exit;
{$IFDEF WIN64}
SetWindowLongPtr(FHandle, 0, 0); // Delete object reference
{$ELSE}
SetWindowLong(FHandle, 0, 0); // Delete object reference
{$ENDIF}
DestroyWindow(FHandle); // Destroy hidden window
FHandle := INVALID_HANDLE_VALUE; // No more handle
EnterCriticalSection(GWndHandlerCritSect);
try
Dec(GWndHandleCount);
if GWndHandleCount <= 0 then
// Unregister the window class use by the component.
// This is necessary to do so from a DLL when the DLL is unloaded
// (that is when DllEntryPoint is called with dwReason equal to
// DLL_PROCESS_DETACH.
Windows.UnregisterClass(WinThreadWindowClassName, HInstance);
finally
LeaveCriticalSection(GWndHandlerCritSect);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMsgHandlingWorkerThread.Execute;
begin
NameThreadForDebugging(ansistring( ClassName ));
AllocateHWnd;
try
MessageLoop;
finally
DeallocateHWnd
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TMsgHandlingWorkerThread.GetHandle: HWND;
begin
EnterCriticalSection(GWndHandlerCritSect);
try
Result := FHandle;
finally
LeaveCriticalSection(GWndHandlerCritSect);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// Loop thru message processing until the WM_QUIT message is received
// The loop is broken when WM_QUIT is retrieved.
procedure TMsgHandlingWorkerThread.MessageLoop;
var
MsgRec : TMsg;
begin
// If GetMessage retrieves the WM_QUIT, the return value is FALSE and
// the message loop is broken.
while GetMessage(MsgRec, 0, 0, 0) do begin
TranslateMessage(MsgRec);
DispatchMessage(MsgRec)
end;
Terminate;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMsgHandlingWorkerThread.WndProc(var MsgRec: TMessage);
begin
MsgRec.Result := DefWindowProc(Handle, MsgRec.Msg,
MsgRec.wParam, MsgRec.lParam);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// WndControlWindowsProc is a callback function used for message handling
function WndControlWindowsProc(
ahWnd : HWND;
auMsg : UINT;
awParam : WPARAM;
alParam : LPARAM): LRESULT; {$IFNDEF CLR} stdcall; {$ENDIF}
var
Obj : TObject;
MsgRec : TMessage;
begin
// When the window is created, we receive the following messages:
// #129 WM_NCCREATE
// #131 WM_NCCALCSIZE
// #1 WM_CREATE
// #5 WM_SIZE
// #3 WM_MOVE
// Later we receive:
// #28 WM_ACTIVATEAPP
// When the window is destroyed we receive
// #2 WM_DESTROY
// #130 WM_NCDESTROY
// When the window was created, we stored a reference to the object
// into the storage space we asked windows to have
{$IFDEF WIN64}
Obj := TObject(GetWindowLongPtr(ahWnd, 0));
{$ELSE}
Obj := TObject(GetWindowLong(ahWnd, 0));
{$ENDIF}
// Check if the reference is actually our object type
if not (Obj is TMsgHandlingWorkerThread) then
Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
else begin
// Internally, Delphi use TMessage to pass parameters to his
// message handlers.
MsgRec.Msg := auMsg;
MsgRec.wParam := awParam;
MsgRec.lParam := alParam;
TMsgHandlingWorkerThread(Obj).WndProc(MsgRec);
Result := MsgRec.Result;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
initialization
InitializeCriticalSection(GWndHandlerCritSect);
finalization
DeleteCriticalSection(GWndHandlerCritSect);
end.
Kopiuj
TMyWorkerThread = class(TMsgHandlingWorkerThread)
public
procedure WndProc(var Msg: TMessage); override;
end;
var
WThread : TMyWorkerThread;
WThread := TMyWorkerThread.Create(TRUE);
WThread.Start;
procedure TMyWorkerThread.WndProc(var Msg: TMessage);
const
DBT_DeviceArrival = $8000;
DBT_DeviceRemoveComplete = $8004;
DBTF_Media = $0001;
DBT_DevTyp_Volume = $0002;
type
PDevBroadcastHdr = ^TDevBroadcastHdr;
TDevBroadcastHdr = packed record
dbcd_size: DWORD;
dbcd_devicetype: DWORD;
dbcd_reserved: DWORD;
end;
type
PDevBroadcastVolume = ^TDevBroadcastVolume;
TDevBroadcastVolume = packed record
dbcv_size: DWORD;
dbcv_devicetype: DWORD;
dbcv_reserved: DWORD;
dbcv_unitmask: DWORD;
dbcv_flags: Word;
end;
function GetDrive(pDBVol: PDevBroadcastVolume): string;
var
i: Byte;
Maske: DWORD;
begin
//if (pDBVol^.dbcv_flags and DBTF_Media) = DBTF_Media then
if (pDBVol^.dbcv_devicetype and DBT_DevTyp_Volume) = DBT_DevTyp_Volume then
begin
Maske := pDBVol^.dbcv_unitmask;
for i := 0 to 25 do
begin
if (Maske and 1) = 1 then
Result := Char(i + Ord('A')) + ':';
Maske := Maske shr 1;
end;
end;
end;
var
Drive: string;
w: DWORD;
begin
case Msg.wParam of
DBT_DeviceArrival:
if PDevBroadcastHdr(Msg.lParam)^.dbcd_devicetype = DBT_DevTyp_Volume then
begin
Drive := GetDrive(PDevBroadcastVolume(Msg.lParam));
if length(Drive)>0 then
begin
AllocConsole;
Writeln(Drive);
end;
end;
{DBT_DeviceRemoveComplete:
if PDevBroadcastHdr(Msg.lParam)^.dbcd_devicetype = DBT_DevTyp_Volume then
begin
Drive := GetDrive(PDevBroadcastVolume(Msg.lParam));
end;}
end;
end;
