EOutOfResources exception when trying to restore tray icon - delphi-xe

I'm getting an EOutOfResources exception 'Cannot remove shell notification icon' when trying to implement code to restore the tray icon after an Explorer crash/restart. My code is based on the old solution found here. The exception occurs when trying to hide the trayicon. Why does the Delphi XE code below not work?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ExtCtrls;
type
TForm1 = class(TForm)
TrayIcon1: TTrayIcon;
ImageListTray: TImageList;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
protected
procedure WndProc(var Message: TMessage); Override;
public
{ Public declarations }
end;
var
Form1: TForm1;
msgTaskbarRestart : Cardinal; {custom systemwide message}
implementation
{$R *.dfm}
//ensure systray icon recreated on explorer crash
procedure TForm1.FormCreate(Sender: TObject);
begin
msgTaskbarRestart := RegisterWindowMessage('TaskbarCreated');
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if (msgTaskbarRestart <> 0) and (Message.Msg = msgTaskbarRestart) then begin
TrayIcon1.Visible := False; {Destroy the systray icon here}//EOutOfResources exception here
TrayIcon1.Visible := True; {Replace the systray icon}
Message.Result := 1;
end;
inherited WndProc(Message);
end;
end.

The TTrayIcon.Visible property setter raises EOutOfResources when a NIM_DELETE request fails:
procedure TCustomTrayIcon.SetVisible(Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
...
if not (csDesigning in ComponentState) then
begin
if FVisible then
...
else if not (csLoading in ComponentState) then
begin
if not Refresh(NIM_DELETE) then
raise EOutOfResources.Create(STrayIconRemoveError); // <-- HERE
end;
...
end;
end;
end;
Where Refresh() is just a call to the Win32 Shell_NotifyIcon() function:
function TCustomTrayIcon.Refresh(Message: Integer): Boolean;
...
begin
Result := Shell_NotifyIcon(Message, FData);
...
end;
When you receive the TaskbarCreated message, your previous icons are no longer present in the Taskbar, so Shell_NotifyIcon(NIM_DELETE) returns False. When the Taskbar is (re-)created, you are not supposed to try to remove old icons at all, only re-add new icons with Shell_NotifyIcon(NIM_ADD) as needed.
TTrayIcon has a public Refresh() method, but that uses NIM_MODIFY instead of NIM_ADD, so that will not work in this situation, either:
procedure TCustomTrayIcon.Refresh;
begin
if not (csDesigning in ComponentState) then
begin
...
if Visible then
Refresh(NIM_MODIFY);
end;
end;
However, you don't actually need to handle the TaskbarCreated message manually when using TTrayIcon, because it already handles that message internally for you, and it will call Shell_NotifyIcon(NIM_ADD) if Visible=True:
procedure TCustomTrayIcon.WindowProc(var Message: TMessage);
...
begin
case Message.Msg of
...
else
if (Cardinal(Message.Msg) = RM_TaskBarCreated) and Visible then
Refresh(NIM_ADD); // <-- HERE
end;
end;
...
initialization
...
TCustomTrayIcon.RM_TaskBarCreated := RegisterWindowMessage('TaskbarCreated');
end.
If, for some reason, that is not working correctly, and/or you need to handle TaskbarCreated manually, then I would suggest calling the protected TCustomTrayIcon.Refresh() method directly, eg:
type
TTrayIconAccess = class(TTrayIcon)
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if (msgTaskbarRestart <> 0) and (Message.Msg = msgTaskbarRestart) then begin
if TrayIcon1.Visible then begin
// TrayIcon1.Refresh;
TTrayIconAccess(TrayIcon1).Refresh(NIM_ADD);
end;
Message.Result := 1;
end;
inherited WndProc(Message);
end;
Otherwise, simply don't use TTrayIcon at all. It is known to be buggy. I have seen a lot of people have a lot of problems with TTrayIcon over the years. I would suggest using Shell_NotifyIcon() directly instead. I have never had any problems using it myself.

Related

Free Pascal / Lazarus : Why is the "FormCloseQuery" Event not called in my example?

I wrote a small testprogram to try out the FormCreate and the FormCloseQuery procedure. The FormCreate works fine, but the FormCloseQuery just doesn't want to execute. Did I overlook something? Pressing the "X" on a form-window or using the close method, both doesn't work!
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
(...)
procedure TForm1.FormCreate(Sender: TObject);
beginn
//gets executed without problems
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
Here's the full code:
The lpr-File:
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
The Unit-File:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowMessage('FormCreate Procedure wurde gestartet');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
end.
The solution is/was to hook up the form's OnCloseQuery event of the form to this procedure. Here's a short description how to do it:
Bring up and select the form (in my case "Form1: TForm1") in the object inspector (see explanation below).
In the object inspector go to the tab "events"
Locate the "OnCloseQuery"-Event and select "FormCloseQuery" if you already declared and written the procedure as it was the case in my example. (If you haven't declared/implemented it double click in the dropdown box or click on the button next to it, the one with the three dots, an an empty "OnCloseQuery"-procedure procedure will be added automatically. The code editor will jump directly to the new procedure.)
To bring up / select the form in the object inspector, open the object inspector (F11). If you are looking at the code editor bring up the form first (F12) and click on it. This should bring it up in the object inspector. Make sure the form (the top element in the list) is selected and none of it's components (like buttons etc.).
Here's another explanation: http://www.delphigroups.info/2/b2/444056.html

Referencing Service.Name crashes after moving service code to ancestor

I had a unit for a Windows (32 bit) service that was built up like this:
unit uSvcBase;
interface
type
TMyServiceBase = class(TService)
procedure ServiceBeforeUninstall(Sender: TService);
procedure ServiceCreate(Sender: TObject);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServiceExecute(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceAfterInstall(Sender: TService);
private
public
function GetServiceController: TServiceController; override;
end;
var
MyServiceBase: TMyServiceBase;
implementation
{$R *.DFM}
{$R SvcEventLogMessages.res}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
MyServiceBase.Controller(CtrlCode);
end;
function TMyServiceBase.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
const
rsServiceMessages =
'SYSTEM\CurrentControlSet\Services\EventLog\Application';
procedure TMyServiceBase.ServiceAfterInstall(Sender: TService);
var
lReg : TRegistry;
lAppName: String;
begin
lReg := TRegistry.create;
try
with lReg do
begin
Rootkey := HKEY_LOCAL_MACHINE;
if OpenKey(rsServiceMessages, False) then
begin
if OpenKey(MyServiceBase.Name, True) then
begin
lAppName := ParamStr(0);
WriteString('EventMessageFile', lAppName);
WriteString('CategoryMessageFile', lAppName);
WriteInteger('CategoryCount', 2);
WriteInteger('TypesSupported', EVENTLOG_ERROR_TYPE OR EVENTLOG_WARNING_TYPE OR EVENTLOG_INFORMATION_TYPE);
CloseKey;
end;
CloseKey;
end; { if OpenKey }
end; { with lReg }
finally
lReg.Free;
end;
end;
Because I needed to make a second service which was largely identical, I decided to make this a 'base' unit that others derive from (you can already see that in the names above):
unit uSvcTasks;
interface
uses
System.SysUtils, System.Classes, uSvcBase;
type
TMyServiceScheduler = class(TMyServiceBase)
procedure ServiceCreate(Sender: TObject);
private
public
end;
var
MyServiceScheduler: TMyServiceScheduler;
implementation
{%CLASSGROUP 'System.Classes.TPersistent'}
{$R *.dfm}
Uses uTypesAlgemeen;
procedure TMyServiceScheduler.ServiceCreate(Sender: TObject);
begin
inherited;
// Set some properties
end;
At design time, the MyServiceScheduler.Name in this descendant differs from the MyServiceBase.Name.
Issue: The AfterInstall now crashed. Trying to use the original code using OpenKey(MyServiceBase.Name was not allowed.
I worked around his by using a property for the name (setting it in the descendant Create), but I do not understand why referencing MyServiceBase.Name in the AfterInstall does not work. Can anyone explain?
Thanks to Uwe Raabe's comments I was able to figure out how to fix this:
The project had an Application.CreateForm(TMyServiceScheduler, MyServiceScheduler) in the project source which initializes MyServiceScheduler, but there was nothing initializing MyServiceBase, so refering to it was illegal.
Replace the reference to MyServiceBase.Name with Name in the AfterInstall(That should've been done anyway).
Move the code for the ServiceController from uSvcBase to uSvcTasks

How do I allow dragging files for specific control(s) in Delphi

I would like to accept files as soon as someone drops a file to a specific control (e.g. TMemo). I started with this example: http://delphi.about.com/od/windowsshellapi/a/accept-filedrop.htm and modified it like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Memo1.Handle, True ) ;
end;
This allows the control to show the dragging icon but the proper WM_DROPFILES message is not getting called because DragAcceptFiles needs a (Parent?)windowhandle. I could determine the MemoHandle in the WMDROPFILES procedure but I don't how, plus the dragging cursor applies for all the controls now. How do I allow dragging for a specific control (and block other controls from dragging)?
You should indeed pass the window handle of the memo control, but then you also need to listen to the WM_DROPFILES message sent to it:
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ShellAPI;
type
TMemo = class(StdCtrls.TMemo)
protected
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
procedure CreateWnd; override;
procedure DestroyWnd; override;
end;
TForm5 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.FormCreate(Sender: TObject);
begin
end;
{ TMemo }
procedure TMemo.CreateWnd;
begin
inherited;
DragAcceptFiles(Handle, true);
end;
procedure TMemo.DestroyWnd;
begin
DragAcceptFiles(Handle, false);
inherited;
end;
procedure TMemo.WMDropFiles(var Message: TWMDropFiles);
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
if c <> 1 then
begin
MessageBox(Handle, 'Too many files.', 'Drag and drop error', MB_ICONERROR);
Exit;
end;
if DragQueryFile(Message.Drop, 0, fn, MAX_PATH) = 0 then Exit;
Text := fn;
end;
end.
The example above only accept a single file dropped. The file name will be put in the memo control. But you can also allow a multiple selection to be dropped:
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
i: Integer;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
Clear;
for i := 0 to c - 1 do
begin
if DragQueryFile(Message.Drop, i, fn, MAX_PATH) = 0 then Exit;
Lines.Add(fn);
end;

how can i free a Tpanel That have a TbitBtn that calls to free the Tpanel

I create a Custom Tpanel and inside I put various Custom Components ...
procedure Panel_Comp(Location: TWinControl; NumOfComp: Integer;Left,Top,Height,width:Integer);
begin
MyPanel := TsPanel.Create(Conf);
MyPanel.Name := 'MyPanel' + IntToStr(NumOfComp);
MyPanel.Parent := Location;
MyPanel.Left := Left;
MyPanel.Top := Top;
MyPanel.Height := Height;
MyPanel.Width := width;
MyPanel.Caption := '';
end;
and i call it like this
Panel_Comp(Conf.ScrollBox1,1,8,10,70,322);
in the same logic i put inside the new panel other custom components including a tBitbtn the have a onclick event..
procedure BitBtn_Comp(Location: TWinControl; NumOfComp: Integer; Left,Top,Height,Width,ImageNum: Integer);
begin
MyBitBtn := TBitBtn.Create(Conf);
......
MyBitBtn.tag := NumOfComp;
MyBitBtn.OnClick:= Conf.CloseCurrentPanel;
end;
In the main Forn The TConf.CloseCurrentPanel;
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
TPanel(panelComp).Free;
Application.ProcessMessages;
end;
When I call that I get access violation...
I think is something that I must free all the components inside the panel before free the panel but how I free the BitBtn before the panel and continue the action of the click event?
Here is the FindComponetEx function instead you need it...
function FindComponentEx(const Name: string): TComponent;
var
FormName: string;
CompName: string;
P: Integer;
Found: Boolean;
Form: TForm;
I: Integer;
begin
// Split up in a valid form and a valid component name
P := Pos('.', Name);
if P = 0 then
begin
raise Exception.Create('No valid form name given');
end;
FormName := Copy(Name, 1, P - 1);
CompName := Copy(Name, P + 1, High(Integer));
Found := False;
// find the form
for I := 0 to Screen.FormCount - 1 do
begin
Form := Screen.Forms[I];
// case insensitive comparing
if AnsiSameText(Form.Name, FormName) then
begin
Found := True;
Break;
end;
end;
if Found then
begin
for I := 0 to Form.ComponentCount - 1 do
begin
Result := Form.Components[I];
if AnsiSameText(Result.Name, CompName) then Exit;
end;
end;
Result := nil;
end;
The AV occurs because you are destroying a component (MyBitBtn) while it is still handling Windows messages. The solution is to postpone the destruction until later via PostMessage, similar to this:
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls;
const
UM_DESTROYPANEL = WM_APP + 623; // some "unique" number; UM = user message
type
TConf = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
strict private
procedure UMDestroyPanel(var Message: TMessage); message UM_DESTROYPANEL;
public
{ Public-Deklarationen }
end;
var
Conf: TConf;
implementation
{$R *.dfm}
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, 0, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
Panel1.Free;
end;
end.
If needed you can use wParam and lParam to pass through parameters like so:
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(Panel1), 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
TObject(Message.WParam).Free;
end;
EDIT:
In your situation I'd probably rewrite TConf.CloseCurrentPanel like this:
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).Tag);
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(panelComp), 0);
end;
Alternatively you can pass through the Tag (might be the better solution because there's less casting involved):
procedure TConf.CloseCurrentPanel(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, TBitBtn(Sender).Tag, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(Message.WParam));
panelComp.Free;
end;
AFAICT the Application.ProcessMessages isn't needed.
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
//Where you need to determine 'PanelComp' if there are.
if Assigned(panelComp) and (PanelComp is TPanel) then
TPanel(panelComp).Free;
Application.ProcessMessages;
end;

How do I close open OLE dialogs

I have a function that closes all the forms in the application apart from the main form
procedure CloseOpenForms(const Component: TComponent);
var
i: Integer;
begin
for i := 0 to pred(Component.ComponentCount) do
begin
CloseOpenForms(Component.Components[i]);
if Component.Components[i] is TForm then
begin
TForm(Component.Components[i]).OnCloseQuery := nil;
TForm(Component.Components[i]).Close;
end;
end;
end;
Called from the main form:
CloseOpenForms(Self);
It works fine as long as there are no active OLE dialogs (e.g. TJvObjectPickerDialog).
How can I force these non modal OLE dialogs to close?
JVCL passes the application handle to 'hwndParent' parameter of IDSObjectPicker.InvokeDialog, hence the dialog is owned (not like 'owner' as in VCL, but more like popup parent) by the application window. Then you can enurate windows to find out the ones owned by the application window and post them a close command.
procedure CloseOpenForms(const AComponent: TComponent);
function CloseOwnedWindows(wnd: HWND; lParam: LPARAM): BOOL; stdcall;
begin
Result := TRUE;
if (GetWindow(wnd, GW_OWNER) = HWND(lParam)) and (not IsVCLControl(wnd)) then
begin
if not IsWindowEnabled(wnd) then // has a modal dialog of its own
EnumWindows(#CloseOwnedWindows, wnd);
SendMessage(wnd, WM_CLOSE, 0, 0);
end;
end;
procedure CloseOpenFormsRecursive(const RecComponent: TComponent);
var
i: Integer;
begin
for i := 0 to pred(RecComponent.ComponentCount) do
begin
CloseOpenFormsRecursive(RecComponent.Components[i]);
if RecComponent.Components[i] is TForm then
begin
TForm(RecComponent.Components[i]).OnCloseQuery := nil;
TForm(RecComponent.Components[i]).Close;
end;
end;
end;
begin
EnumWindows(#CloseOwnedWindows, Application.Handle);
CloseOpenFormsRecursive(AComponent)
end;

Resources