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;
Related
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.
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;
i am trying to achieve a simple task but by using GDI+ and i cannot find any example.
In my code i need to change an image position (top if to be more specific), but i have no idea if i can do it in a better way.
This is how i do it now:
procedure TForm2.Timer1Timer(Sender: TObject);
var
I: Integer;
begin
if image1.Top = -93 then
Begin
for I := -93 to -1 do
Begin
Sleep(10);
image1.Top := Image1.Top + 1;
Application.ProcessMessages;
End;
End else if image1.Top = 0 then
Begin
for I := 0 downto -92 do
Begin
Sleep(10);
image1.Top := Image1.Top - 1;
Application.ProcessMessages;
End;
End;
end;
Well it's pretty simple, but it does not go smooth, but jumps and redraws itself at each step.
I appreciate your help.
UPDATE:
Thanks to TLama and his inspiration i have found this GDIPlus implementation for delphi 2007
Moving control is a wrong way to animate anything, GDI+ independent. Instead, you should remember the position you want to change for the animation, modify it in the OnTimer event and tell the system that you want to invalidate the target control. Then in the control's OnPaint event you should render whatever you want by that position.
So as the first, replace your TImage component by a TPaintBox since the TImage is used mainly for static images, not for a dynamic rendering. Also use two timers. One for upward animation and one for downward animation.
The following code doesn't take into account approximation of a timer, and it uses less known Delphi 2009 GDI+ Library wrapper for Delphi:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, GdiPlus;
type
TForm1 = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
GPImage: IGPImage;
FImageTop: Integer;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FImageTop := 0;
Timer1.Interval := 15;
Timer2.Interval := 15;
DoubleBuffered := True;
Timer1.Enabled := True;
Timer2.Enabled := False;
GPImage := TGPImage.Create('d:\Image.jpg');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
// no need for the following line since it's a reference of the interface
// GPImage := nil;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if (FImageTop > -93) then
begin
FImageTop := FImageTop - 1;
PaintBox1.Invalidate;
end
else
begin
Timer1.Enabled := False;
Timer2.Enabled := True;
end;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if (FImageTop < 0) then
begin
FImageTop := FImageTop + 1;
PaintBox1.Invalidate;
end
else
begin
Timer2.Enabled := False;
Timer1.Enabled := True;
end;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
var
GPGraphics: IGPGraphics;
begin
GPGraphics := TGPGraphics.Create(PaintBox1.Canvas.Handle);
GPGraphics.DrawImage(GPImage, 0, FImageTop);
end;
end.
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;
Is there any way to know which verion of Windows we are working on?
I need to set image to TBitButton in Windows XP and no image in Windows7. It should be done automatically.
Check the SysUtils.Win32MajorVersion (in Delphi 7, you'll need to add SysUtils to your uses clause if it's not there already - later versions add it automatically). The easiest way is to assign the Glyph as usual in the IDE, and clear it if you're running on Vista or higher:
if SysUtils.Win32MajorVersion >= 6 then // Windows Vista or higher
BitBtn1.Glyph := nil;
For more info on detecting specific Windows editions and versions, see this post. It hasn't been updated for the latest Windows versions and editions, but it'll get you started. You can also search SO for [delphi] GetVersionEx to see other examples.
This is actually a little project of mine - a drop-in component which provides info of the operating system - even preview it in design-time...
unit JDOSInfo;
interface
uses
Classes, Windows, SysUtils, StrUtils, Forms, Registry;
type
TJDOSInfo = class(TComponent)
private
fReg: TRegistry;
fKey: String;
fMinor: Integer;
fMajor: Integer;
fBuild: Integer;
fPlatform: Integer;
fIsServer: Bool;
fIs64bit: Bool;
fProductName: String;
function GetProductName: String;
procedure SetProductName(Value: String);
procedure SetMajor(Value: Integer);
procedure SetMinor(Value: Integer);
procedure SetBuild(Value: Integer);
procedure SetPlatform(Value: Integer);
procedure SetIs64Bit(const Value: Bool);
procedure SetIsServer(const Value: Bool);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Major: Integer read fMajor write SetMajor;
property Minor: Integer read fMinor write SetMinor;
property Build: Integer read fBuild write SetBuild;
property Platf: Integer read fPlatform write SetPlatform;
property ProductName: String read GetProductName write SetProductName;
property IsServer: Bool read fIsServer write SetIsServer;
property Is64Bit: Bool read fIs64bit write SetIs64Bit;
end;
function IsWOW64: Boolean;
function GetOSInfo: TOSVersionInfo;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('JD Custom', [TJDOSInfo]);
end;
function GetOSInfo: TOSVersionInfo;
begin
FillChar(Result, SizeOf(Result), 0);
Result.dwOSVersionInfoSize := SizeOf(Result);
if not GetVersionEx(Result) then
raise Exception.Create('Error calling GetVersionEx');
end;
function IsWOW64: Boolean;
type
TIsWow64Process = function( // Type of IsWow64Process API fn
Handle: THandle;
var Res: BOOL): BOOL; stdcall;
var
IsWow64Result: BOOL; // result from IsWow64Process
IsWow64Process: TIsWow64Process; // IsWow64Process fn reference
begin
// Try to load required function from kernel32
IsWow64Process:= GetProcAddress(GetModuleHandle('kernel32'),'IsWow64Process');
if Assigned(IsWow64Process) then
begin
// Function is implemented: call it
if not IsWow64Process(GetCurrentProcess, IsWow64Result) then
raise Exception.Create('Bad process handle');
// Return result of function
Result := IsWow64Result;
end else
// Function not implemented: can't be running on Wow64
Result:= False;
end;
constructor TJDOSInfo.Create(AOwner: TComponent);
var
Info: TOSVersionInfo;
Str: String;
begin
inherited Create(AOwner);
fReg:= TRegistry.Create(KEY_READ);
fReg.RootKey:= HKEY_LOCAL_MACHINE;
fKey:= 'Software\Microsoft\Windows NT\CurrentVersion';
fReg.OpenKey(fKey, False);
Info:= GetOSInfo;
fMajor:= Info.dwMajorVersion;
fMinor:= Info.dwMinorVersion;
fBuild:= Info.dwBuildNumber;
fIsServer:= False;
fIs64bit:= False;
fPlatform:= Info.dwPlatformId;
if fMajor >= 5 then begin
//After 2000
if fReg.ValueExists('ProductName') then
Str:= fReg.ReadString('ProductName')
else begin
Str:= 'Unknown OS: '+IntToStr(fMajor)+'.'+IntToStr(fMinor)+'.'+
IntToStr(fBuild)+'.'+IntToStr(fPlatform);
end;
if fReg.ValueExists('InstallationType') then begin
if UpperCase(fReg.ReadString('InstallationType')) = 'SERVER' then
fIsServer:= True;
end;
fIs64bit:= IsWOW64;
if fIs64bit then
Str:= Str + ' 64 Bit';
end else begin
//Before 2000
case fMajor of
4: begin
case fMinor of
0: Str:= 'Windows 95';
10: Str:= 'Windows 98';
90: Str:= 'Windows ME';
end;
end;
else begin
Str:= 'Older than 95';
end;
end;
end;
Self.fProductName:= Str;
end;
destructor TJDOSInfo.Destroy;
begin
if assigned(fReg) then begin
if fReg.Active then
fReg.CloseKey;
fReg.Free;
end;
inherited Destroy;
end;
function TJDOSInfo.GetProductName: String;
begin
Result:= Self.fProductName;
end;
procedure TJDOSInfo.SetProductName(Value: String);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetMinor(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetMajor(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetBuild(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetPlatform(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetIs64Bit(const Value: Bool);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetIsServer(const Value: Bool);
begin
//Do Nothing Here!
end;
end.