Why does my thread just hang after a certain number of loops? - multithreading

I've made an application to select specific .xml files, open them (into a TStringList), and check for specific numbers, then move the to a folder so that I can upload to another section of our company.
Here's the problem.
After around 9728 items moved, it just stops, for no reason that I can think of.
It doesn't show any error, just keeps hanging.
Maybe it's my code that's doing it after some time, but I hope you guys can help!
I'm using Delphi 2006.
Thread Code:
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, DBGrids, dblookup, FileCtrl, ExtDlgs, StrUtils;
type
FThread = class(TThread)
private
{ Private declarations }
arquivo: string;
Lista3: TStringList;
protected
procedure Execute; override;
procedure UpdateMemo; overload;
end;
implementation
uses AcharArquivos3;
{ Important: Methods and properties of objects in visual components can only be
used in a method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure FThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end; }
{ FThread }
procedure FThread.UpdateMemo;
begin
Lista3.Add(Arquivo);
end;
procedure FThread.Execute;
var
SR: TSearchRec;
Lista2: TStringList;
Caminho: string;
CaminhoOriginal: string;
Origem: string;
Destino: string;
begin
inherited;
Caminho := Form3.Dir;
CaminhoOriginal := Form3.Edit1.Text;
Lista2 := TStringList.Create;
Lista3 := TStringList.Create;
if FindFirst(IncludeTrailingBackslash(Caminho) + '*.*', faAnyFile or faDirectory, SR) = 0 then
try
repeat
if (SR.Attr and faDirectory) = 0 then
begin
if (ExtractFileExt(SR.Name) = '.xml') and not (Pos(Sr.Name, Lista3.Text) > 0) then
Lista2.LoadFromFile(IncludeTrailingBackslash(Caminho) + SR.name);
if Pos(Form3.NCM, Lista2.Text) > 0 then
begin
Origem := Caminho + '\' + SR.name;
Destino := CaminhoOriginal + '\' + 'Incluir' + '\' + SR.Name;
Arquivo := ChangeFileExt(SR.name, '');
Lista3.Add(Arquivo);
MoveFile(Pchar(Origem), Pchar(Destino));
Synchronize(Self.UpdateMemo);
end;
end
else if (SR.Name <> '.') and (SR.Name <> '..') and (Sr.Name <> 'Incluir') then
begin
Caminho := (IncludeTrailingBackslash(Caminho) + SR.Name); // Recursão
end;
until (FindNext(Sr) <> 0) and (Sr.Name = 'Incluir');
finally
FindClose(SR);
ShowMessage('Pesquisa Concluida!');
Form3.Button6.Enabled := True;
Form3.Button5.Enabled := True;
Form3.Button2.Enabled := True;
Form3.Memo3.Lines.Add(Lista3.Text);
end;
end;
end.
VCL Code:
unit AcharArquivos3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, DBGrids, dblookup, FileCtrl, ExtDlgs, StrUtils;
type
TForm3 = class(TForm)
OpenDialog1: TOpenDialog;
Button2: TButton;
OpenPictureDialog1: TOpenPictureDialog;
SaveDialog1: TSaveDialog;
Label3: TLabel;
Memo3: TMemo;
Button5: TButton;
Label4: TLabel;
Button6: TButton;
ComboBox1: TComboBox;
Edit1: TEdit;
Label1: TLabel;
procedure Button2Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Path:String;
NCM: String;
Origem: string;
Destino: string;
Dir: String;
Lista2: TStringList;
Lista: TStringList;
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
uses Unit5;
function WUserName: String;
var
nSize: DWord;
begin
nSize := 1024;
SetLength(Result, nSize);
if GetUserName(PChar(Result), nSize) then
SetLength(Result, nSize-1)
else
RaiseLastOSError;
end;
//Pegando a pasta dos XML
procedure TForm3.Button2Click(Sender: TObject);
var
chosenDirectory : string;
begin
if SelectDirectory('Select a directory', 'C:\' + WUserName + 'Documents', chosenDirectory) then
begin
Edit1.Text := chosenDirectory;
end
else
ShowMessage('Seleção de Pasta Abortada');
end;
procedure TForm3.Button5Click(Sender: TObject);
var
FileName: String;
begin
if (Memo3.GetTextLen() > 0) then
begin
SaveDialog1.FileName := 'ListaEncontrados';
SaveDialog1.DefaultExt := 'txt';
SaveDialog1.Filter := 'Text file|*.txt|Word file|*.doc';
SaveDialog1.Title := 'Salve o arquivo de Lista';
Memo3.Lines.Delete(Memo3.Lines.Count-1);
if SaveDialog1.Execute then
Memo3.Lines.SaveToFile(SaveDialog1.FileName);
SaveDialog1.Free;
Memo3.Lines.Clear;
end
else
ShowMessage('Nenhum Arquivo Excluido');
end;
procedure TForm3.Button6Click(Sender: TObject);
var
vThread : FThread;
begin
if ComboBox1.Text = '' then
begin
ShowMessage('Por Favor escolha um NCM para procura');
Exit;
end;
if Edit1.Text = '' then
begin
ShowMessage('Por Favor Selecione ou Digite um Diretório');
Exit;
end;
if ComboBox1.Text = '2402 - Cigarros' then
NCM := '<NCM>2402';
Dir := Edit1.Text;
if not DirectoryExists(Dir + '\' + 'Incluir') then
begin
CreateDir(Dir + '\' + 'Incluir.');
end;
Button6.Enabled := False;
Button5.Enabled := False;
Button2.Enabled := False;
vThread := FThread.Create(True);
vThread.FreeOnTerminate := True;
VThread.Resume;
end;
end.

Related

Delphi. How to Send a Thread a Message from a Form and for the Thread to Process the Message

I have a Main Form that creates a Thread.
The Thread creates a Form with a Progress bar.
What I'm trying to do is create the Thread from the Main Form and send a message to the Thread to increase the Progress bar on the Thread Form.
This will allow me to execute code and provide the user with the progress.
So far I have the Main Form:-
unit uMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, contnrs,
StdCtrls, uThread, ExtCtrls;
type
TMainForm = class(TForm)
btnCreateForm: TButton;
btnSendMessage: TButton;
procedure btnCreateFormClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnSendMessageClick(Sender: TObject);
private
{ Private declarations }
MyProgressBarThread: TProgressBarThread;
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.btnCreateFormClick(Sender: TObject);
begin
MyProgressBarThread := TProgressBarThread.Create(Self);
end;
procedure TMainForm.btnSendMessageClick(Sender: TObject);
begin
// Is this correct way to send a message to the Thread?
PostThreadMessage(MyProgressBarThread.Handle, WM_USER, 0, 0);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
if Assigned(MyProgressBarThread) then
MyProgressBarThread.Terminate;
end;
end.
And the Thread:-
unit uThread;
interface
uses
Forms, StdCtrls, Graphics, ExtCtrls, ClipBrd, Contnrs, JPeg, SysUtils,
ComCtrls, System.Classes{taRightJustify}, Winapi.Messages, Winapi.Windows;
type
TProgressBarThread = class(TThread)
private
{ Private declarations }
FForm: TForm;
FUse_Progress_Position_Label: Boolean;
lbProcessing_Name: TLabel;
lbProcessing_Description: TLabel;
lbProcessing_Position_Number: TLabel;
ProgressBar1: TProgressBar;
procedure OnCloseForm(Sender: TObject; var Action: TCloseAction);
procedure OnDestroyForm(Sender: TObject);
protected
procedure Execute; override;
public
constructor Create(AForm: TForm);
end;
implementation
{ TProgressBarThread }
constructor TProgressBarThread.Create(AForm: TForm);
begin
FForm := TForm.Create(nil);
lbProcessing_Name := TLabel.Create(FForm);
ProgressBar1 := TProgressBar.Create(FForm);
lbProcessing_Description := TLabel.Create(FForm);
lbProcessing_Position_Number := TLabel.Create(FForm);
with FForm do
begin
Caption := 'Please Wait...';
Left := 277;
Top := 296;
BorderIcons := [biSystemMenu];
BorderStyle := bsSingle;
ClientHeight := 80;
ClientWidth := 476;
Color := clBtnFace;
Font.Color := clWindowText;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
FormStyle := fsStayOnTop;
OldCreateOrder := False;
Position := poMainFormCenter;
PixelsPerInch := 96;
OnClose := OnCloseForm;
OnDestroy := OnDestroyForm;
with lbProcessing_Name do
begin
Parent := FForm;
Left := 16;
Top := 24;
Width := 130;
Height := 13;
Caption := 'Processing Request... ';
Font.Color := clWindowText;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [fsBold];
ParentFont := False;
end;
with lbProcessing_Description do
begin
Parent := FForm;
Left := 160;
Top := 24;
Width := 3;
Height := 13;
Font.Color := clBlue;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
ParentFont := False;
end;
with lbProcessing_Position_Number do
begin
Parent := FForm;
Left := 456;
Top := 24;
Width := 6;
Height := 13;
Alignment := taRightJustify;
Caption := '0';
Visible := False;
Font.Color := clBlue;
Font.Height := -11;
Font.Name := 'MS Sans Serif';
Font.Style := [];
end;
with ProgressBar1 do
begin
Parent := FForm;
Left := 16;
Top := 48;
Width := 449;
Height := 17;
TabOrder := 0;
end;
end;
FForm.Show;
inherited Create(False);
end;
procedure TProgressBarThread.Execute;
var
Msg: TMsg;
begin
FreeOnTerminate := True;
// Is this the correct way to Look for Messages sent to the Thread and to handle them?
while not (Terminated or Application.Terminated) do
begin
if PeekMessage(&Msg, 0, 0, 0, PM_NOREMOVE) then
begin
if Msg.message > 0 then
ProgressBar1.Position := ProgressBar1.Position + 1;
end;
end;
end;
procedure TProgressBarThread.OnCloseForm(Sender: TObject; var Action: TCloseAction);
begin
Terminate;
// WaitFor;
end;
procedure TProgressBarThread.OnDestroyForm(Sender: TObject);
begin
if not Terminated then
begin
Terminate;
WaitFor;
end;
end;
end.
Is this the correct way to go for my situation? If not then any examples?
Is the PostThreadMessage(MyProgressBarThread.Handle, WM_USER, 0, 0); correct?
How do I Listening for messages in the Thread and process them?
tia
Updated based on comments 09/07/2021
Is this code correct and safe:-
MainForm
unit uMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, contnrs,
StdCtrls, uThread, ExtCtrls;
type
TMainForm = class(TForm)
btnStart_Process: TButton;
procedure btnStart_ProcessClick(Sender: TObject);
private
{ Private declarations }
Start_ProcessThread: TStart_ProcessThread;
procedure TheCallback(const ProgressBarPosition: Integer);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
hLogWnd: HWND = 0;
implementation
uses
uProgressBar;
{$R *.DFM}
procedure TMainForm.btnStart_ProcessClick(Sender: TObject);
begin
frmProgressBar.ProgressBar1.Max := Con_Max_ProgressBarPosition;
frmProgressBar.ProgressBar1.Position := 0;
frmProgressBar.Show;
Start_ProcessThread := TStart_ProcessThread.Create(TheCallback);
end;
procedure TMainForm.TheCallback(const ProgressBarPosition: Integer);
begin
if ProgressBarPosition <> Con_Finished_Processing then
frmProgressBar.ProgressBar1.Position := ProgressBarPosition
else
frmProgressBar.Close;
end;
end.
ProgressBarForm
unit uProgressBar;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls;
type
TfrmProgressBar = class(TForm)
ProgressBar1: TProgressBar;
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmProgressBar: TfrmProgressBar;
implementation
{$R *.dfm}
end.
Thread
unit uThread;
interface
uses
Forms, StdCtrls, Graphics, ExtCtrls, ClipBrd, Contnrs, JPeg, SysUtils,
ComCtrls, System.Classes{taRightJustify}, Winapi.Messages, Winapi.Windows;
const
Con_Finished_Processing = -1;
Con_Max_ProgressBarPosition = 1024 * 65536;
type
TMyCallback = procedure(const ProgressBarPosition: Integer) of object;
TStart_ProcessThread = class(TThread)
private
FCallback : TMyCallback;
procedure Execute; override;
procedure SendLog(I: Integer);
public
constructor Create(aCallback : TMyCallback);
end;
implementation
{ TStart_ProcessThread }
constructor TStart_ProcessThread.Create(aCallback: TMyCallback);
begin
inherited Create(false);
FCallback := aCallback;
end;
procedure TStart_ProcessThread.SendLog(I: Integer);
begin
if not Assigned(FCallback) then
Exit;
Self.Queue( // Executed later in the main thread
procedure
begin
FCallback(I{ThePosition});
end
);
end;
procedure TStart_ProcessThread.Execute;
var
I: Integer;
begin
// Do the Work Load here:-
for I := 0 to Con_Max_ProgressBarPosition do
begin
if ((I mod 65536) = 0) then
begin
// Send back the progress of the work here:-
SendLog(I);
Sleep(10);
end;
end;
// Finished
SendLog(Con_Finished_Processing);
end;
end.
If your going for additional Components: i would suggest looking at Omni Thread Library.
http://www.omnithreadlibrary.com/book/chap10.html#leanpub-auto-sending-data-from-a-worker-to-a-form
The 7.13.2 Example in the current Version (Sending data from a worker to a form)
Its a great Library and the free book from the link above is a good source for many multithreaded Scenarios.
I use almost every Time the 3.2 Blocking collection (in the text there is a link to the demo source) Its not specially what your looking for, but a combination of both should be powerfull to create multihreaded chains of workloads.
kbmMW contains a feature called SmartEvent which I would recommend checking out. It works great in such scenarios, where you want different parts of your code (threaded or not) to communicate with each other and transfer data.
It works as simple as this:
TForm1 = class(...)
...
private
procedure FormCreate(Sender: TObject);
public
[kbmMW_Event('UPDATESTATUS',[mweoSync])]
procedure UpdateStatus(const APct:integer);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Event.Subscribe(self);
end;
procedure TForm1.UpdateStatus(const APct:integer);
begin
Label1.Caption:='Pct='+inttostr(APct);
end;
and then in your thread do:
procedure TYourThread.Execute;
begin
...
Event.Notify('UPDATESTATUS',pct);
...
end;
All thread synchronization etc. will be handled automatically for you.
You can even make calls, expecting data back, and there can be any number of subscribers for your notifications.
kbmMW is a toolbox that fully supports Delphi and all platforms.
You can read more about SmartEvent here: https://components4developers.blog/2019/11/11/smartevent-with-kbmmw-1/

multi-thread causes memory leak

I'm made an application that receives data from an API every 10 seconds and this is all done within 2 threads. I can't figure out why there is a memory leak as I free all that I used after the task is done.
I want to apologize if I'm missing or doing something wrong as I'm new to threading and I don't fully understand how it works.
I tried to remake this: Synchronizing Threads and GUI in a Delphi Application but failed as I don't understand what is going on. If someone can please explain to me what I'm doing wrong and how I can fix it or make it better.
Current Code:
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP,
IdSSLOpenSSL, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack, IdSSL;
type
TfrmMain = class(TForm)
grpLuno: TGroupBox;
lblBid: TLabel;
lblRolling24HourVolume: TLabel;
grpBinance: TGroupBox;
tmrRefresh: TTimer;
lblPrice: TLabel;
lblBinanceVolume: TLabel;
lbl1: TLabel;
lbl24hChange: TLabel;
procedure Refresh;
procedure tmrRefreshTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TGetLuno = class(TThread)
protected
procedure Execute; override;
end;
type
TGetBinance = class(TThread)
protected
procedure Execute; override;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
uses
djson, DateUtils, Math;
{ TForm1 }
procedure TfrmMain.FormCreate(Sender: TObject);
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NoMove or SWP_NoSize);
Refresh;
end;
procedure TfrmMain.Refresh;
begin
with TGetLuno.Create do
begin
FreeOnTerminate := True;
end;
with TGetBinance.Create do
begin
FreeOnTerminate := True;
end;
end;
procedure TfrmMain.tmrRefreshTimer(Sender: TObject);
begin
Refresh;
end;
{ TGetLuno }
procedure TGetLuno.Execute;
var
httpclient: TIdHTTP;
sdata: string;
jdata: TJSON;
begin
httpclient := TIdHTTP.Create(nil);
try
sdata := httpclient.Get('https://api.mybitx.com/api/1/ticker?pair=XBTZAR');
finally
httpclient.Free;
end;
jdata := TJSON.Parse(sdata);
try
frmMain.lblBid.Caption := 'Price: R ' + jdata['bid'].AsString;
frmMain.lblRolling24HourVolume.Caption := 'Volume: ' + jdata['rolling_24_hour_volume'].AsString;
finally
jdata.Free;
end;
end;
{ TGetBinance }
procedure TGetBinance.Execute;
var
httpclient: TIdHTTP;
sdata: string;
jdata: TJSON;
SocketOpenSSL: TIdSSLIOHandlerSocketOpenSSL;
begin
httpclient := TIdHTTP.Create(nil);
SocketOpenSSL := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
SocketOpenSSL.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2];
httpclient.IOHandler := SocketOpenSSL;
try
sdata := httpclient.Get('https://api.binance.com/api/v1/ticker/24hr?symbol=BTCUSDT');
finally
httpclient.Free;
end;
jdata := TJSON.Parse(sdata);
try
frmMain.lblPrice.Caption := 'Price: $ ' + jdata['lastPrice'].AsString;
frmMain.lblBinanceVolume.Caption := 'Volume: ' + jdata['volume'].AsString;
if StrToFloat(StringReplace(jdata['priceChangePercent'].AsString, '.', ',', [rfReplaceAll, rfIgnoreCase])) > 0 then
frmMain.lbl24hChange.Font.Color := clLime
else
frmMain.lbl24hChange.Font.Color := clRed;
frmMain.lbl24hChange.Caption := StringReplace(FloatToStr(RoundTo(StrToFloat(StringReplace(jdata['priceChangePercent'].AsString, '.', ',', [rfReplaceAll, rfIgnoreCase])), -2)), ',', '.', [rfReplaceAll, rfIgnoreCase]) + ' %';
finally
jdata.Free;
end;
end;
initialization
ReportMemoryLeaksOnShutdown := True;
end.
Inside your thread execute methods, you are accessing VCL frmMain components directly.
Since the VCL framework must be executed in the main thread only, you will need to divert those calls. Use TThread.Synchronize() or TThread.Queue() for example:
jdata := TJSON.Parse(sdata);
try
Synchronize(
procedure
begin
frmMain.lblPrice.Caption := 'Price: $ ' + jdata['lastPrice'].AsString;
frmMain.lblBinanceVolume.Caption := 'Volume: ' + jdata['volume'].AsString;
if StrToFloat(StringReplace(jdata['priceChangePercent'].AsString, '.',
',', [rfReplaceAll, rfIgnoreCase])) > 0 then
frmMain.lbl24hChange.Font.Color := clLime
else
frmMain.lbl24hChange.Font.Color := clRed;
frmMain.lbl24hChange.Caption :=
StringReplace(FloatToStr(RoundTo(StrToFloat(StringReplace(jdata
['priceChangePercent'].AsString, '.', ',', [rfReplaceAll, rfIgnoreCase])
), -2)), ',', '.', [rfReplaceAll, rfIgnoreCase]) + ' %';
end);
finally
jdata.Free;
end;

How to send records containing strings between applications

So, I have a class that uses WM_COPYDATA to allow applications to communicate.
type
TMyRec = record
Name: string[255]; // I want just string
Age: integer;
Birthday: TDateTime;
end;
function TAppCommunication.SendRecord(const ARecordType: ShortString; const ARecordToSend: Pointer; ARecordSize: Integer): Boolean;
var
_Stream: TMemoryStream;
begin
_Stream := TMemoryStream.Create;
try
_Stream.WriteBuffer(ARecordType, 1 + Length(ARecordType));
_Stream.WriteBuffer(ARecordToSend^, ARecordSize);
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
function TAppCommunication.SendStreamData(const AStream: TMemoryStream;
const ADataType: TCopyDataType): Boolean;
var
_CopyDataStruct: TCopyDataStruct;
begin
Result := False;
if AStream.Size = 0 then
Exit;
_CopyDataStruct.dwData := integer(ADataType);
_CopyDataStruct.cbData := AStream.Size;
_CopyDataStruct.lpData := AStream.Memory;
Result := SendData(_CopyDataStruct);
end;
function TAppCommunication.SendData(const ADataToSend: TCopyDataStruct)
: Boolean;
var
_SendResponse: integer;
_ReceiverHandle: THandle;
begin
Result := False;
_ReceiverHandle := GetRemoteReceiverHandle;
if (_ReceiverHandle = 0) then
Exit;
_SendResponse := SendMessage(_ReceiverHandle, WM_COPYDATA,
WPARAM(FLocalReceiverForm.Handle), LPARAM(#ADataToSend));
Result := _SendResponse <> 0;
end;
Sender application:
procedure TSenderMainForm.BitBtn1Click(Sender: TObject);
var
_AppCommunication: TAppCommunication;
_ms: TMemoryStream;
_Rec: TMyRec;
_Record: TAttrData;
begin
_AppCommunication := TAppCommunication.Create('LocalReceiverName', OnAppMessageReceived);
_ms := TMemoryStream.Create;
try
_AppCommunication.SetRemoteReceiverName('LocalReceiverNameServer');
_AppCommunication.SendString('ąčęėįšųūž123');
_AppCommunication.SendInteger(998);
_AppCommunication.SendDouble(0.95);
_Rec.Name := 'Edijs';
_Rec.Age := 29;
_Rec.Birthday := EncodeDate(1988, 10, 06);
_Record.Len := 1988;
_AppCommunication.SendRecord(TTypeInfo(System.TypeInfo(TMyRec)^).Name, #_Rec, SizeOf(_Rec));
finally
FreeAndNil(_ms);
FreeAndNil(_AppCommunication);
end;
end;
Receiver app:
procedure TReceiverMainForm.OnAppMessageReceived(const ASender
: TPair<HWND, string>; const AReceivedData: TCopyDataStruct;
var AResult: integer);
var
_MyRec: TMyRec;
_RecType: ShortString;
_RecData: Pointer;
begin
...
else
begin
if (AReceivedData.dwData) = Ord(TCopyDataType.cdtRecord) then
begin
_RecType := PShortString(AReceivedData.lpData)^;
_RecData := PByte(AReceivedData.lpData)+1+Length(_RecType);
if (_RecType = TTypeInfo(System.TypeInfo(TMyRec)^).Name) then
begin
_MyRec := TMyRec(_RecData^);
ShowMessage(_MyRec.Name + ', Age: ' + IntToStr(_MyRec.Age) + ', birthday: ' +
DateToStr(_MyRec.Birthday));
end;
end;
AResult := -1;
end;
end;
The problem is that crash occur when I change Name: string[255]; to Name: string; in TMyRec. How do I overcome this? I do not want to edit all my records to change string to something else and I want to have one function to send all kind of records (as far as my idea goes none of them will contain objects).
EDITED:
Used answer provided by Remy and made some tweaks so I would by able to send any kind of record using only one SendRecord function:
function TAppCommunication.SendRecord(const ARecordToSend, ARecordTypInfo: Pointer): Boolean;
var
_Stream: TMemoryStream;
_RType: TRTTIType;
_RFields: TArray<TRttiField>;
i: Integer;
begin
_Stream := TMemoryStream.Create;
try
_RType := TRTTIContext.Create.GetType(ARecordTypInfo);
_Stream.WriteString(_RType.ToString);
_RFields := _RType.GetFields;
for i := 0 to High(_RFields) do
begin
if _RFields[i].FieldType.TypeKind = TTypeKind.tkUString then
_Stream.WriteString(_RFields[i].GetValue(ARecordToSend).ToString)
else if _RFields[i].FieldType.TypeKind = TTypeKind.tkInteger then
_Stream.WriteInteger(_RFields[i].GetValue(ARecordToSend).AsType<integer>)
else if _RFields[i].FieldType.TypeKind = TTypeKind.tkFloat then
_Stream.WriteDouble(_RFields[i].GetValue(ARecordToSend).AsType<Double>)
end;
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
Sender:
_AppCommunication.SendRecord(#_Rec, System.TypeInfo(TMyRec));
A ShortString has a fixed size of 256 bytes max (1 byte length + up to 255 AnsiChars), so it is easy to embed in records and send as-is.
A String, on the other hand, is a pointer to dynamically allocated memory for an array of Chars. So, it requires a little more work to serialize back and forth.
To do what you are asking, you can't simply replace ShortString with String without also changing everything else in between to account for that difference.
You already have the basic framework to send variable-length strings (send the length before sending the data), so you can expand on that to handle string values, eg:
type
TMyRec = record
Name: string;
Age: integer;
Birthday: TDateTime;
end;
TStreamHelper = class helper for TStream
public
function ReadInteger: Integer;
function ReadDouble: Double;
function ReadString: String;
...
procedure WriteInteger(Value: Integer);
procedure WriteDouble(Strm: Value: Double);
procedure WriteString(const Value: String);
end;
function TStreamHelper.ReadInteger: Integer;
begin
Self.ReadBuffer(Result, SizeOf(Integer));
end;
function TStreamHelper.ReadDouble: Double;
begin
Self.ReadBuffer(Result, SizeOf(Double));
end;
function TStreamHelper.ReadString: String;
var
_Bytes: TBytes;
_Len: Integer;
begin
_Len := ReadInteger;
SetLength(_Bytes, _Len);
Self.ReadBuffer(PByte(_Bytes)^, _Len);
Result := TEncoding.UTF8.GetString(_Bytes);
end;
...
procedure TStreamHelper.WriteInteger(Value: Integer);
begin
Self.WriteBuffer(Value, SizeOf(Value));
end;
procedure TStreamHelper.WriteDouble(Value: Double);
begin
Self.WriteBuffer(Value, SizeOf(Value));
end;
procedure TStreamHelper.WriteString(const Value: String);
var
_Bytes: TBytes;
_Len: Integer;
begin
_Bytes := TEncoding.UTF8.GetBytes(Value);
_Len := Length(_Bytes);
WriteInteger(_Len);
Self.WriteBuffer(PByte(_Bytes)^, _Len);
end;
function TAppCommunication.SendRecord(const ARecord: TMyRec): Boolean;
var
_Stream: TMemoryStream;
begin
_Stream := TMemoryStream.Create;
try
_Stream.WriteString('TMyRec');
_Stream.WriteString(ARecord.Name);
_Stream.WriteInteger(ARecord.Age);
_Stream.WriteDouble(ARecord.Birthday);
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
// more overloads of SendRecord()
// for other kinds of records as needed...
procedure TSenderMainForm.BitBtn1Click(Sender: TObject);
var
...
_Rec: TMyRec;
begin
...
_Rec.Name := 'Edijs';
_Rec.Age := 29;
_Rec.Birthday := EncodeDate(1988, 10, 06);
_AppCommunication.SendRecord(_Rec);
...
end;
type
TReadOnlyMemoryStream = class(TCustomMemoryStream)
public
constructor Create(APtr: Pointer; ASize: NativeInt);
function Write(const Buffer; Count: Longint): Longint; override;
end;
constructor TReadOnlyMemoryStream.Create(APtr: Pointer; ASize: NativeInt);
begin
inherited Create;
SetPointer(APtr, ASize);
end;
function TReadOnlyMemoryStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := 0;
end;
procedure TReceiverMainForm.OnAppMessageReceived(const ASender : TPair<HWND, string>; const AReceivedData: TCopyDataStruct; var AResult: integer);
var
...
_Stream: TReadOnlyMemoryStream;
_MyRec: TMyRec;
_RecType: String;
begin
...
else
begin
if (AReceivedData.dwData = Ord(TCopyDataType.cdtRecord)) then
begin
_Stream := TReadOnlyMemoryStream(AReceivedData.lpData, AReceivedData.cbData);
try
_RecType := _Stream.ReadString;
if (_RecType = 'TMyRec') then
begin
_MyRec.Name := _Stream.ReadString;
_MyRec.Age := _Stream.ReadInteger;
_MyRec.Birthday := _Stream.ReadDouble;
ShowMessage(_MyRec.Name + ', Age: ' + IntToStr(_MyRec.Age) + ', birthday: ' + DateToStr(_MyRec.Birthday));
end;
finally
_Stream.Free;
end;
end;
AResult := -1;
end;
end;

TThread checksynchronize issue with dll

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;

Delphi - Message pump in thread not receiving WM_COPYDATA messages

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.

Resources