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 am new to Threads, i have a List contains a strings. My goal is to make multiple threads do work to this List, this codes only for a single thread because i'm learning currently, however i get AV when i press start Button.
type
TDemoThread = class(TThread)
private
procedure Abort;
protected
procedure Execute; override;
public
List: TStringList;
end;
procedure TfrmMain.StartButton1Click(Sender: TObject);
var
i: integer;
List: Tstrings;
begin
for i := 0 to memo1.Lines.Count - 1 do
begin
List := TStringList.Create;
List.Add(memo1.Lines.Strings[i]);
end;
Thread := TDemoThread.Create(True);
Thread.FreeOnTerminate := True;
Thread.Start;
end;
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
i: integer;
X: Tstrings;
begin
inherited;
if Terminated then
Exit;
lHTTP := TIdHTTP.Create(nil);
X := TStringList.Create;
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
for i := 0 to List.Count - 1 do
try
X.Text := lHTTP.Get('https://instagram.com/' + List.Strings[i]);
S := ExtractDelimitedString(X.Text);
X.Clear;
TThread.Synchronize(nil,
procedure
begin
frmMain.Memo2.Lines.Add(List.Strings[i] + ' : ' + S);
end);
finally
end;
end;
Your problem is that you never assign to the List member of the thread class:
type
TDemoThread = class(TThread)
private
procedure Abort;
protected
procedure Execute; override;
public
List: TStringList; <-- never assigned to, hence always nil
end;
Hence the access violation.
It looks like you are trying to pass the contents of memo1 to the thread. I would do that like so:
type
TDemoThread = class(TThread)
private
FData: TStringList;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
end;
constructor TDemoThread.Create(Data: TStrings);
begin
inherited Create(False);
FData := TStringList.Create;
FData.Assign(Data);
FreeOnTerminate := True;
end;
destructor TDemoThread.Destroy;
begin
FData.Free;
inherited;
end;
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
i: integer;
X: TStrings;
begin
inherited;
if Terminated then
Exit;
lHTTP := TIdHTTP.Create(nil);
X := TStringList.Create;
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
for i := 0 to FData.Count - 1 do
try
X.Text := lHTTP.Get('https://instagram.com/' + FData[i]);
S := ExtractDelimitedString(X.Text);
X.Clear;
TThread.Synchronize(nil,
procedure
begin
frmMain.Memo2.Lines.Add(FData[i] + ' : ' + S);
end);
finally
end;
end;
procedure TfrmMain.StartButton1Click(Sender: TObject);
begin
TDemoThread.Create(memo1.Lines);
end;
It is pointless to create suspended and then immediately start. It is also not permitted to hold a reference to a FreeOnTerminate thread after it has started so I removed that.
The code in TDemoThread.Execute leaks, unless you are running exclusively on an ARC platform. And the try/finally is pointless. And you don't need a string list to hold a single string. Assuming you aren't using ARC it should be:
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
i: integer;
S: string;
begin
if Terminated then
Exit;
lHTTP := TIdHTTP.Create(nil);
try
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
for i := 0 to FData.Count - 1 do
begin
S := ExtractDelimitedString(lHTTP.Get('https://instagram.com/' + FData[i]));
TThread.Synchronize(nil,
procedure
begin
frmMain.Memo2.Lines.Add(FData[i] + ' : ' + S);
end);
end;
finally
lHTTP.Free;
end;
end;
Personally I'd avoid updating the form from the threads themselves. Threads are data generators here, not GUI managers. So let them separate their concerns.
I'd make all the threads accumulate the results into the same shared container and then make a GUI thread to poll that container instead. Human eyes are slow and Windows GUI is slow too, so you should not update your GUI more often than 2 or 3 times per second. It would only waste CPU load and blur the form into being unreadable.
Another thing would be to avoid using slow TStringList unless its extra functionality (which makes it slow) is required. The regular TList<string> is more than enough as a dumb container and is faster.
type
TDemoThread = class;
TfrmMain = class(TForm)
private
Fetchers: TThreadList<TDemoThread>;
Data: TThreadList<string>;
property inProcess: Boolean read ... write SetInProcess;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
....
end;
// this demo makes each thread per each line - that is actually a bad design
// one better use a thread pool working over the same queue and only have
// 20-40 worker threads for all the URLs
TDemoThread = class(TThread)
private
URL: string;
List: TThreadList<string>;
Tracker: TThreadList<TDemoThread>;
protected
procedure Execute; override;
end;
procedure TfrmMain.BeforeDestruction;
begin
while TThreadList.Count > 0 do
Sleep(100);
FreeAndNil( Fetchers );
Data.Free;
inherited;
end;
procedure TfrmMain.AfterConstruction;
begin
Fetchers := TThreadList<TDemoThread>.Create;
Data := TThreadList<string>.Create;
inherited;
end;
procedure TfrmMain.StartButton1Click(Sender: TObject);
var
i: integer;
List: Tstrings;
worker: TDemoThread;
URL: string;
begin
If inProcess then exit;
for URL in memo1.Lines do begin
worker := TDemoThread.Create(True);
worker.FreeOnTerminate := True;
worker.URL := URL;
worker.List := Data;
worker.Tracker := Fetchers;
Fetchers.Add( worker );
end;
InProcess := True;
for worker in Fetchers do
worker.Start;
end;
procedure TfrmMain.SetInProcess(const Value: Boolean);
begin
if Value = InProcess then exit; // form already is in this mode
FInProcess := Value;
memo1.ReadOnly := Value;
StartButton.Enabled := not Value;
if Value then begin
Memo2.Lines.Clear;
Data.Clear;
end;
Timer1.Delay := 500; // twice per second
Timer1.Enabled := Value;
If not Value then // for future optimisation - make immediate mode change
FlushData; // when last worker thread quits, no waiting for timer event
If not Value then
ShowMessage('Work complete');
end;
procedure TfrmMain.Timer1Timer(const Sender: TObject);
begin
FlushData;
if Fetchers.Count <= 0 then
InProcess := False;
end;
procedure TfrmMain.FlushData;
begin
Data.LockList; // next two operations should go as non-interruptible atom
try
Memo2.Lines.AddStrings( Data.ToArray() );
Data.Clear;
finally
Data.UnLockList;
end;
end;
procedure TDemoThread.Execute;
var
lHTTP: TIdHTTP;
begin
try
lHTTP := TIdHTTP.Create(nil);
try
lHTTP.ReadTimeout := 30000;
lHTTP.HandleRedirects := True;
S := ExtractDelimitedString( lHTTP.Get('https://instagram.com/' + URL) );
List.Add( S );
finally
lHTTP.Destroy;
end;
finally
Tracker.Remove( Self );
end;
end;
http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TThreadList
http://docwiki.embarcadero.com/Libraries/Seattle/en/System.Classes.TStrings.AddStrings
PS. Personally, I'd also use OmniThreads Library, as it generally makes maintaining data-generating threads easier. For example just managing how many threads did you created becomes setting one property and determining when all threads complete their work is another oneliner. You really should not create a thousand of threads to fetch all the URLs, instead you should have 10-20 threads in a Thread Pool that would take the URLs from a Input Queue and fetch them one after another. I suggest you reading about OTL's Parallel For and Fork-Join patterns at http://otl.17slon.com/tutorials.htm - it would allow making such an application more concise and easier to write. Pipeline pattern would probably be even better match for this task - since you anyway prepare URLs list as a source collection. Half the scaffolding in StartButtonClick would be gone, and the whole TDemoThread class too.
UPDATE Problem Still Exists.
Is it possible to run code in already running thread? for example:
thread1 is running some code & i want to run code from thread2 in thread1.
I want to run code in idTCPServer thread to send some data to client
Edit:
After research seems that my problem is that when Client data is received or is receiving same time another thread is trying to write to that socket.
Edit:
procedure TMainFrm.UserSRVExecute(AContext: TIdContext);
var
Command : String;
msSize : Int64;
ms : TMemoryStream;
decompressedMS : TMemoryStream;
H : TIdNotify;
begin
// Application.ProcessMessages;
Command := AContext.Connection.Socket.ReadLn;
// messagebox(0,'snd','',$40);
if logb then mainfrm.mconnections.Lines.Add(command + ' - BEGIN');
if Command <> '' then // keepalive
begin
//Application.ProcessMessages;
msSize := AContext.Connection.Socket.ReadInt64;
ms := TMemoryStream.Create;
decompressedMS := TMemoryStream.Create;
try
AContext.Connection.Socket.ReadStream(ms, msSize);
ms.Position := 0;
DecompressStream(MS,decompressedMS);
decompressedMS.Position := 0;
Client_ProcessData(AContext,Command,decompressedMS);
finally
ms.Free;
decompressedMS.Free;
if logb then mainfrm.mconnections.Lines.Add(command + ' - END');
end;
end;
end;
procedure Client_ProcessData(AContext: TIdContext; cmd : String; data : TMemoryStream);
var
Hnd : THandle;
clData : TStringArray;
TmpStr1 : String;
Tmp : String;
TN : TIdNotify;
Sync : TMySync;
I,I2 : Integer;
begin
Hnd := AContext.Connection.Socket.Binding.Handle;
if cmd = 'scr' then // RECEIVE COMMAND TO SEND TO CLIENT TO RECEIVE DATA FROM CLIENT
begin
Tmp := StreamToString(data);
{Sync := TMySync2.Create(True);
try
Sync.cmd := cmd;
Sync.hnd := Hnd;
Sync.tmp := TmpStr1;
Sync.Resume;
finally
//Sync.Free;
end; }
log('>>> CLFROMAS: '+IntToStr(HND)+':::'+cmd+':::');
// SendCMDToSocket(MainFrm.UserSRV,StrToInt(Trim(Tmp)),'scr'+IntToStr(Hnd));
I2 := StrToInt(Trim(Tmp));
for I := 0 to 100 do
if USRVData[i].hnd = I2 then
begin
// cs.Acquire;
USRVData[i].CTX.Connection.Socket.WriteLn('scr'+IntToStr(Hnd)); // PLACED ALL CONTEXTs IN GLOBAL VARIABLE + ALL SOCKET HANDLES. <--- HERE IS THE PROBLEM
// cs.Release;
Break;
end;
// log('>>> CLFROMAS: '+IntToStr(HND)+':::'+cmd+':::'+streamtostring(data));
Exit;
end;
if Copy(cmd,1,Length('scr4u')) = 'scr4u' then // RECEIVE DATA FROM CLIENT TO SEND IT TO ADMIN CLIENT REQUEST ABOVE
begin
if Length(cmd) > Length('scr4u') then
begin
Delete(cmd,1,Length('scr4u'));
Data.Position := 0;
{ Sync := TMySync.Create;
try
Sync.cmd := cmd;
Sync.hnd := Hnd;
Sync.data := TMemoryStream.Create;
Sync.data.CopyFrom(data,data.Size);
Sync.data.Position := 0;
Sync.DoNotify;
finally
Sync.data.Free;
Sync.Free;
end; }
SendStreamToSocket(MainFrm.UserSRV,strtoint(cmd),'scr4u',Data);
log('>>>>> ADMIN: '+IntToStr(HND)+':::'+cmd+':::'{+streamtostring(data)});
end else TmpStr1 := '';
Exit;
end;
...
UPDATE
procedure TMainFrm.UserSRVExecute(AContext: TIdContext);
var
Command : String;
msSize : Int64;
ms : TMemoryStream;
decompressedMS : TMemoryStream;
H : TIdNotify;
I : Integer;
List, Messages : TStringList;
begin
Messages := nil;
try
List := TMyContext(AContext).OutgoingMessages.Lock;
try
if List.Count > 0 then
begin
Messages := TStringList.Create;
Messages.Assign(List);
List.Clear;
end;
finally
TMyContext(AContext).OutgoingMessages.Unlock;
end;
if Messages <> nil then
begin
for I := 0 to Messages.Count-1 do
begin
AContext.Connection.IOHandler.WriteLn(Messages.Strings[I]);
end;
end;
finally
Messages.Free;
end;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
Exit;
end;
Command := AContext.Connection.Socket.ReadLn;
if logb then mainfrm.mconnections.Lines.Add(command + ' - BEGIN');
if Command <> '' then
begin
msSize := AContext.Connection.Socket.ReadInt64;
ms := TMemoryStream.Create;
decompressedMS := TMemoryStream.Create;
try
AContext.Connection.Socket.ReadStream(ms, msSize);
ms.Position := 0;
DecompressStream(MS,decompressedMS);
decompressedMS.Position := 0;
Client_ProcessData(AContext,Command,decompressedMS);
finally
ms.Free;
decompressedMS.Free;
if logb then mainfrm.mconnections.Lines.Add(command + ' - END');
end;
end;
end;
Is it possible to run code in already running thread? for example: thread1 is running some code & i want to run code from thread2 in thread1.
No. Thread1 needs to be explicitly coded to stop what it is currently doing, do something else, and then go back to what it was previous doing. All Thread2 can do is signal Thread1 to perform that stop+continue at its earliest convenience.
I want to run code in idTCPServer thread to send some data to client
Your TIdTCPServer.OnExecute event handler needs to check for that data periodically and send it when it is available.
You can use the TIdContext.Data property, or derive a custom class from TIdServerContext and assign it to the TIdTCPServer.ContextClass property, to provide a per-client thread-safe buffer for your outbound data. Your OnExecute handler can then access that buffer when needed.
For example:
type
TMyContext = class(TIdServerContext)
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
OutgoingMessages: TIdThreadSafeStringList;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
OutgoingMessages := TIdThreadSafeStringList.Create;
end;
destructor TMyContext.Destroy;
begin
OutgoingMessages.Free;
inherited;
end;
procedure TMyForm.FormCreate(Sender: TObject);
begin
// this must be set before activating the server...
IdTCPServer1.ContextClass := TMyContext;
end;
procedure TMyForm.IdTCPServer1Execute(AContext: TIdContext);
var
List, Messages: TStringList;
begin
// check for outgoing data...
Messages := nil;
try
List := TMyContext(AContext).OutgoingMessages.LockList;
try
if List.Count > 0 then
begin
Messages := TStringList.Create;
Messages.Assign(List);
List.Clear;
end;
finally
TMyContext(AContext).OutgoingMessages.UnlockList;
end;
if Messages <> nil then
begin
// send Messages using AContext.Connection.IOHandler as needed...
end;
finally
Messages.Free;
end;
// check for incoming data...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
Exit;
end;
// process incoming data as needed...
end;
procedure TForm1.SomeProcedure;
var
List: TIdContextList;
Context: TMyContext;
begin
List := IdTCPServer1.Contexts.LockList;
try
Context := TMyContext(List[SomeIndex]);
Context.OutgoingMessages.Add('something');
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
So, I've always faced MAJOR headaches when threading in delphi xe4-6, whether it be from threads not executing, exception handling causes app crashes, or simply the on terminate method never getting called. All the workarounds I've been instructed to use have become very tedious with issues still haunting me in XE6. My code generally has looked something like this:
procedure TmLoginForm.LoginClick(Sender: TObject);
var
l:TLoginThread;
begin
SyncTimer.Enabled:=true;
l:=TLoginThread.Create(true);
l.username:=UsernameEdit.Text;
l.password:=PasswordEdit.Text;
l.FreeOnTerminate:=true;
l.Start;
end;
procedure TLoginThread.Execute;
var
Success : Boolean;
Error : String;
begin
inherited;
Success := True;
if login(USERNAME,PASSWORD) then
begin
// do another network call maybe to get dif data.
end else
begin
Success := False;
Error := 'Login Failed. Check User/Pass combo.';
end;
Synchronize(
procedure
if success = true then
begin
DifferentForm.Show;
end else
begin
ShowMessage('Error: '+SLineBreak+Error);
end;
SyncTimer.Enabled := False;
end);
end;
And then I came across this unit from the samples in Delphi and from the forums:
unit AnonThread;
interface
uses
System.Classes, System.SysUtils, System.Generics.Collections;
type
EAnonymousThreadException = class(Exception);
TAnonymousThread<T> = class(TThread)
private
class var
CRunningThreads:TList<TThread>;
private
FThreadFunc: TFunc<T>;
FOnErrorProc: TProc<Exception>;
FOnFinishedProc: TProc<T>;
FResult: T;
FStartSuspended: Boolean;
private
procedure ThreadTerminate(Sender: TObject);
protected
procedure Execute; override;
public
constructor Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False;
AFreeOnTerminate: Boolean = True);
class constructor Create;
class destructor Destroy;
end;
implementation
{$IFDEF MACOS}
uses
{$IFDEF IOS}
iOSapi.Foundation
{$ELSE}
MacApi.Foundation
{$ENDIF IOS}
;
{$ENDIF MACOS}
{ TAnonymousThread }
class constructor TAnonymousThread<T>.Create;
begin
inherited;
CRunningThreads := TList<TThread>.Create;
end;
class destructor TAnonymousThread<T>.Destroy;
begin
CRunningThreads.Free;
inherited;
end;
constructor TAnonymousThread<T>.Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False; AFreeOnTerminate: Boolean = True);
begin
FOnFinishedProc := AOnFinishedProc;
FOnErrorProc := AOnErrorProc;
FThreadFunc := AThreadFunc;
OnTerminate := ThreadTerminate;
FreeOnTerminate := AFreeOnTerminate;
FStartSuspended := ACreateSuspended;
//Store a reference to this thread instance so it will play nicely in an ARC
//environment. Failure to do so can result in the TThread.Execute method
//not executing. See http://qc.embarcadero.com/wc/qcmain.aspx?d=113580
CRunningThreads.Add(Self);
inherited Create(ACreateSuspended);
end;
procedure TAnonymousThread<T>.Execute;
{$IFDEF MACOS}
var
lPool: NSAutoreleasePool;
{$ENDIF}
begin
{$IFDEF MACOS}
//Need to create an autorelease pool, otherwise any autorelease objects
//may leak.
//See https://developer.apple.com/library/ios/#documentation/Cocoa/Conceptual/MemoryMgmt/Articles/mmAutoreleasePools.html#//apple_ref/doc/uid/20000047-CJBFBEDI
lPool := TNSAutoreleasePool.Create;
try
{$ENDIF}
FResult := FThreadFunc;
{$IFDEF MACOS}
finally
lPool.drain;
end;
{$ENDIF}
end;
procedure TAnonymousThread<T>.ThreadTerminate(Sender: TObject);
var
lException: Exception;
begin
try
if Assigned(FatalException) and Assigned(FOnErrorProc) then
begin
if FatalException is Exception then
lException := Exception(FatalException)
else
lException := EAnonymousThreadException.Create(FatalException.ClassName);
FOnErrorProc(lException)
end
else if Assigned(FOnFinishedProc) then
FOnFinishedProc(FResult);
finally
CRunningThreads.Remove(Self);
end;
end;
end.
Why is that this anon thread unit above works flawlessly 100% of the time and my code crashes sometimes? For example, I can exec the same thread 6 times in a row, but then maybe on the 7th (or the first for that matter) time it causes the app to crash. No exceptions ever come up when debugging so I dont have a clue where to start fixing the issue. Also, why is it that I need a separate timer that calls "CheckSynchronize" for my code in order to GUI updates to happen but it is not needed when I use the anon thread unit?
Maybe someone can point me in the right direction to ask this question elsewhere if here is not the place. Sorry, I'm diving into documentation already, trying my best to understand.
Here is an example of a thread that may work 20 times in a row, but then randomly cause app to crash
inherited;
try
SQL:= 'Some SQL string';
if GetSQL(SQL,XMLData) then
synchronize(
procedure
var
i:Integer;
begin
try
mTasksForm.TasksListView.BeginUpdate;
if mTasksForm.TasksListView.Items.Count>0 then
mTasksForm.TasksListView.Items.Clear;
XMLDocument := TXMLDocument.Create(nil);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
XMLDocument.LoadFromXML(XMLData);
XMLNode:=XMLDocument.DocumentElement.ChildNodes['Record'];
i:=0;
if XMLNode.ChildNodes['ID'].Text <>'' then
while XMLNode <> nil do
begin
LItem := mTasksForm.TasksListView.Items.AddItem;
with LItem do
begin
Text := XMLNode.ChildNodes['LOCATION'].Text;
Detail := XMLNode.ChildNodes['DESC'].Text +
SLineBreak+
'Assigned To: '+XMLNode.ChildNodes['NAME'].Text
tag := StrToInt(XMLNode.ChildNodes['ID'].Text);
color := TRectangle.Create(nil);
with color do
begin
if XMLNode.ChildNodes['STATUS'].Text = STATUS_DONE then
fill.Color := TAlphaColors.Lime
else if XMLNode.ChildNodes['STATUS'].Text = STATUS_OK then
fill.Color := TAlphaColors.Yellow
else
fill.Color := TAlphaColors.Crimson;
stroke.Color := fill.Color;
ButtonText := XMLNode.ChildNodes['STATUS'].Text;
end;
Bitmap := Color.MakeScreenshot;
end;
XMLNode:=XMLNode.NextSibling;
end;
finally
mTasksForm.TasksListView.EndUpdate;
for i := 0 to mTasksForm.TasksListView.Controls.Count-1 do
begin
if mTasksForm.TasksListView.Controls[I].ClassType = TSearchBox then
begin
SearchBox := TSearchBox(mTasksForm.TasksListView.Controls[I]);
Break;
end;
end;
SearchBox.Text:=' ';
SearchBox.text := ''; //have in here because if the searchbox has text, when attempting to add items then app crashes
end;
end)
else
error := 'Please check internet connection.';
finally
synchronize(
procedure
begin
if error <> '' then
ShowMessage('Erorr: '+error);
mTasksForm.Spinner.Visible:=false;
mTasksForm.SyncTimer.Enabled:=false;
end);
end;
end;
here is the GETSQL method
function GetSQL(SQL:String;var XMLData:String):Boolean;
var
PostResult,
ReturnCode : String;
PostData : TStringList;
IdHTTP : TIdHTTP;
XMLDocument : IXMLDocument;
XMLNode : IXMLNode;
Test : String;
begin
Result:=False;
XMLData:='';
XMLDocument:=TXMLDocument.Create(nil);
IdHTTP:=TIdHTTP.Create(nil);
PostData:=TStringList.Create;
PostData.Add('session='+SessionID);
PostData.Add('database='+Encode(DATABASE,''));
PostData.Add('sql='+Encode(SQL,''));
IdHTTP.Request.ContentEncoding:='UTF-8';
IdHTTP.Request.ContentType:='application/x-www-form-urlencoded';
IdHTTP.ConnectTimeout:=100000;
IdHTTP.ReadTimeout:=1000000;
try
PostResult:=IdHTTP.Post(SERVER_URL+GET_METHOD,PostData);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
test := Decode(PostResult,'');
XMLDocument.LoadFromXML(Decode(PostResult,''));
XMLNode:=XMLDocument.DocumentElement;
try
ReturnCode:=XMLNode.ChildNodes['status'].Text;
except
ReturnCode:='200';
end;
if ReturnCode='' then begin
ReturnCode:='200';
end;
if ReturnCode='200' then begin
Result:=True;
XMLData:=Decode(PostResult,'');
end;
except
on E: Exception do begin
result:=false;
end;
end;
PostData.Free;
IdHTTP.Free;
end;
When i used this code with button, it is ok... All sockets connected success. All events working. no problem (OnSessionClosed, OnSessionConnected, ...)
procedure TfrmMain.btnConnectClick(Sender: TObject);
var
I: Integer;
begin
for I := 0 to query.RecordCount - 1 do
begin
pUser[I] := TUser.Create();
pUser[I].Connect(frmMain.editEbenezerIP.Text);
pUser[I].run := False;
pUser[I].username := Trim(query.FieldByName('strAccountID').Text);
pUser[I].password := Trim(query.FieldByName('strPasswd').Text);
pUser[I].md5 := editMD5.Text;
pUser[I].Resume;
query.Next;
end;
end;
i created a thread to connect with sleep. (my thread TConnector).
All thread connected but OnSessionConnected event not working when i created with TConnector.
No problem with button to use create sockets.
procedure TUser.OnSessionConnected(Sender: TObject; ErrCode: Word);
begin
ShowMessage('Connection success!');
end;
procedure TUser.Connect(eip : string);
begin
Initialize;
socket := TWSocket.Create(nil);
socket.OnDataAvailable := OnDataAvailable;
socket.OnSessionConnected := OnSessionConnected;
socket.OnSessionClosed := OnSessionClosed;
socket.Connect;
end;
procedure TConnector.Execute;
var
I : Integer;
pUser : array [0..1500] of TUser;
begin
for I := 0 to frmMain.query.RecordCount - 1 do
begin
pUser[I] := TUser.Create();
pUser[I].run := False;
pUser[I].username := Trim(frmMain.query.FieldByName('strAccountID').Text);
pUser[I].password := Trim(frmMain.query.FieldByName('strPasswd').Text);
pUser[I].Connect(frmMain.editEbenezerIP.Text);
pUser[I].Resume;
frmMain.query.Next;
**Sleep(100);**
end;
end;
I fixed this problem with Synchronize(CreateUser);. Thanks for your answers
TConnector = class(TThread)
private
protected
procedure Execute; override;
public
strAccountID, strPasswd, MD5, eIP : string;
X : Integer;
constructor Create;
procedure CreateUser;
end;
procedure TConnector.CreateUser;
begin
Output(Format('Thread for %s',[strAccountID]));
frmMain.pUser[X] := TUser.Create();
frmMain.pUser[X].run := False;
frmMain.pUser[X].username := strAccountID;
frmMain.pUser[X].password := strPasswd;
frmMain.pUser[X].md5 := MD5;
frmMain.pUser[X].Connect(eIP, frmMain);
frmMain.pUser[X].Resume;
end;
procedure TConnector.Execute;
var
I : Integer;
begin
MD5 := frmMain.editMD5.Text;
eIP := frmMain.editEbenezerIP.Text;
for I := 0 to frmMain.query.RecordCount - 1 do
begin
X := I;
strAccountID := Trim(frmMain.query.FieldByName('strAccountID').Text);
strPasswd := Trim(frmMain.query.FieldByName('strPasswd').Text);
**Synchronize(CreateUser);**
Sleep(1000);
frmMain.query.Next;
end;
while(not Terminated)do
begin
Sleep(1000);
OutPut('test');
end;
end;
TWSocket uses a non-blocking socket and a hidden window for handling socket state updates asynchronously. As such, you need to give your thread a message loop. It works in a TButton.OnClick event because it is utilizing the main thread's existing message loop.
Edit: The simplest message loop involves calling Peek/GetMessage(), TranslateMessage(), and DispatchMessage() in a loop for the lifetime of the thread, so you need to add those function calls to your worker thread, eg:
procedure TConnector.Execute;
var
I : Integer;
pUser : array [0..1500] of TUser;
Msg: TMsg
begin
for I := 0 to frmMain.query.RecordCount - 1 do
begin
if Terminated then Break;
pUser[I] := TUser.Create();
pUser[I].run := False;
pUser[I].username := Trim(frmMain.query.FieldByName('strAccountID').Text);
pUser[I].password := Trim(frmMain.query.FieldByName('strPasswd').Text);
pUser[I].Connect(frmMain.editEbenezerIP.Text);
pUser[I].Resume;
frmMain.query.Next;
end;
while (GetMessage(Msg, 0, 0, 0) > 0) and (not Terminated) then
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
// perform cleanup here as needed...
end;
procedure TConnector.Stop;
begin
Terminate;
PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
end;