I'm trying (in D7) to set up a thread with a message pump, which eventually I want to transplant into a DLL.
Here's the relevant/non-trivial parts of my code:
const
WM_Action1 = WM_User + 1;
scThreadClassName = 'MyThreadClass';
type
TThreadCreatorForm = class;
TWndThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
FCreator : TForm;
procedure HandleAction1;
protected
procedure Execute; override;
public
constructor Create(ACreator: TForm; const Title: String);
end;
TThreadCreatorForm = class(TForm)
btnCreate: TButton;
btnAction1: TButton;
Label1: TLabel;
btnQuit: TButton;
btnSend: TButton;
edSend: TEdit;
procedure FormShow(Sender: TObject);
procedure btnCreateClick(Sender: TObject);
procedure btnAction1Click(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure WMAction1(var Msg : TMsg); message WM_Action1;
procedure FormCreate(Sender: TObject);
public
{ Public declarations }
WndThread : TWndThread;
ThreadID : Integer;
ThreadHWnd : HWnd;
end;
var
ThreadCreatorForm: TThreadCreatorForm;
implementation
{$R *.DFM}
procedure SendStringViaWMCopyData(HSource, HDest : THandle; const AString : String);
var
Cds : TCopyDataStruct;
Res : Integer;
begin
FillChar(Cds, SizeOf(Cds), 0);
GetMem(Cds.lpData, Length(Astring) + 1);
try
StrCopy(Cds.lpData, PChar(AString));
Res := SendMessage(HDest, WM_COPYDATA, HSource, Cardinal(#Cds));
ShowMessage(IntToStr(Res));
finally
FreeMem(Cds.lpData);
end;
end;
procedure TThreadCreatorForm.FormShow(Sender: TObject);
begin
ThreadID := GetWindowThreadProcessId(Self.Handle, Nil);
Assert(ThreadID = MainThreadID);
end;
procedure TWndThread.HandleAction1;
begin
//
end;
constructor TWndThread.Create(ACreator: TForm; const Title:String);
begin
inherited Create(True);
FTitle := Title;
FCreator := ACreator;
FillChar(FWndClass, SizeOf(FWndClass), 0);
FWndClass.lpfnWndProc := #DefWindowProc;
FWndClass.hInstance := HInstance;
FWndClass.lpszClassName := scThreadClassName;
end;
procedure TWndThread.Execute;
var
Msg: TMsg;
Done : Boolean;
S : String;
begin
if Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME, 0, 0, 0, 0, 0, 0, HInstance, nil);
if FWnd = 0 then Exit;
Done := False;
while GetMessage(Msg, 0, 0, 0) and not done do begin
case Msg.message of
WM_Action1 : begin
HandleAction1;
end;
WM_COPYDATA : begin
Assert(True);
end;
WM_Quit : Done := True;
else begin
TranslateMessage(msg);
DispatchMessage(msg)
end;
end; { case }
end;
if FWnd <> 0 then
DestroyWindow(FWnd);
Windows.UnregisterClass(FWndClass.lpszClassName, FWndClass.hInstance);
end;
Once I've created the thread, I find its window handle using FindWindow and that works fine.
If I PostMessage it my user-defined WM_Action1 message, it's received by the GetMessage(), and caught by the case statement in the thread's Execute, and that works fine.
If I send myself (i.e. my host form) a WM_CopyData message using the SendStringViaWMCopyData() routine that works fine.
However: If I send my thread the WM_CopyData message, the GetMessage and case statement in Execute never see it and the SendMessage in SendStringViaWMCopyData returns 0.
So, my question is, why does the WM_CopyData message not get received by the GetMessage in .Execute? I have an uncomfortable feeling I'm missing something ...
WM_COPYDATA is not a posted message, it is a sent message, so it does not go through the message queue and thus a message loop will never see it. You need to assign a window procedure to your window class and process WM_COPYDATA in that procedure instead. Don't use DefWindowProc() as your window procedure.
Also, when sending WM_COPYDATA, the lpData field is expressed in bytes not in characters, so you need to take that in to account. And you are not filling in the COPYDATASTRUCT correctly. You need to provide values for the dwData and cbData fields. And you don't need to allocate memory for the lpData field, you can point it to your String's existing memory instead.
Try this:
const
WM_Action1 = WM_User + 1;
scThreadClassName = 'MyThreadClass';
type
TThreadCreatorForm = class;
TWndThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
FCreator : TForm;
procedure WndProc(var Message: TMessage);
procedure HandleAction1;
procedure HandleCopyData(const Cds: TCopyDataStruct);
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(ACreator: TForm; const Title: String);
end;
TThreadCreatorForm = class(TForm)
btnCreate: TButton;
btnAction1: TButton;
Label1: TLabel;
btnQuit: TButton;
btnSend: TButton;
edSend: TEdit;
procedure FormShow(Sender: TObject);
procedure btnCreateClick(Sender: TObject);
procedure btnAction1Click(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure WMAction1(var Msg : TMsg); message WM_Action1;
procedure FormCreate(Sender: TObject);
public
{ Public declarations }
WndThread : TWndThread;
ThreadID : Integer;
ThreadHWnd : HWnd;
end;
var
ThreadCreatorForm: TThreadCreatorForm;
implementation
{$R *.DFM}
var
MY_CDS_VALUE: UINT = 0;
procedure SendStringViaWMCopyData(HSource, HDest : HWND; const AString : String);
var
Cds : TCopyDataStruct;
Res : Integer;
begin
ZeroMemory(#Cds, SizeOf(Cds));
Cds.dwData := MY_CDS_VALUE;
Cds.cbData := Length(AString) * SizeOf(Char);
Cds.lpData := PChar(AString);
Res := SendMessage(HDest, WM_COPYDATA, HSource, LPARAM(#Cds));
ShowMessage(IntToStr(Res));
end;
procedure TThreadCreatorForm.FormShow(Sender: TObject);
begin
ThreadID := GetWindowThreadProcessId(Self.Handle, Nil);
Assert(ThreadID = MainThreadID);
end;
function TWndThreadWindowProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
pSelf: TWndThread;
Message: TMessage;
begin
pSelf := TWndThread(GetWindowLongPtr(hWnd, GWL_USERDATA));
if pSelf <> nil then
begin
Message.Msg := uMsg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;
pSelf.WndProc(Message);
Result := Message.Result;
end else
Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
constructor TWndThread.Create(ACreator: TForm; const Title:String);
begin
inherited Create(True);
FTitle := Title;
FCreator := ACreator;
FillChar(FWndClass, SizeOf(FWndClass), 0);
FWndClass.lpfnWndProc := #TWndThreadWindowProc;
FWndClass.hInstance := HInstance;
FWndClass.lpszClassName := scThreadClassName;
end;
procedure TWndThread.Execute;
var
Msg: TMsg;
begin
if Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME, 0, 0, 0, 0, 0, 0, HInstance, nil);
if FWnd = 0 then Exit;
SetWindowLongPtr(FWnd, GWL_USERDATA, ULONG_PTR(Self));
while GetMessage(Msg, 0, 0, 0) and (not Terminated) do
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
procedure TWndThread.DoTerminate;
begin
if FWnd <> 0 then
DestroyWindow(FWnd);
Windows.UnregisterClass(FWndClass.lpszClassName, FWndClass.hInstance);
inherited;
end;
procedure TWndThread.WndProc(var Message: TMessage);
begin
case Message.Msg of
WM_Action1 : begin
HandleAction1;
Exit;
end;
WM_COPYDATA : begin
if PCopyDataStruct(lParam).dwData = MY_CDS_VALUE then
begin
HandleCopyData(PCopyDataStruct(lParam)^);
Exit;
end;
end;
end;
Message.Result := DefWindowProc(FWnd, Message.Msg, Message.WParam, Message.LParam);
end;
procedure TWndThread.HandleAction1;
begin
//
end;
procedure TWndThread.HandleCopyData(const Cds: TCopyDataStruct);
var
S: String;
begin
if Cds.cbData > 0 then
begin
SetLength(S, Cds.cbData div SizeOf(Char));
CopyMemory(Pointer(S), Cds.lpData, Length(S) * SizeOf(Char));
end;
// use S as needed...
end;
initialization
MY_CDS_VALUE := RegisterWindowMessage('MY_CDS_VALUE');
end.
The copy data message is sent synchronously. Which means that it won't be returned by GetMessage. So you'll need to supply a window procedure to process the message because sent messages are dispatched directly to the window procedure of their windows, being synchronous rather than asynchronous.
Beyond that the other problem is that you don't specify the length of the data in the copy data struct, cbData. That's needed when sending the message cross-thread so that the system can marshal your data.
You should set dwData so that the recipient can check that they are handling the intended message.
You don't need to use GetMem at all here, you can use the string buffer directly. A window handle is an HWND and not a THandle. A message only window would be most appropriate here.
Related
I'm working in a project where want receive continuous frames of a live webcam and i found this code example that in my tests worked fine. Now want know how can make this receiving inside a TThread (Socket NonBlocking) similar to approach of Server multiclient/multithread? I tried this, but the server not received none frame from client. I hope that you can help me.
Server:
uses
System.Win.ScktComp, Winapi.WinSock, Vcl.Imaging.jpeg, System.Math;
type
TMyThread = class(TThread)
private
Socket: TCustomWinSocket;
protected
procedure Execute; override;
public
constructor Create(aSocket: TCustomWinSocket);
end;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
ServerSocket1: TServerSocket;
procedure ServerSocket1Accept(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure Button1Click(Sender: TObject);
procedure ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket);
private
{ Private declarations }
MyThread: TMyThread;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TMyThread.Create(aSocket: TCustomWinSocket);
begin
inherited Create(True);
Socket := aSocket;
FreeOnTerminate := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ServerSocket1.Port := 1234;
ServerSocket1.Active := true;
end;
procedure TForm1.ServerSocket1Accept(Sender: TObject; Socket: TCustomWinSocket);
begin
MyThread := TMyThread.Create(Socket);
MyThread.Start;
end;
procedure TForm1.ServerSocket1ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := nil;
end;
procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
if Socket.Data <> nil then
TMemoryStream(Socket.Data).Free;
end;
procedure TForm1.ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ErrorCode := 0;
end;
procedure TForm1.ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket);
begin
ShowMessage('Server listen on port: ' + IntToStr(Socket.LocalPort));
end;
procedure TMyThread.Execute;
var
Stream: TMemoryStream;
BytesReceived: Integer;
StreamSize, TempSize: Int32;
BytesRemaining: Int64;
P: PByte;
ChunkSize: Integer;
jpg: TJpegImage;
const
MaxChunkSize: Int64 = 8192;
begin
while Socket.Connected do
begin
Stream := TMemoryStream(Socket.Data);
if Stream = nil then
begin
if Socket.ReceiveLength < SizeOf(TempSize) then
Exit;
BytesReceived := Socket.ReceiveBuf(TempSize, SizeOf(TempSize));
if BytesReceived <= 0 then
Exit;
StreamSize := ntohl(TempSize);
Stream := TMemoryStream.Create;
Socket.Data := Stream;
Stream.Size := StreamSize;
BytesRemaining := StreamSize;
end
else
BytesRemaining := Stream.Size - Stream.Position;
if BytesRemaining > 0 then
begin
P := PByte(Stream.Memory);
if Stream.Position > 0 then
Inc(P, Stream.Position);
repeat
ChunkSize := Integer(Min(BytesRemaining, MaxChunkSize));
BytesReceived := Socket.ReceiveBuf(P^, ChunkSize);
if BytesReceived <= 0 then
Exit;
Inc(P, BytesReceived);
Dec(BytesRemaining, BytesReceived);
Stream.Seek(BytesReceived, soCurrent);
until BytesRemaining = 0;
end;
try
jpg := TJpegImage.Create;
try
Stream.Position := 0;
jpg.LoadFromStream(Stream);
Synchronize(
procedure
begin
Form1.Image1.Picture.Assign(jpg);
end);
finally
jpg.Free;
end;
finally
Socket.Data := nil;
Stream.Free;
end;
end;
end;
end.
You need to use the TServerSocket in thread-blocking mode in order to effectively use worker threads with its accepted clients. Non-blocking mode and worker threads don't mix well together.
Non-blocking mode was invented to be able to use TClientSocket and TServerSocket in the main UI thread without blocking it. But when using sockets outside of the main UI thread, there is very little use for non-blocking mode (just some corner cases that don't apply to your situation). Internally, TCustomWinSocket allocates an HWND to detect socket activity when used in non-blocking, and that HWND requires a message loop. But since each accepted client socket is created outside of your worker threads, their HWNDs will not be able to be serviced by any message loop you run in your threads. So all the more reason why you need to use thread-blocking mode anyway.
Also, using thread-blocking mode will greatly simplify your socket I/O code anyway.
Try something more like this:
unit Unit1;
interface
uses
..., System.Win.ScktComp;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
ServerSocket1: TServerSocket;
procedure Button1Click(Sender: TObject);
procedure ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ServerSocket1GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
procedure ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
Winapi.WinSock, Vcl.Imaging.jpeg, System.Math;
{$R *.dfm}
type
TMyThread = class(TServerClientThread)
protected
procedure ClientExecute; override;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// this can be set at design-time, if desired...
ServerSocket1.ServerType := TServerType.stThreadBlocking;
// so can this...
ServerSocket1.Port := 1234;
ServerSocket1.Active := True;
end;
procedure TForm1.ServerSocket1ClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ErrorCode := 0;
end;
procedure TForm1.ServerSocket1GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
begin
SocketThread := TMyThread.Create(False, ClientSocket);
end;
procedure TForm1.ServerSocket1Listen(Sender: TObject; Socket: TCustomWinSocket);
begin
ShowMessage('Server listen on port: ' + IntToStr(Socket.LocalPort));
end;
procedure TMyThread.ClientExecute;
var
Stream: TMemoryStream;
StreamSize: Int32;
jpg: TJpegImage;
function DoRead(Buffer: Pointer; BufSize: Int64): Boolean;
const
MaxChunkSize: Int64 = 8192;
var
P: PByte;
BytesReceived: Integer;
ChunkSize: Integer;
begin
Result := False;
P := PByte(Buffer);
while BufSize > 0 do
begin
ChunkSize := Integer(Min(BufSize, MaxChunkSize));
BytesReceived := ClientSocket.ReceiveBuf(P^, ChunkSize);
if BytesReceived <= 0 then
Exit;
Inc(P, BytesReceived);
Dec(BufSize, BytesReceived);
end;
Result := True;
end;
begin
while (not Terminated) and ClientSocket.Connected do
begin
if not DoRead(#StreamSize, SizeOf(StreamSize)) then Exit;
StreamSize := ntohl(StreamSize);
if StreamSize <= 0 then Continue;
jpg := TJpegImage.Create;
try
Stream := TMemoryStream.Create;
try
Stream.Size := StreamSize;
if not DoRead(Stream.Memory, StreamSize) then Exit;
Stream.Position := 0;
jpg.LoadFromStream(Stream);
finally
Stream.Free;
end;
Synchronize(
procedure
begin
Form1.Image1.Picture.Assign(jpg);
end
);
finally
jpg.Free;
end;
end;
end;
end.
That being said, I strongly suggest you stop using these outdated and deprecated socket components from Borland's legacy. For instance, Indy 10 ships pre-installed in the IDE, and has a TIdTCPServer component that will greatly simplify the above threading logic even further (TIdTCPServer is a multi-threaded component and will manage per-client threads for you), eg:
unit Unit1;
interface
uses
..., IdContext, IdTCPServer;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
IdTCPServer1: TIdTCPServer;
procedure Button1Click(Sender: TObject);
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Execute(AContext: TIdContext);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
Vcl.Imaging.jpeg, System.Math;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
IdTCPServer1.DefaultPort := 1234;
IdTCPServer1.Active := True;
ShowMessage('Server listen on port: ' + IntToStr(IdTCPServer1.DefaultPort));
end;
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
// tell ReadStream() to read the stream size as an Int32 and not as an Int64...
AContext.Connection.IOHandler.LargeStream := False;
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
Stream: TMemoryStream;
jpg: TJpegImage;
begin
// OnExecute is a looped event, it is called in a continuous
// loop for the lifetime of the TCP connection...
jpg := TJpegImage.Create;
try
Stream := TMemoryStream.Create;
try
// ReadStream() can read the stream size first, then read the stream data...
AContext.Connection.IOHandler.ReadStream(Stream, -1, False);
Stream.Position := 0;
jpg.LoadFromStream(Stream);
finally
Stream.Free;
end;
TThread.Synchronize(nil,
procedure
begin
Form1.Image1.Picture.Assign(jpg);
end
);
finally
jpg.Free;
end;
end;
end.
I found this code on the net and it's working but I'm not sure if it's ok to directly read the variable in the main thread from another thread. In this example the flag (variable) is CancelCopy.
In general, I want to know how can I read the state of a variable from the main thread in another thread but immediately, without waiting.
type
TCopyEx = packed record
Source: String;
Dest: String;
Handle: THandle;
end;
PCopyEx = ^TCopyEx;
const
CFEX_CANCEL = WM_USER + 1;
var
CancelCopy:Boolean=False;
function CopyFileProgress(TotalFileSize, TotalBytesTransferred, StreamSize,
StreamBytesTransferred: LARGE_INTEGER; dwStreamNumber, dwCallbackReason: DWORD;
hSourceFile, hDestinationFile: THandle; lpData: Pointer): DWORD; stdcall;
begin
if CancelCopy then begin
SendMessage(THandle(lpData), CFEX_CANCEL, 0, 0);
result:=PROGRESS_CANCEL;
Exit;
end;
//rest of the code here.......
end;
function CopyExThread(p: PCopyEx):Integer;
var
Source: String;
Dest: String;
Handle: THandle;
Cancel: PBool;
begin
Source:=p.Source;
Dest:=p.Dest;
Handle:=p.Handle;
Cancel:=PBOOL(False);
CopyFileEx(PChar(Source), PChar(Dest), #CopyFileProgress, Pointer(Handle), Cancel, COPY_FILE_NO_BUFFERING);
Dispose(p);
result:=0;
end;
procedure TFormMain.ButtonCopyClick(Sender: TObject);
var
Params: PCopyEx;
ThreadID: Cardinal;
begin
cancelCopy := False;
New(Params);
Params.Source := EditOriginal.Text;
Params.Dest := EditCopied.Text;
Params.Handle := Handle;
CloseHandle(BeginThread(nil, 0, #CopyExThread, Params, 0, ThreadID));
end;
procedure TFormMain.ButtonCancelClick(Sender: TObject);
begin
cancelCopy := true;
end;
Technically, the code you have shown is fine, and will work as expected.
However, there is a small mistake in it. You are passing the wrong pointer value to the pbCancel parameter of CopyFileEx(). However, your code does not crash because the pointer you are passing is effectively being set to nil, and pbCancel will accept a nil pointer, thus CopyFileEx() will ignore the parameter.
What you are supposed to do is pass the address of a BOOL variable, which you can set to TRUE at any time to cancel the copy. CopyFileEx() will monitor that variable for you, you do not need to manually return PROGRESS_CANCEL from the callback when the variable is set (return PROGRESS_CANCEL if your callback encounters an error not related to the copy itself, and you want to abort the copy as a result of the error). I would not use a global variable for that, though. I would use a variable that is local to the Form that is performing the copy.
Try something more like this instead:
type
TFormMain = class(TForm)
...
private
CancelCopy: BOOL; // <-- BOOL, not Boolean
...
end;
...
type
TCopyEx = record
Source: String;
Dest: String;
Handle: HWND;
PCancelCopy: PBOOL;
end;
PCopyEx = ^TCopyEx;
const
CFEX_CANCEL = WM_USER + 1;
function CopyFileProgress(TotalFileSize, TotalBytesTransferred, StreamSize,
StreamBytesTransferred: LARGE_INTEGER; dwStreamNumber, dwCallbackReason: DWORD;
hSourceFile, hDestinationFile: THandle; lpData: Pointer): DWORD; stdcall;
begin
// no need to watch CancelCopy here...
// do normal status handling here as needed...
// use PCopyEx(lpData)^ as needed...
end;
function CopyExThread(p: PCopyEx): Integer;
begin
try
if not CopyFileEx(PChar(p.Source), PChar(p.Dest), #CopyFileProgress, p, p.PCancelCopy, COPY_FILE_NO_BUFFERING) then
begin
if GetLastError() = ERROR_REQUEST_ABORTED then
SendMessage(p.Handle, CFEX_CANCEL, 0, 0);
end;
finally
Dispose(p);
end;
Result := 0;
end;
procedure TFormMain.ButtonCopyClick(Sender: TObject);
var
Params: PCopyEx;
ThreadID: Cardinal;
begin
New(Params);
Params.Source := EditOriginal.Text;
Params.Dest := EditCopied.Text;
Params.Handle := Handle;
Params.PCancelCopy := #CancelCopy; // <-- pass address of CancelCopy here...
CancelCopy := FALSE;
CloseHandle(BeginThread(nil, 0, #CopyExThread, Params, 0, ThreadID));
end;
procedure TFormMain.ButtonCancelClick(Sender: TObject);
begin
CancelCopy := TRUE;
end;
With that said, something else to watch out for - you are passing the HWND from the TForm.Handle property to the thread. If the TForm ever destroys/recreates its HWND for any reason (and yes, it can happen) while the thread is still running, the TCopyEx.Handle value will be left pointing to an invalid window (or worse, to a new window that reuses the old HWND value).
In general, the TWinControl.Handle property is not thread-safe, and so for that reason alone, it is not a good idea to pass the HWND of a TWinControl object to a worker thread, unless you can guarantee the HWND will not be destroyed while the thread is running (and in this example, that is not guaranteed).
In this example, I would use a different HWND that is guaranteed to be persistent for the life of the thread, such as the TApplication.Handle window (messages sent to this window can be handled via TApplication.HookMainWindow()), or the result of calling AllocateHWnd().
For example:
type
TFormMain = class(TForm)
procedure FormDestroy(Sender: TObject);
...
private
CancelCopy: BOOL; // <-- BOOL, not Boolean
CopyFileExWnd: HWND;
procedure CopyFileExWndProc(var Message: TMessage);
...
end;
...
type
TCopyEx = record
Source: String;
Dest: String;
Handle: HWND;
PCancelCopy: PBOOL;
end;
PCopyEx = ^TCopyEx;
const
CFEX_CANCEL = WM_USER + 1;
function CopyFileProgress(TotalFileSize, TotalBytesTransferred, StreamSize,
StreamBytesTransferred: LARGE_INTEGER; dwStreamNumber, dwCallbackReason: DWORD;
hSourceFile, hDestinationFile: THandle; lpData: Pointer): DWORD; stdcall;
begin
...
end;
function CopyExThread(p: PCopyEx): Integer;
begin
try
if not CopyFileEx(
PChar(p.Source), PChar(p.Dest), #CopyFileProgress, p, p.PCancelCopy, COPY_FILE_NO_BUFFERING) then
begin
if GetLastError() = ERROR_REQUEST_ABORTED then
SendMessage(p.Handle, CFEX_CANCEL, 0, 0);
end;
finally
Dispose(p);
end;
Result := 0;
end;
procedure TFormMain.FormDestroy(Sender: TObject);
begin
if CopyFileExWnd <> 0 then
DeallocateHWnd(CopyFileExWnd);
end;
procedure TFormMain.ButtonCopyClick(Sender: TObject);
var
Params: PCopyEx;
ThreadID: Cardinal;
begin
if CopyFileExWnd = 0 then
CopyFileExWnd := AllocateHWnd(CopyFileExWndProc);
New(Params);
Params.Source := EditOriginal.Text;
Params.Dest := EditCopied.Text;
Params.Handle := CopyFileExWnd;
Params.PCancelCopy := #CancelCopy;
CancelCopy := FALSE;
CloseHandle(BeginThread(nil, 0, #CopyExThread, Params, 0, ThreadID));
end;
procedure TFormMain.ButtonCancelClick(Sender: TObject);
begin
CancelCopy := TRUE;
end;
procedure TFormMain.CopyFileExWndProc(var Message: TMessage);
begin
case Message.Msg of
CFEX_CANCEL: begin
...
end;
...
else
Message.Result := DefWindowProc(CopyFileExWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
I've been beating my head for over a day now, going through tons of resources trying to figure out how to receive the WM_POWERBROADCAST Windows message from within a thread.
Currently, I am using AllocateHWnd(WndMethod) inside of a stand-alone component. When I create an instance of said component in a standard VCL Forms Application, everything works fine, and I receive the WM_POWERBROADCAST message every time, as needed.
However, when I create an instance of the very same component from within a TThread, I'm no longer receiving this particular Windows message. I'm receiving all kinds of other messages, just not this particular one.
In my searching for a solution, I've found many resources related to how a Windows Service requires some extra work in order to receive this message. But I'm not using a service, at least not yet. I've also found a couple people mention that a thread needs to have a message loop in order to receive this message, and I've implemented a thread from another answer here, but again, I never receive this particular message.
Below is the complete component how I'm receiving this message, which again works perfectly if this is in a VCL application's main thread. I'm guessing the main thread needs to receive this message and forward it into the thread.
How do I make this receive the WM_POWERBROADCAST message when inside of a TThread?
unit JD.Power.Monitor;
(*
JD Power Monitor
by Jerry Dodge
Purpose: To monitor the current state of power on the computer, and trigger
events when different power related changes occur.
Component: TPowerMonitor
- Create an instance of TPowerMonitor component
- Choose desired power settings to get notified of using Settings property
- Implement event handlers for those events you wish to monitor
- Component automatically takes care of the rest of the work
*)
interface
uses
System.Classes, System.SysUtils, System.Generics.Collections,
Winapi.ActiveX, Winapi.Windows, Winapi.Messages;
type
TPowerSetting = (psACDCPowerSource, psBatteryPercentage,
psConsoleDisplayState, psGlobalUserPresence, psIdleBackgroundTask,
psMonitorPower, psPowerSaving, psPowerSchemePersonality,
psSessionDisplayStatus, psSessionUserPresence, psSystemAwayMode);
TPowerSettings = set of TPowerSetting;
TPowerSource = (poAC, poDC, poHot);
TPowerDisplayState = (pdOff, pdOn, pdDimmed);
TPowerUserPresence = (puPresent = 0, puInactive = 2);
TPowerSavingStatus = (psSaverOff, psSaverOn);
TPowerAwayMode = (paExiting, paEntering);
TPowerPersonality = (ppHighPerformance, ppPowerSaver, ppAutomatic);
TPowerMonitorSettingHandles = array[TPowerSetting] of HPOWERNOTIFY;
TPowerQueryEndSessionEvent = procedure(Sender: TObject; var EndSession: Boolean) of object;
TPowerEndSessionEvent = procedure(Sender: TObject) of object;
TPowerSettingSourceChangeEvent = procedure(Sender: TObject;
const Src: TPowerSource) of object;
TPowerSettingBatteryPercentEvent = procedure(Sender: TObject;
const Perc: Single) of object;
TPowerSettingDisplayStateEvent = procedure(Sender: TObject;
const State: TPowerDisplayState) of object;
TPowerSettingUserPresenceEvent = procedure(Sender: TObject;
const Presence: TPowerUserPresence) of object;
TPowerSettingSavingEvent = procedure(Sender: TObject;
const Status: TPowerSavingStatus) of object;
TPowerAwayModeEvent = procedure(Sender: TObject;
const Mode: TPowerAwayMode) of object;
TPowerPersonalityEvent = procedure(Sender: TObject;
const Personality: TPowerPersonality) of object;
TPowerMonitor = class(TComponent)
private
FHandle: HWND;
FSettingHandles: TPowerMonitorSettingHandles;
FSettings: TPowerSettings;
FBatteryPresent: Boolean;
FOnQueryEndSession: TPowerQueryEndSessionEvent;
FOnEndSession: TPowerEndSessionEvent;
FOnPowerStatusChange: TNotifyEvent;
FOnResumeAutomatic: TNotifyEvent;
FOnResumeSuspend: TNotifyEvent;
FOnSuspend: TNotifyEvent;
FOnSourceChange: TPowerSettingSourceChangeEvent;
FOnBatteryPercent: TPowerSettingBatteryPercentEvent;
FOnConsoleDisplayState: TPowerSettingDisplayStateEvent;
FOnGlobalUserPresence: TPowerSettingUserPresenceEvent;
FOnIdleBackgroundTask: TNotifyEvent;
FOnMonitorPower: TPowerSettingDisplayStateEvent;
FOnPowerSavingStatus: TPowerSettingSavingEvent;
FOnSessionDisplayState: TPowerSettingDisplayStateEvent;
FOnSessionUserPresence: TPowerSettingUserPresenceEvent;
FOnAwayMode: TPowerAwayModeEvent;
FOnPersonality: TPowerPersonalityEvent;
procedure UnregisterSettings;
procedure RegisterSettings;
procedure SetSettings(const Value: TPowerSettings);
protected
procedure HandlePowerSetting(const Val: PPowerBroadcastSetting);
procedure WndMethod(var Msg: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Settings: TPowerSettings read FSettings write SetSettings;
property OnQueryEndSession: TPowerQueryEndSessionEvent
read FOnQueryEndSession write FOnQueryEndSession;
property OnEndSession: TPowerEndSessionEvent
read FOnEndSession write FOnEndSession;
property OnPowerStatusChange: TNotifyEvent
read FOnPowerStatusChange write FOnPowerStatusChange;
property OnResumeAutomatic: TNotifyEvent
read FOnResumeAutomatic write FOnResumeAutomatic;
property OnResumeSuspend: TNotifyEvent
read FOnResumeSuspend write FOnResumeSuspend;
property OnSuspend: TNotifyEvent
read FOnSuspend write FOnSuspend;
property OnSourceChange: TPowerSettingSourceChangeEvent
read FOnSourceChange write FOnSourceChange;
property OnBatteryPercent: TPowerSettingBatteryPercentEvent
read FOnBatteryPercent write FOnBatteryPercent;
property OnConsoleDisplayState: TPowerSettingDisplayStateEvent
read FOnConsoleDisplayState write FOnConsoleDisplayState;
property OnGlobalUserPresence: TPowerSettingUserPresenceEvent
read FOnGlobalUserPresence write FOnGlobalUserPresence;
property OnIdleBackgroundTask: TNotifyEvent
read FOnIdleBackgroundTask write FOnIdleBackgroundTask;
property OnMonitorPower: TPowerSettingDisplayStateEvent
read FOnMonitorPower write FOnMonitorPower;
property OnPowerSavingStatus: TPowerSettingSavingEvent
read FOnPowerSavingStatus write FOnPowerSavingStatus;
property OnSessionDisplayState: TPowerSettingDisplayStateEvent
read FOnSessionDisplayState write FOnSessionDisplayState;
property OnSessionUserPresence: TPowerSettingUserPresenceEvent
read FOnSessionUserPresence write FOnSessionUserPresence;
property OnAwayMode: TPowerAwayModeEvent
read FOnAwayMode write FOnAwayMode;
property OnPersonality: TPowerPersonalityEvent
read FOnPersonality write FOnPersonality;
end;
implementation
{ TPowerMonitor }
constructor TPowerMonitor.Create(AOwner: TComponent);
begin
inherited;
FBatteryPresent:= False;
FHandle := AllocateHWnd(WndMethod);
end;
destructor TPowerMonitor.Destroy;
begin
UnregisterSettings;
DeallocateHWnd(FHandle);
inherited;
end;
procedure TPowerMonitor.SetSettings(const Value: TPowerSettings);
begin
UnregisterSettings;
FSettings := Value;
RegisterSettings;
end;
procedure TPowerMonitor.WndMethod(var Msg: TMessage);
var
Handled: Boolean;
begin
Handled := True;
case Msg.Msg of
WM_POWERBROADCAST: begin
//TODO: Why is this never received when inside of a thread?
case Msg.WParam of
PBT_APMPOWERSTATUSCHANGE: begin
//Power status has changed.
if Assigned(FOnPowerStatusChange) then
FOnPowerStatusChange(Self);
end;
PBT_APMRESUMEAUTOMATIC: begin
//Operation is resuming automatically from a low-power state.
//This message is sent every time the system resumes.
if Assigned(FOnResumeAutomatic) then
FOnResumeAutomatic(Self);
end;
PBT_APMRESUMESUSPEND: begin
//Operation is resuming from a low-power state. This message
//is sent after PBT_APMRESUMEAUTOMATIC if the resume is triggered
//by user input, such as pressing a key.
if Assigned(FOnResumeSuspend) then
FOnResumeSuspend(Self);
end;
PBT_APMSUSPEND: begin
//System is suspending operation.
if Assigned(FOnSuspend) then
FOnSuspend(Self);
end;
PBT_POWERSETTINGCHANGE: begin
//A power setting change event has been received.
HandlePowerSetting(PPowerBroadcastSetting(Msg.LParam));
end;
else begin
end;
end;
end
else Handled := False;
end;
if Handled then
Msg.Result := 0
else
Msg.Result := DefWindowProc(FHandle, Msg.Msg,
Msg.WParam, Msg.LParam);
end;
procedure TPowerMonitor.HandlePowerSetting(const Val: PPowerBroadcastSetting);
var
Pers: TPowerPersonality;
function ValAsDWORD: DWORD;
begin
Result:= DWORD(Val.Data[0]);
end;
function ValAsGUID: TGUID;
begin
Result:= StringToGUID('{00000000-0000-0000-0000-000000000000}'); //Default
if SizeOf(TGUID) = Val.DataLength then begin
Move(Val.Data, Result, Val.DataLength);
end;
end;
function IsVal(G: String): Boolean;
begin
Result:= Assigned(Val);
if Result then
Result:= IsEqualGUID(StringToGUID(G), Val.PowerSetting);
end;
function IsValGuid(G: String): Boolean;
begin
Result:= Assigned(Val);
if Result then
Result:= IsEqualGUID(StringToGUID(G), ValAsGUID);
end;
begin
if IsVal('{5d3e9a59-e9D5-4b00-a6bd-ff34ff516548}') then begin
//GUID_ACDC_POWER_SOURCE
if Assigned(FOnSourceChange) then
FOnSourceChange(Self, TPowerSource(ValAsDWORD));
end else
if IsVal('{a7ad8041-b45a-4cae-87a3-eecbb468a9e1}') then begin
//GUID_BATTERY_PERCENTAGE_REMAINING
//We assume that if we get this message, that there is a battery connected.
//Otherwise if this never occurs, then a battery is not present.
//TODO: How to handle if battery is detached and no longer present?
FBatteryPresent:= True;
if Assigned(FOnBatteryPercent) then
FOnBatteryPercent(Self, ValAsDWORD);
end else
if IsVal('{6fe69556-704a-47a0-8f24-c28d936fda47}') then begin
//GUID_CONSOLE_DISPLAY_STATE
if Assigned(FOnConsoleDisplayState) then
FOnConsoleDisplayState(Self, TPowerDisplayState(ValAsDWORD));
end else
if IsVal('{786E8A1D-B427-4344-9207-09E70BDCBEA9}') then begin
//GUID_GLOBAL_USER_PRESENCE
if Assigned(FOnGlobalUserPresence) then
FOnGlobalUserPresence(Self, TPowerUserPresence(ValAsDWORD));
end else
if IsVal('{515c31d8-f734-163d-a0fd-11a08c91e8f1}') then begin
//GUID_IDLE_BACKGROUND_TASK
if Assigned(FOnIdleBackgroundTask) then
FOnIdleBackgroundTask(Self);
end else
if IsVal('{02731015-4510-4526-99e6-e5a17ebd1aea}') then begin
//GUID_MONITOR_POWER_ON
if Assigned(FOnMonitorPower) then
FOnMonitorPower(Self, TPowerDisplayState(ValAsDWORD));
end else
if IsVal('{E00958C0-C213-4ACE-AC77-FECCED2EEEA5}') then begin
//GUID_POWER_SAVING_STATUS
if Assigned(FOnPowerSavingStatus) then
FOnPowerSavingStatus(Self, TPowerSavingStatus(ValAsDWORD));
end else
if IsVal('{245d8541-3943-4422-b025-13A784F679B7}') then begin
//GUID_POWERSCHEME_PERSONALITY
if IsValGuid('{8c5e7fda-e8bf-4a96-9a85-a6e23a8c635c}') then begin
Pers:= TPowerPersonality.ppHighPerformance;
end else
if IsValGuid('{a1841308-3541-4fab-bc81-f71556f20b4a}') then begin
Pers:= TPowerPersonality.ppPowerSaver;
end else
if IsValGuid('{381b4222-f694-41f0-9685-ff5bb260df2e}') then begin
Pers:= TPowerPersonality.ppAutomatic;
end else begin
//TODO: Handle unrecognized GUID
Pers:= TPowerPersonality.ppAutomatic;
end;
if Assigned(FOnPersonality) then
FOnPersonality(Self, Pers);
end else
if IsVal('{2B84C20E-AD23-4ddf-93DB-05FFBD7EFCA5}') then begin
//GUID_SESSION_DISPLAY_STATUS
if Assigned(FOnSessionDisplayState) then
FOnSessionDisplayState(Self, TPowerDisplayState(ValAsDWORD));
end else
if IsVal('{3C0F4548-C03F-4c4d-B9F2-237EDE686376}') then begin
//GUID_SESSION_USER_PRESENCE
if Assigned(FOnSessionUserPresence) then
FOnSessionUserPresence(Self, TPowerUserPresence(ValAsDWORD));
end else
if IsVal('{98a7f580-01f7-48aa-9c0f-44352c29e5C0}') then begin
//GUID_SYSTEM_AWAYMODE
if Assigned(FOnAwayMode) then
FOnAwayMode(Self, TPowerAwayMode(ValAsDWORD));
end else begin
//TODO: Handle Unrecognized GUID
end;
end;
function PowerSettingGUID(const Setting: TPowerSetting): TGUID;
begin
case Setting of
psACDCPowerSource: Result:= StringToGUID('{5d3e9a59-e9D5-4b00-a6bd-ff34ff516548}');
psBatteryPercentage: Result:= StringToGUID('{a7ad8041-b45a-4cae-87a3-eecbb468a9e1}');
psConsoleDisplayState: Result:= StringToGUID('{6fe69556-704a-47a0-8f24-c28d936fda47}');
psGlobalUserPresence: Result:= StringToGUID('{786E8A1D-B427-4344-9207-09E70BDCBEA9}');
psIdleBackgroundTask: Result:= StringToGUID('{515c31d8-f734-163d-a0fd-11a08c91e8f1}');
psMonitorPower: Result:= StringToGUID('{02731015-4510-4526-99e6-e5a17ebd1aea}');
psPowerSaving: Result:= StringToGUID('{E00958C0-C213-4ACE-AC77-FECCED2EEEA5}');
psPowerSchemePersonality: Result:= StringToGUID('{245d8541-3943-4422-b025-13A784F679B7}');
psSessionDisplayStatus: Result:= StringToGUID('{2B84C20E-AD23-4ddf-93DB-05FFBD7EFCA5}');
psSessionUserPresence: Result:= StringToGUID('{3C0F4548-C03F-4c4d-B9F2-237EDE686376}');
psSystemAwayMode: Result:= StringToGUID('{98a7f580-01f7-48aa-9c0f-44352c29e5C0}');
end;
end;
procedure TPowerMonitor.RegisterSettings;
var
V: TPowerSetting;
begin
for V := Low(TPowerSetting) to High(TPowerSetting) do begin
if V in FSettings then begin
FSettingHandles[V]:= RegisterPowerSettingNotification(FHandle,
PowerSettingGUID(V), 0);
end;
end;
end;
procedure TPowerMonitor.UnregisterSettings;
var
V: TPowerSetting;
begin
for V := Low(TPowerSetting) to High(TPowerSetting) do begin
if V in FSettings then begin
UnregisterPowerSettingNotification(FSettingHandles[V]);
end;
end;
end;
end.
Further, based on the other answer as mentioned, here's how I'm attempting to capture this message using only a thread, although I'm sure this is not actually what I need since WM_POWERBROADCAST is not a posted message:
unit JD.ThreadTest;
interface
uses
System.Classes, Winapi.Messages, Winapi.Windows;
type
TDataThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
procedure HandlePower(AMsg: TMsg);
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(const Title: String); reintroduce;
end;
implementation
constructor TDataThread.Create(const Title: String);
begin
inherited Create(True);
FTitle := Title;
with FWndClass do begin
Style := 0;
lpfnWndProc := #DefWindowProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName := nil;
lpszClassName := PChar(Self.ClassName);
end;
end;
procedure TDataThread.Execute;
var
Msg: TMsg;
begin
if Winapi.Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME,
0, 0, 698, 517, 0, 0, HInstance, nil);
if FWnd = 0 then Exit;
while GetMessage(Msg, FWnd, 0, 0) = True do begin
if Terminated then Break;
case Msg.message of
WM_POWERBROADCAST: begin
HandlePower(Msg); //Never receives this message
end;
else begin
TranslateMessage(msg);
DispatchMessage(msg)
end;
end;
end;
end;
procedure TDataThread.HandlePower(AMsg: TMsg);
begin
end;
procedure TDataThread.DoTerminate;
begin
if FWnd <> 0 then DestroyWindow(FWnd);
Winapi.Windows.UnregisterClass(PChar(Self.ClassName), FWndClass.hInstance);
inherited;
end;
end.
PS: The end goal is to make this component re-usable, and to be using it inside of a thread, which will be spawned inside of a service.
EDIT
Just to show some perspective, here's a screenshot of my results, when I put my computer into sleep mode. The form on the left is my 100% working UI application, without any worker thread. It receives many messages through the WM_POWERBROADCAST message. The one on the right is where I attempt to capture this message inside of a thread - updated with the code below in Remy's answer.
Obviously the "Power Setting" specific messages are not received, because I haven't called RegisterPowerSettingNotification - but there are other cases when I should still receive this message regardless, such as PBT_APMSUSPEND.
unit JD.ThreadTest;
interface
uses
System.Classes, System.SysUtils, Winapi.Messages, Winapi.Windows;
type
TMessageEvent = procedure(Sender: TObject; Message: TMessage) of object;
TDataThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
FOnMessage: TMessageEvent;
FMsg: TMessage;
procedure HandleMessage(var Message: TMessage);
protected
procedure Execute; override;
procedure DoTerminate; override;
procedure DoOnMessage;
public
constructor Create(const Title: String); reintroduce;
property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
end;
implementation
function DataThreadWndProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Thread: TDataThread;
Message: TMessage;
begin
if Msg = WM_NCCREATE then
begin
Thread := TDataThread(PCREATESTRUCT(lParam)^.lpCreateParams);
SetWindowLongPtr(Wnd, GWLP_USERDATA, LONG_PTR(Thread));
end else
Thread := TDataThread(GetWindowLongPtr(Wnd, GWLP_USERDATA));
if Thread <> nil then
begin
Message.Msg := Msg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;
Thread.HandleMessage(Message);
Result := Message.Result;
end else
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
constructor TDataThread.Create(const Title: String);
begin
inherited Create(True);
FTitle := Title;
with FWndClass do
begin
Style := 0;
lpfnWndProc := #DataThreadWndProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName := nil;
lpszClassName := 'TDataThread';
end;
end;
procedure TDataThread.Execute;
var
Msg: TMsg;
begin
if Winapi.Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME, 0, 0, 698, 517, 0, 0, HInstance, Self);
if FWnd = 0 then Exit;
while GetMessage(Msg, 0, 0, 0) do
begin
if Terminated then Exit;
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
procedure TDataThread.DoOnMessage;
begin
if Assigned(FOnMessage) then
FOnMessage(Self, FMsg);
end;
procedure TDataThread.DoTerminate;
begin
if FWnd <> 0 then DestroyWindow(FWnd);
Winapi.Windows.UnregisterClass(FWndClass.lpszClassName, HInstance);
inherited;
end;
procedure TDataThread.HandleMessage(var Message: TMessage);
begin
FMsg:= Message;
Synchronize(DoOnMessage);
case Message.Msg of
WM_POWERBROADCAST:
begin
end;
else
Message.Result := DefWindowProc(FWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end.
WM_POWERBROADCAST is not a posted message, so your message loop will never see it. You need a window procedure to receive that message. Your thread code is using DefWindowProc() directly as the window procedure. Change the call to RegisterClass() to register a custom procedure instead, that then calls DefWindowProc() for unhandled messages. GetMessage() will dispatch any sent message directly to the window procedure, and DispatchMessage() will dispatch any posted messages to the same window procedure.
unit JD.ThreadTest;
interface
uses
System.Classes, Winapi.Messages, Winapi.Windows;
type
TDataThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
procedure HandleMessage(var Message: TMessage);
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(const Title: String); reintroduce;
end;
implementation
function DataThreadWndProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Thread: TDataThread;
Message: TMessage;
begin
if Msg = WM_NCCREATE then
begin
Thread := TDataThread(PCREATESTRUCT(lParam)^.lpCreateParams);
SetWindowLongPtr(Wnd, GWLP_USERDATA, LONG_PTR(Thread));
end else
Thread := TDataThread(GetWindowLongPtr(Wnd, GWLP_USERDATA));
if Thread <> nil then
begin
Message.Msg := Msg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;
Thread.HandleMessage(Message);
Result := Message.Result;
end else
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
constructor TDataThread.Create(const Title: String);
begin
inherited Create(True);
FTitle := Title;
with FWndClass do
begin
Style := 0;
lpfnWndProc := #DataThreadWndProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName := nil;
lpszClassName := 'TDataThread';
end;
end;
procedure TDataThread.Execute;
var
Msg: TMsg;
begin
if Winapi.Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_OVERLAPPED, 0, 0, 0, 0, 0, 0, HInstance, Self);
if FWnd = 0 then Exit;
while GetMessage(Msg, 0, 0, 0) do
begin
if Terminated then Exit;
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
procedure TDataThread.DoTerminate;
begin
if FWnd <> 0 then DestroyWindow(FWnd);
Winapi.Windows.UnregisterClass(FWndClass.lpszClassName, HInstance);
inherited;
end;
procedure TDataThread.HandleMessage(var Message: TMessage);
begin
case Message.Msg of
WM_POWERBROADCAST:
begin
// ...
end;
else
Message.Result := DefWindowProc(FWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end.
i have this TThread that i use inside my dll to update some visual control its working fine but i face issue when i try to close my dll and reopen it again its raised this exception
checksynchronize called from thread which is not the main thread
what iam doing wrong ? i need to call checksynchronize within timer because i will update some vcl with Threading while app running .
Here is my Thread unit
unit Thread;
interface
uses Messages, Windows, SysUtils, dialogs, Classes, Menus, forms, ComOBJ,
ShlObj;
{ Thread client }
type
TThreadCallbackProc = procedure(Sender: TObject; Updatestring : string) of object;
TAPPTHREAD = class(TThread)
private
Fstatus : String;
FOnCallbackProc: TThreadCallbackProc;
procedure dosomework;
procedure DoCallbackProc;
//
protected
procedure Execute; override;
Public
constructor Create(CreateSuspended: Boolean; aThreadCallbackProc: TThreadCallbackProc);
destructor Destroy; override;
end;
var
APPTHREAD : TAPPTHREAD;
implementation
constructor TAPPTHREAD.Create(CreateSuspended: Boolean;
aThreadCallbackProc: TThreadCallbackProc);
begin
inherited Create(CreateSuspended);
FreeOnTerminate := True;
FOnCallbackProc := aThreadCallbackProc;
end;
destructor TAPPTHREAD.Destroy;
begin
//
end;
procedure TAPPTHREAD.DoCallbackProc;
begin
if Assigned(FOnCallbackProc) then
FOnCallbackProc(self, Fstatus);
end;
procedure TAPPTHREAD.Execute;
begin
while not Terminated do
begin
Fstatus := 'Synched';
if Fstatus <> '' then
dosomework;
end;
end;
procedure TAPPTHREAD.dosomework;
begin
if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;
end;
end.
Main Form
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure callbackproc(Sender: TObject; Updatestring : String);
end;
var
Form1: TForm1;
implementation
uses Thread;
{$R *.dfm}
procedure TForm1.callbackproc(Sender: TObject; Updatestring: String);
begin
label1.Caption := updatestring;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := Cafree;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if Assigned(APPTHREAD) then
AppThread.Terminate;
except end;
try
Timer2.Enabled := False;
except end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
Checksynchronize;
end;
end.
DFM
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 242
ClientWidth = 472
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnDestroy = FormDestroy
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 0
Top = 0
Width = 472
Height = 13
Align = alTop
Caption = 'Label1'
ExplicitLeft = 232
ExplicitTop = 136
ExplicitWidth = 31
end
object Timer1: TTimer
Enabled = False
OnTimer = Timer1Timer
Left = 232
Top = 128
end
object Timer2: TTimer
Enabled = False
Interval = 1
OnTimer = Timer2Timer
Left = 320
Top = 168
end
end
dll code
library dllapp;
uses
System.SysUtils,
Themes,
Windows,
Forms,
dialogs,
Graphics,
Vcl.ExtCtrls,
Unit1 in 'Unit1.pas' {Unit1},
DThreadsend in 'Thread.pas';
var
mHandle: THandle;
DLLHandle: Longint = 0;
function createApp(Width: Integer; Height: Integer; hw: HWnd;
app: TApplication): boolean; stdcall;
begin
mHandle := CreateMutex(nil, True, 'APPNAMETLOAD');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Halt;
end;
try
form1 := Tform1.CreateParented(hw); // **
form1.Width := Width;
form1.Height := Height;
Result := True
except
on e: exception do
begin
Result := False;
end;
end;
end;
procedure closeApp; stdcall;
begin
ApplicationClosed := True;
try
if mHandle <> 0 then
CloseHandle(mHandle);
except
end;
if Assigned(form1) then
try
FreeAndNil(form1);
except
end;
try
OptimizeRamUsage;
except
end;
end;
procedure showapp; stdcall;
begin
try
form1.Visible := True;
except
end;
form1.Show;
end;
procedure DLLEntryProc(EntryCode: Integer);
begin
case EntryCode of
DLL_PROCESS_DETACH:
begin
StyleServices.Free;
end;
DLL_PROCESS_ATTACH:
begin
end;
DLL_THREAD_ATTACH:
begin
end;
DLL_THREAD_DETACH:
begin
end;
end;
end;
exports
closeApp,
createApp,
showapp;
begin
DllProc := #DLLEntryProc;
end.
Host Application and how i create Dll
loadapp Unit
unit loadapp;
interface
uses windows, forms, System.SysUtils , dialogs;
procedure loadmainapp;
type
TcreaFunc = function (Width: Integer; Height: Integer; hw:HWnd; app: TApplication): boolean; stdcall;
TshowFunc = procedure stdcall;
TCloseAppFunc = procedure stdcall;
var
dllHandle : THandle = 0;
creaFunc : TcreaFunc;
showFunc : TshowFunc;
CloseAppFunc: TCloseAppFunc;
implementation
uses Mainapp;
procedure loadmainapp;
var
S: widestring;
PW: PWideChar;
begin
S := 'dllapp.dll';
pw:=pwidechar(widestring(s));
dllHandle := LoadLibrary(pw);
if dllHandle <> 0 then
begin
#creaFunc := GetProcAddress(dllHandle, 'createApp');
#showFunc := GetProcAddress(dllHandle, 'showapp');
if Assigned (creaFunc) then
begin
creaFunc(mainfrm.panel1.Width, mainfrm.panel1.Height, mainfrm.panel1.Handle, Application);
DisFunc;
end
else
ShowMessage('ERROR');
end
else
begin
ShowMessage('ERROR');
end;
end;
end.
Active Form
unit activeform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, Frmldr_TLB, StdVcl, Vcl.ExtCtrls, ShlObj, Vcl.StdCtrls, SHDocVw, MSHTML;
type
TActiveFrmldr = class(TActiveForm, IActiveFrmldr)
mpanl: TPanel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
end;
implementation
uses ComObj, ComServ, Mainapp, libacload;
{$R *.DFM}
{ TActiveFrmldr }
procedure TActiveFrmldr.FormDestroy(Sender: TObject);
begin
if dllHandle <> 0 then
begin
#CloseAppFunc := GetProcAddress(dllHandle, 'closeApp');
CloseAppFunc;
FreeLibrary(dllHandle); //release dll
end;
if Assigned(mainfrm) then
try
FreeAndNil(mainfrm);
except
end;
end;
procedure TActiveFrmldr.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
mainfrm.Parent := mpanl;
mainfrm.Left := 0;
mainfrm.Top := 0;
mainfrm.Width := self.Width;
mainfrm.Height := self.Height;
mainfrm.Align := alClient;
mainfrm.Show;
end;
procedure TActiveFrmldr.FormCreate(Sender: TObject);
begin
Application.CreateForm(Tmainfrm, mainfrm);
Timer1.Enabled := True;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TActiveFrmldr,
Class_ActiveFrmldr,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
finalization
end.
Main app Form that call load library function
unit Mainapp;
interface
uses
Windows, Messages, System.SysUtils, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Classes, libacload,
Vcl.Controls, Vcl.StdCtrls;
type
Tmainfrm = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
mainfrm: Tmainfrm;
implementation
Uses loadapp;
{$R *.dfm}
procedure Tmainfrm.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure Tmainfrm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
loadmainapp;
end;
procedure Tmainfrm.Timer2Timer(Sender: TObject);
begin
checksynchronize; // i do this to check some thread in activex it self
end;
end.
The error means that CheckSynchronize() is being called in a thread whose ThreadID does not match the RTL's global System.MainThreadID variable.
A DLL does not have a main thread of its own. MainThreadID gets initialized to whatever thread is initializing the DLL. So, if your DLL is creating its GUI in a different thread than the one that is initializing your DLL, CheckSynchronize() (and TThread.Synchronize(), and TThread.Queue()) will not work unless you manually update the MainThreadID variable to the ThreadID that is running your GUI. Do that before creating your worker thread, eg:
if IsLibrary then
MainThreadID := GetCurrentThreadID;
Form1 := TForm1.Create(nil);
Or:
procedure TForm1.FormCreate(Sender: TObject);
begin
if IsLibrary then
MainThreadID := GetCurrentThreadID;
end;
Or:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
if IsLibrary then
MainThreadID := GetCurrentThreadID;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
I created a class derived from TThread that executes in background a query.
I want that this class is decoupled from the client.
This kind of thread has the purpose of executing a simple check (like how many users are currently connected to the application, without blocking the UI), so a simple idea is to use the Synchronize Method.
Anyway since i want it to be decoupled i pass in the constructor a parameter of type
TSyncMethod: procedure of object;
Where TSyncMethod is a method on the client (a form in my case).
Anyway how can I pass the value to TSyncMethod? I should write the result on some "global place" and then inside my TSyncMethod I check for it?
I also tried to think of
TSyncMethod: procedure(ReturnValue: integer) of object;
but of course when I call Synchronize(MySyncMethod) I cannot pass parameters to it.
For such a simply example, you can put the desired value into a member field of the thread (or even into the thread's own ReturnValue property), then Synchronize() execution of the callback using an intermediate thread method, where you can then pass the value to the callback. For example:
type
TSyncMethod: procedure(ReturnValue: integer) of object;
TQueryUserConnected = class(TThread)
private
FMethod: TSyncMethod;
FMethodValue: Integer;
procedure DoSync;
protected
procedure Execute; override;
public
constructor Create(AMethod: TSyncMethod); reintroduce;
end;
constructor TQueryUserConnected.Create(AMethod: TSyncMethod);
begin
FMethod := AMethod;
inherited Create(False);
end;
procedure TQueryUserConnected.Execute;
begin
...
FMethodValue := ...;
if FMethod <> nil then
Synchronize(DoSync);
end;
procedure TQueryUserConnected.DoSync;
begin
if FMethod <> nil then
FMethod(FMethodValue);
end;
Using OmniThreadLibrary:
uses OtlFutures;
var
thread: IOmniFuture<integer>;
thread := TOmniFuture<integer>.Create(
function: integer;
begin
Result := YourFunction;
end;
);
// do something else
threadRes := thread.Value; //will block if thread is not yet done
Creating the TOmniFuture object will automatically start background thread executing your code. Later you can wait on result by calling .Value or you can use .TryValue or .IsDone to check if the thread has already completed its work.
What version of Delphi are you using? If you're on D2009 or newer, you can pass an anonymous method to Synchronize that takes no parameters but references local variables, passing them "under the radar" as part of the closure.
You can try my TCommThread component. It allows you to pass data back to the main thread without worrying about any of the complexities of threads or Windows messages.
Here's the code if you'd like to try it. You can also see some example code here.
CommThread Library:
unit Threading.CommThread;
interface
uses
Classes, SysUtils, ExtCtrls, SyncObjs, Generics.Collections, DateUtils;
const
CTID_USER = 1000;
PRM_USER = 1000;
CTID_STATUS = 1;
CTID_PROGRESS = 2;
type
TThreadParams = class(TDictionary<String, Variant>);
TThreadObjects = class(TDictionary<String, TObject>);
TCommThreadParams = class(TObject)
private
FThreadParams: TThreadParams;
FThreadObjects: TThreadObjects;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function GetParam(const ParamName: String): Variant;
function SetParam(const ParamName: String; ParamValue: Variant): TCommThreadParams;
function GetObject(const ObjectName: String): TObject;
function SetObject(const ObjectName: String; Obj: TObject): TCommThreadParams;
end;
TCommQueueItem = class(TObject)
private
FSender: TObject;
FMessageId: Integer;
FCommThreadParams: TCommThreadParams;
public
destructor Destroy; override;
property Sender: TObject read FSender write FSender;
property MessageId: Integer read FMessageId write FMessageId;
property CommThreadParams: TCommThreadParams read FCommThreadParams write FCommThreadParams;
end;
TCommQueue = class(TQueue<TCommQueueItem>);
ICommDispatchReceiver = interface
['{A4E2C9D1-E4E8-497D-A9BF-FAFE2D3A7C49}']
procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure CommThreadTerminated(Sender: TObject);
function Cancelled: Boolean;
end;
TCommThread = class(TThread)
protected
FCommThreadParams: TCommThreadParams;
FCommDispatchReceiver: ICommDispatchReceiver;
FName: String;
FProgressFrequency: Integer;
FNextSendTime: TDateTime;
procedure SendStatusMessage(const StatusText: String; StatusType: Integer = 0); virtual;
procedure SendProgressMessage(ProgressID: Int64; Progress, ProgressMax: Integer; AlwaysSend: Boolean = TRUE); virtual;
public
constructor Create(CommDispatchReceiver: TObject); reintroduce; virtual;
destructor Destroy; override;
function SetParam(const ParamName: String; ParamValue: Variant): TCommThread;
function GetParam(const ParamName: String): Variant;
function SetObject(const ObjectName: String; Obj: TObject): TCommThread;
function GetObject(const ObjectName: String): TObject;
procedure SendCommMessage(MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
property Name: String read FName;
end;
TCommThreadClass = Class of TCommThread;
TCommThreadQueue = class(TObjectList<TCommThread>);
TCommThreadDispatchState = (
ctsIdle,
ctsActive,
ctsTerminating
);
TOnReceiveThreadMessage = procedure(Source, Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams) of object;
TOnStateChange = procedure(Sender: TObject; State: TCommThreadDispatchState) of object;
TOnStatus = procedure(Source, Sender: TObject; const ID: String; StatusText: String; StatusType: Integer) of object;
TOnProgress = procedure(Source, Sender: TObject; const ID: String; Progress, ProgressMax: Integer) of object;
TBaseCommThreadDispatch = class(TComponent, ICommDispatchReceiver)
private
FProcessQueueTimer: TTimer;
FCSReceiveMessage: TCriticalSection;
FCSCommThreads: TCriticalSection;
FCommQueue: TCommQueue;
FActiveThreads: TList;
FCommThreadClass: TCommThreadClass;
FCommThreadDispatchState: TCommThreadDispatchState;
function CreateThread(const ThreadName: String = ''): TCommThread;
function GetActiveThreadCount: Integer;
function GetStateText: String;
protected
FOnReceiveThreadMessage: TOnReceiveThreadMessage;
FOnStateChange: TOnStateChange;
FOnStatus: TOnStatus;
FOnProgress: TOnProgress;
FManualMessageQueue: Boolean;
FProgressFrequency: Integer;
procedure SetManualMessageQueue(const Value: Boolean);
procedure SetProcessQueueTimerInterval(const Value: Integer);
procedure SetCommThreadDispatchState(const Value: TCommThreadDispatchState);
procedure QueueMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
procedure OnProcessQueueTimer(Sender: TObject);
function GetProcessQueueTimerInterval: Integer;
procedure CommThreadTerminated(Sender: TObject); virtual;
function Finished: Boolean; virtual;
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); virtual;
procedure DoOnStateChange; virtual;
procedure TerminateActiveThreads;
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
property CommThreadDispatchState: TCommThreadDispatchState read FCommThreadDispatchState write SetCommThreadDispatchState;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function NewThread(const ThreadName: String = ''): TCommThread; virtual;
procedure ProcessMessageQueue; virtual;
procedure Stop; virtual;
function State: TCommThreadDispatchState;
function Cancelled: Boolean;
property ActiveThreadCount: Integer read GetActiveThreadCount;
property StateText: String read GetStateText;
property CommThreadClass: TCommThreadClass read FCommThreadClass write FCommThreadClass;
end;
TCommThreadDispatch = class(TBaseCommThreadDispatch)
published
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
end;
TBaseStatusCommThreadDispatch = class(TBaseCommThreadDispatch)
protected
FOnStatus: TOnStatus;
FOnProgress: TOnProgress;
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
procedure DoOnStatus(Sender: TObject;const ID: String; const StatusText: String; StatusType: Integer); virtual;
procedure DoOnProgress(Sender: TObject; const ID: String; Progress, ProgressMax: Integer); virtual;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
end;
TStatusCommThreadDispatch = class(TBaseStatusCommThreadDispatch)
published
property OnReceiveThreadMessage: TOnReceiveThreadMessage read FOnReceiveThreadMessage write FOnReceiveThreadMessage;
property OnStateChange: TOnStateChange read FOnStateChange write FOnStateChange;
property OnStatus: TOnStatus read FOnStatus write FOnStatus;
property OnProgress: TOnProgress read FOnProgress write FOnProgress;
property ProgressFrequency: Integer read FProgressFrequency write FProgressFrequency;
property ProcessQueueTimerInterval: Integer read GetProcessQueueTimerInterval write SetProcessQueueTimerInterval;
property ManualMessageQueue: Boolean read FManualMessageQueue write SetManualMessageQueue;
end;
implementation
const
PRM_STATUS_TEXT = 'Status';
PRM_STATUS_TYPE = 'Type';
PRM_PROGRESS_ID = 'ProgressID';
PRM_PROGRESS = 'Progess';
PRM_PROGRESS_MAX = 'ProgressMax';
resourcestring
StrCommReceiverMustSupportInterface = 'CommDispatchReceiver must support ICommDispatchReceiver interface';
StrSenderMustBeATCommThread = 'Sender must be a TCommThread';
StrUnableToFindTerminatedThread = 'Unable to find the terminated thread';
StrIdle = 'Idle';
StrTerminating = 'Terminating';
StrActive = 'Active';
{ TCommThread }
constructor TCommThread.Create(CommDispatchReceiver: TObject);
begin
Assert(Supports(CommDispatchReceiver, ICommDispatchReceiver, FCommDispatchReceiver), StrCommReceiverMustSupportInterface);
inherited Create(TRUE);
FCommThreadParams := TCommThreadParams.Create;
end;
destructor TCommThread.Destroy;
begin
FCommDispatchReceiver.CommThreadTerminated(Self);
FreeAndNil(FCommThreadParams);
inherited;
end;
function TCommThread.GetObject(const ObjectName: String): TObject;
begin
Result := FCommThreadParams.GetObject(ObjectName);
end;
function TCommThread.GetParam(const ParamName: String): Variant;
begin
Result := FCommThreadParams.GetParam(ParamName);
end;
procedure TCommThread.SendCommMessage(MessageId: Integer;
CommThreadParams: TCommThreadParams);
begin
FCommDispatchReceiver.QueueMessage(Self, MessageId, CommThreadParams);
end;
procedure TCommThread.SendProgressMessage(ProgressID: Int64; Progress,
ProgressMax: Integer; AlwaysSend: Boolean);
begin
if (AlwaysSend) or (now > FNextSendTime) then
begin
// Send a status message to the comm receiver
SendCommMessage(CTID_PROGRESS, TCommThreadParams.Create
.SetParam(PRM_PROGRESS_ID, ProgressID)
.SetParam(PRM_PROGRESS, Progress)
.SetParam(PRM_PROGRESS_MAX, ProgressMax));
if not AlwaysSend then
FNextSendTime := now + (FProgressFrequency * OneMillisecond);
end;
end;
procedure TCommThread.SendStatusMessage(const StatusText: String;
StatusType: Integer);
begin
// Send a status message to the comm receiver
SendCommMessage(CTID_STATUS, TCommThreadParams.Create
.SetParam(PRM_STATUS_TEXT, StatusText)
.SetParam(PRM_STATUS_TYPE, StatusType));
end;
function TCommThread.SetObject(const ObjectName: String;
Obj: TObject): TCommThread;
begin
Result := Self;
FCommThreadParams.SetObject(ObjectName, Obj);
end;
function TCommThread.SetParam(const ParamName: String;
ParamValue: Variant): TCommThread;
begin
Result := Self;
FCommThreadParams.SetParam(ParamName, ParamValue);
end;
{ TCommThreadDispatch }
function TBaseCommThreadDispatch.Cancelled: Boolean;
begin
Result := State = ctsTerminating;
end;
procedure TBaseCommThreadDispatch.CommThreadTerminated(Sender: TObject);
var
idx: Integer;
begin
FCSCommThreads.Enter;
try
Assert(Sender is TCommThread, StrSenderMustBeATCommThread);
// Find the thread in the active thread list
idx := FActiveThreads.IndexOf(Sender);
Assert(idx <> -1, StrUnableToFindTerminatedThread);
// if we find it, remove it (we should always find it)
FActiveThreads.Delete(idx);
finally
FCSCommThreads.Leave;
end;
end;
constructor TBaseCommThreadDispatch.Create(AOwner: TComponent);
begin
inherited;
FCommThreadClass := TCommThread;
FProcessQueueTimer := TTimer.Create(nil);
FProcessQueueTimer.Enabled := FALSE;
FProcessQueueTimer.Interval := 5;
FProcessQueueTimer.OnTimer := OnProcessQueueTimer;
FProgressFrequency := 200;
FCommQueue := TCommQueue.Create;
FActiveThreads := TList.Create;
FCSReceiveMessage := TCriticalSection.Create;
FCSCommThreads := TCriticalSection.Create;
end;
destructor TBaseCommThreadDispatch.Destroy;
begin
// Stop the queue timer
FProcessQueueTimer.Enabled := FALSE;
TerminateActiveThreads;
// Pump the queue while there are active threads
while CommThreadDispatchState <> ctsIdle do
begin
ProcessMessageQueue;
sleep(10);
end;
// Free everything
FreeAndNil(FProcessQueueTimer);
FreeAndNil(FCommQueue);
FreeAndNil(FCSReceiveMessage);
FreeAndNil(FCSCommThreads);
FreeAndNil(FActiveThreads);
inherited;
end;
procedure TBaseCommThreadDispatch.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
// Don't send the messages if we're being destroyed
if not (csDestroying in ComponentState) then
begin
if Assigned(FOnReceiveThreadMessage) then
FOnReceiveThreadMessage(Self, Sender, MessageId, CommThreadParams);
end;
end;
procedure TBaseCommThreadDispatch.DoOnStateChange;
begin
if (Assigned(FOnStateChange)) and (not (csDestroying in ComponentState)) then
FOnStateChange(Self, FCommThreadDispatchState);
end;
function TBaseCommThreadDispatch.GetActiveThreadCount: Integer;
begin
Result := FActiveThreads.Count;
end;
function TBaseCommThreadDispatch.GetProcessQueueTimerInterval: Integer;
begin
Result := FProcessQueueTimer.Interval;
end;
function TBaseCommThreadDispatch.GetStateText: String;
begin
case State of
ctsIdle: Result := StrIdle;
ctsTerminating: Result := StrTerminating;
ctsActive: Result := StrActive;
end;
end;
function TBaseCommThreadDispatch.NewThread(const ThreadName: String): TCommThread;
begin
if FCommThreadDispatchState = ctsTerminating then
Result := nil
else
begin
// Make sure we're active
if CommThreadDispatchState = ctsIdle then
CommThreadDispatchState := ctsActive;
Result := CreateThread(ThreadName);
FActiveThreads.Add(Result);
if ThreadName = '' then
Result.FName := IntToStr(Integer(Result))
else
Result.FName := ThreadName;
Result.FProgressFrequency := FProgressFrequency;
end;
end;
function TBaseCommThreadDispatch.CreateThread(
const ThreadName: String): TCommThread;
begin
Result := FCommThreadClass.Create(Self);
Result.FreeOnTerminate := TRUE;
end;
procedure TBaseCommThreadDispatch.OnProcessQueueTimer(Sender: TObject);
begin
ProcessMessageQueue;
end;
procedure TBaseCommThreadDispatch.ProcessMessageQueue;
var
CommQueueItem: TCommQueueItem;
begin
if FCommThreadDispatchState in [ctsActive, ctsTerminating] then
begin
if FCommQueue.Count > 0 then
begin
FCSReceiveMessage.Enter;
try
CommQueueItem := FCommQueue.Dequeue;
while Assigned(CommQueueItem) do
begin
try
DoOnReceiveThreadMessage(CommQueueItem.Sender, CommQueueItem.MessageId, CommQueueItem.CommThreadParams);
finally
FreeAndNil(CommQueueItem);
end;
if FCommQueue.Count > 0 then
CommQueueItem := FCommQueue.Dequeue;
end;
finally
FCSReceiveMessage.Leave
end;
end;
if Finished then
begin
FCommThreadDispatchState := ctsIdle;
DoOnStateChange;
end;
end;
end;
function TBaseCommThreadDispatch.Finished: Boolean;
begin
Result := FActiveThreads.Count = 0;
end;
procedure TBaseCommThreadDispatch.QueueMessage(Sender: TObject; MessageId: Integer;
CommThreadParams: TCommThreadParams);
var
CommQueueItem: TCommQueueItem;
begin
FCSReceiveMessage.Enter;
try
CommQueueItem := TCommQueueItem.Create;
CommQueueItem.Sender := Sender;
CommQueueItem.MessageId := MessageId;
CommQueueItem.CommThreadParams := CommThreadParams;
FCommQueue.Enqueue(CommQueueItem);
finally
FCSReceiveMessage.Leave
end;
end;
procedure TBaseCommThreadDispatch.SetCommThreadDispatchState(
const Value: TCommThreadDispatchState);
begin
if FCommThreadDispatchState <> ctsTerminating then
begin
if Value = ctsActive then
begin
if not FManualMessageQueue then
FProcessQueueTimer.Enabled := TRUE;
end
else
TerminateActiveThreads;
end;
FCommThreadDispatchState := Value;
DoOnStateChange;
end;
procedure TBaseCommThreadDispatch.SetManualMessageQueue(const Value: Boolean);
begin
FManualMessageQueue := Value;
end;
procedure TBaseCommThreadDispatch.SetProcessQueueTimerInterval(const Value: Integer);
begin
FProcessQueueTimer.Interval := Value;
end;
function TBaseCommThreadDispatch.State: TCommThreadDispatchState;
begin
Result := FCommThreadDispatchState;
end;
procedure TBaseCommThreadDispatch.Stop;
begin
if CommThreadDispatchState = ctsActive then
TerminateActiveThreads;
end;
procedure TBaseCommThreadDispatch.TerminateActiveThreads;
var
i: Integer;
begin
if FCommThreadDispatchState = ctsActive then
begin
// Lock threads
FCSCommThreads.Acquire;
try
FCommThreadDispatchState := ctsTerminating;
DoOnStateChange;
// Terminate each thread in turn
for i := 0 to pred(FActiveThreads.Count) do
TCommThread(FActiveThreads[i]).Terminate;
finally
FCSCommThreads.Release;
end;
end;
end;
{ TCommThreadParams }
procedure TCommThreadParams.Clear;
begin
FThreadParams.Clear;
FThreadObjects.Clear;
end;
constructor TCommThreadParams.Create;
begin
FThreadParams := TThreadParams.Create;
FThreadObjects := TThreadObjects.Create;
end;
destructor TCommThreadParams.Destroy;
begin
FreeAndNil(FThreadParams);
FreeAndNil(FThreadObjects);
inherited;
end;
function TCommThreadParams.GetObject(const ObjectName: String): TObject;
begin
Result := FThreadObjects.Items[ObjectName];
end;
function TCommThreadParams.GetParam(const ParamName: String): Variant;
begin
Result := FThreadParams.Items[ParamName];
end;
function TCommThreadParams.SetObject(const ObjectName: String;
Obj: TObject): TCommThreadParams;
begin
FThreadObjects.AddOrSetValue(ObjectName, Obj);
Result := Self;
end;
function TCommThreadParams.SetParam(const ParamName: String;
ParamValue: Variant): TCommThreadParams;
begin
FThreadParams.AddOrSetValue(ParamName, ParamValue);
Result := Self;
end;
{ TCommQueueItem }
destructor TCommQueueItem.Destroy;
begin
if Assigned(FCommThreadParams) then
FreeAndNil(FCommThreadParams);
inherited;
end;
{ TBaseStatusCommThreadDispatch }
procedure TBaseStatusCommThreadDispatch.DoOnReceiveThreadMessage(
Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited;
case MessageId of
// Status Message
CTID_STATUS: DoOnStatus(Sender,
Name,
CommThreadParams.GetParam(PRM_STATUS_TEXT),
CommThreadParams.GetParam(PRM_STATUS_TYPE));
// Progress Message
CTID_PROGRESS: DoOnProgress(Sender,
CommThreadParams.GetParam(PRM_PROGRESS_ID),
CommThreadParams.GetParam(PRM_PROGRESS),
CommThreadParams.GetParam(PRM_PROGRESS_MAX));
end;
end;
procedure TBaseStatusCommThreadDispatch.DoOnStatus(Sender: TObject; const ID,
StatusText: String; StatusType: Integer);
begin
if (not (csDestroying in ComponentState)) and (Assigned(FOnStatus)) then
FOnStatus(Self, Sender, ID, StatusText, StatusType);
end;
procedure TBaseStatusCommThreadDispatch.DoOnProgress(Sender: TObject;
const ID: String; Progress, ProgressMax: Integer);
begin
if not (csDestroying in ComponentState) and (Assigned(FOnProgress)) then
FOnProgress(Self, Sender, ID, Progress, ProgressMax);
end;
end.
To use the library, simply descend your thread from the TCommThread thread and override the Execute procedure:
MyCommThreadObject = class(TCommThread)
public
procedure Execute; override;
end;
Next, create a descendant of the TStatusCommThreadDispatch component and set it's events.
MyCommThreadComponent := TStatusCommThreadDispatch.Create(Self);
// Add the event handlers
MyCommThreadComponent.OnStateChange := OnStateChange;
MyCommThreadComponent.OnReceiveThreadMessage := OnReceiveThreadMessage;
MyCommThreadComponent.OnStatus := OnStatus;
MyCommThreadComponent.OnProgress := OnProgress;
// Set the thread class
MyCommThreadComponent.CommThreadClass := TMyCommThread;
Make sure you set the CommThreadClass to your TCommThread descendant.
Now all you need to do is create the threads via MyCommThreadComponent:
FCommThreadComponent.NewThread
.SetParam('MyThreadInputParameter', '12345')
.SetObject('MyThreadInputObject', MyObject)
.Start;
Add as many parameters and objects as you like. In your threads Execute method you can retrieve the parameters and objects.
MyThreadParameter := GetParam('MyThreadInputParameter'); // 12345
MyThreadObject := GetObject('MyThreadInputObject'); // MyObject
Parameters will be automatically freed. You need to manage objects yourself.
To send a message back to the main thread from the threads execute method:
FCommDispatchReceiver.QueueMessage(Self, CTID_MY_MESSAGE_ID, TCommThreadParams.Create
.SetObject('MyThreadObject', MyThreadObject)
.SetParam('MyThreadOutputParameter', MyThreadParameter));
Again, parameters will be destroyed automatically, objects you have to manage yourself.
To receive messages in the main thread either attach the OnReceiveThreadMessage event or override the DoOnReceiveThreadMessage procedure:
procedure DoOnReceiveThreadMessage(Sender: TObject; MessageId: Integer; CommThreadParams: TCommThreadParams); override;
Use the overridden procedure to process the messages sent back to your main thread:
procedure THostDiscovery.DoOnReceiveThreadMessage(Sender: TObject;
MessageId: Integer; CommThreadParams: TCommThreadParams);
begin
inherited;
case MessageId of
CTID_MY_MESSAGE_ID:
begin
// Process the CTID_MY_MESSAGE_ID message
DoSomethingWithTheMessage(CommThreadParams.GetParam('MyThreadOutputParameter'),
CommThreadParams.GeObject('MyThreadObject'));
end;
end;
end;
The messages are pumped in the ProcessMessageQueue procedure. This procedure is called via a TTimer. If you use the component in a console app you will need to call ProcessMessageQueue manually. The timer will start when the first thread is created. It will stop when the last thread has finished. If you need to control when the timer stops you can override the Finished procedure. You can also perform actions depending on the state of the threads by overriding the DoOnStateChange procedure.
Take a look at the TCommThread descendant TStatusCommThreadDispatch. It implements the sending of simple Status and Progress messages back to the main thread.
I hope this helps and that I've explained it OK.
Create a form and add a ListBox , two Buttons, and edit your form. Then use this code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TSyncMethod = procedure(ReturnValue: integer) of object;
TMyThread = class(TThread)
private
fLowerLimit: Integer;
fUpperLimit: Integer;
FMethod: TSyncMethod;
FMethodValue: Integer;
procedure UpdateMainThread;
protected
procedure Execute; override;
public
constructor Create(AMethod: TSyncMethod;lValue, uValue: Integer; Suspended: Boolean);
end;
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
ListBox1: TListBox;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
MyMethod: TSyncMethod;
ReturnValue : Integer;
CountingThread: TMyThread;
procedure MyTest(X : Integer);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TMyThread.Create(AMethod: TSyncMethod;lValue, uValue: Integer; Suspended: Boolean);
begin
FMethod := AMethod;
Inherited Create(Suspended);
fLowerLimit := lValue;
fUpperLimit := uValue;
FreeOnTerminate := True;
Priority := tpLowest;
end;
procedure TMyThread.Execute;
var
I: Integer;
begin
For I := fLowerLimit to fUpperLimit do
if (I mod 10) = 0 then
Synchronize(UpdateMainThread);
FMethod(FMethodValue);
end;
procedure TMyThread.UpdateMainThread;
begin
Form1.ListBox1.Items.Add('Hello World');
FMethodValue := Form1.ListBox1.Count;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MyMethod := MyTest;
CountingThread := TMyThread.Create(MyMethod,22, 999, True);
CountingThread.Resume;
// ShowMessage(IntToStr(ReturnValue));
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage(Edit1.Text);
end;
procedure TForm1.MyTest(X: Integer);
begin
ShowMessage(IntToStr(X));
end;
end.