I use the following code to capture when the minimise button of my program is pressed so that I can hide the form from the taskbar, and as such minimise to the system tray.
procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
form1.Hide;
show1.Checked :=false;
hide1.Checked :=true;
end;
if (Msg.CmdType = SC_CLOSE) then form1.Close;
end;
I have had to put the capture in for the close button too as this code was preventing the program closing via the close button. What I need help with is how to fix dragging the program window by the caption bar which has stopped working with this code.
If you override the processing of a Windows message you need to take care to either handle all possible cases, or to call the inherited code for all unhandled cases:
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if (Msg.CmdType = SC_MINIMIZE) then
begin
Hide;
show1.Checked := False;
hide1.Checked := True;
Msg.Result := 0;
exit;
end;
inherited;
end;
Related
In the Delphi IDE, create a VCL Forms Application. Then add a TApplicationEvents component and a TButton on the form. Then add these two event-handlers:
uses
JclShell;
procedure TForm3.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
begin
if Msg.Message = WM_LBUTTONDOWN then
begin
Self.Caption := 'WM_LBUTTONDOWN';
end
else if Msg.Message = WM_LBUTTONUP then
begin
Self.Caption := 'WM_LBUTTONUP';
end
end;
procedure TForm3.Button1Click(Sender: TObject);
begin
JclShell.ShellExecAndWait('C:\Windows\system32\notepad.exe');
Self.Caption := 'Notepad closed';
end;
Now click on the button. The following happens:
"WM_LBUTTONDOWN" appears on the form's title-bar.
"WM_LBUTTONUP" appears on the form's title-bar.
Notepad is executed.
Then click again on the button which starts another instance of Notepad BUT this time without writing anything on the form's title-bar.
Obviously, the program is stuck in JclShell.ShellExecAndWait which returns only when Notepad is closed. So when Notepad is closed any mouse-click again writes to the form's title-bar.
So we can see that while Notepad is running in JclShell.ShellExecAndWait everything in the program works normally: You could even make mathematical calculations while Notepad is running in JclShell.ShellExecAndWait. Only the ApplicationEvents1Message is not triggered while Notepad is running.
So how can I get a WM_LBUTTONDOWN message while Notepad is running in JclShell.ShellExecAndWait?
While JclShell.ShellExecAndWait is waiting for the spawned process to exit it uses following basic message pump:
while WaitForSingleObject(Sei.hProcess, 10) = WAIT_TIMEOUT do
repeat
Msg.hwnd := 0;
Res := PeekMessage(Msg, Sei.Wnd, 0, 0, PM_REMOVE);
if Res then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
until not Res;
CloseHandle(Sei.hProcess);
I say basic, because the looped part of the VCLs message pump looks like this:
if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
begin
Unicode := (Msg.hwnd = 0) or IsWindowUnicode(Msg.hwnd);
if Unicode then
MsgExists := PeekMessageW(Msg, 0, 0, 0, PM_REMOVE)
else
MsgExists := PeekMessageA(Msg, 0, 0, 0, PM_REMOVE);
if MsgExists then
begin
Result := True;
if Msg.Message <> WM_QUIT then
begin
Handled := False;
if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
if not IsPreProcessMessage(Msg) and not IsHintMsg(Msg) and
not Handled and not IsMDIMsg(Msg) and
not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
begin
TranslateMessage(Msg);
if Unicode then
DispatchMessageW(Msg)
else
DispatchMessageA(Msg);
end;
end
else
begin
{$IF DEFINED(CLR)}
if Assigned(FOnShutDown) then FOnShutDown(self);
DoneApplication;
{$IFEND}
FTerminate := True;
end;
end;
The code line
if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
is what will hand the message to your TApplicationEvents.OnMessage via the TMultiCaster that TApplicationEvents has assigned to Application.OnMessage. This is not done in the JCL source.
Additional issues might be that JCL is not UniCode aware regarding messages at this point and there is no handling for WM_QUIT.
What to do about this is depending on what you want to achieve, too. Why do you want to receive this messages in the first place?
I mean it is possible to alter the JCL source - if you are willing to do so - and to add VCL.Forms to the uses, and then call the event handler if assigned like the VCL does:
while WaitForSingleObject(Sei.hProcess, 10) = WAIT_TIMEOUT do
repeat
Msg.hwnd := 0;
Res := PeekMessage(Msg, Sei.Wnd, 0, 0, PM_REMOVE);
if Res then
begin
Handled := False;
if Assigned(Application.OnMessage) then
Application.OnMessage(Msg, Handled);
if not Handled then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
until not Res;
CloseHandle(Sei.hProcess);
Or even call Application.ProcessMessages, to have the same message processing in place the VCL does:
while WaitForSingleObject(Sei.hProcess, 10) = WAIT_TIMEOUT do
Application.ProcessMessages;
CloseHandle(Sei.hProcess);
This is working, I could not see any side effects like commenters suggested. But before changing the JCL source in this way I would probably implement my own ShellExecAndWait. Depending on what you would like to achieve, the normal dispatching of messages should still work. So if your TFrom has e.g.
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
implemented, it should be called. This is, however, only the case if the message was directed at your form. If the button is clicked, the resulting messages will be directed to the button itself. You would need to implement your own descendant class then.
Maybe a completely different suggestion?
If your goal is to let certain controls not to be clicked while JclShell.ShellExecAndWait is waiting, and using message handling is your approach to make this possible, there might be other things you can try.
Why not disable them? This will also give the user a visible indication that clicking is a no-go.
Button1.Enabled := False;
try
JclShell.ShellExecAndWait('C:\Windows\system32\notepad.exe');
Self.Caption := 'Notepad closed';
finally
Button1.Enabled := True;
end;
If you are concerned about multiple controls create a TAction, assign it to every control you want to disable and disable all of them together with the Enabled property of the TAction.
Or, just hide your form while notepad.exe is opened?
Hide;
try
JclShell.ShellExecAndWait('C:\Windows\system32\notepad.exe');
Self.Caption := 'Notepad closed';
finally
Show;
end;
Or you could remove the event handlers:
var
ATmpOnClick: TNotifyEvent;
begin
ATmpOnClick := Button1.OnClick;
Button1.OnClick := nil;
try
JclShell.ShellExecAndWait('C:\Windows\system32\notepad.exe');
Self.Caption := 'Notepad closed';
finally
Button1.OnClick := ATmpOnClick;
end;
end;
I have a Firemonkey multi device project in Delphi 10 Seattle where the user can get a screen at the start of the app. Here the user needs to fill in 2 fields. But when I click on the edit fields the Virtual Keyboard isn't shown. If I skip this screen at start and call it later then the Virtual Keyboard is shown. This is done in the same way too.
I found sort of a solution:
When i click on the edit fields i call show VirtualKeyboard myself. The only problem is that the cursor isn't shown in the edit field.
Is there a way to place the cursor myself? Or does anyone know how to solve the Virtual Keyboard not showing problem in an other way?
Problem is on both Android and iOS
In the code below you can see the initial form create. The problem is when in ConnectFromProfile method the actCreateNewProfileExecute is called. There it will call a new form. In that form(TfrmProfile) the virtual keyboard isn't shown. I also call this form with another action and then it works fine.
procedure TfrmNocoreDKS.FormCreate(Sender: TObject);
begin
Inherited;
System.SysUtils.FormatSettings.ShortDateFormat := 'dd/mm/yyyy';
CheckPhone;
ConnectfromProfile;
if not Assigned(fProfileAction) then
ConnectDatabase
Else
lstDocuments.Enabled := False;
{$IFDEF ANDROID}
ChangeComboBoxStyle;
{$ENDIF}
end;
procedure TfrmNocoreDKS.ConnectfromProfile;
begin
fdmProfileConnection := TdmConnection.Create(nil);
fdmProfileConnection.OpenProfileDb;
fdmProfileConnection.LoadProfiles;
if fdmProfileConnection.Profiles.Count = 0 then
begin // Createdefault Profile
fProfileAction := actCreateNewProfileExecute;
end
else if fdmProfileConnection.Profiles.Count = 1 then
begin // one profile load connection;
fProfileAction := nil;
fCurrentProfile := fdmProfileConnection.Profiles.Items[0];
end
else
begin // multiple profiles choose connection;
fProfileAction := SelectProfileOnStartUp;
end;
end;
procedure TfrmNocoreDKS.FormShow(Sender: TObject);
begin
if Assigned(fProfileAction) then
fProfileAction(Self);
end;
procedure TfrmNocoreDKS.actCreateNewProfileExecute(Sender: TObject);
var
profilename, databasename, pathname: string;
prf: TfrmProfile;
begin
prf := TfrmProfile.Create(nil);
prf.Data := fdmProfileConnection.Profiles;
prf.ShowModal(
procedure(ModalResult: TModalResult)
begin
if ModalResult = mrOk then
begin
profilename := prf.edtProfilename.Text;
databasename := prf.edtDatabaseName.Text;
{$IFDEF IOS}
pathname := System.IOUtils.TPath.GetDocumentsPath;
{$ENDIF}
{$IFDEF ANDROID}
pathname := System.IOUtils.TPath.GetDocumentsPath;
{$ENDIF}
{$IFDEF WIN32}
pathname := ExtractFilePath(ParamStr(0)) + '\Data';
{$ENDIF}
FDSQLiteBackup1.Database := System.IOUtils.TPath.Combine(pathname,
'default.sqlite3'); // Default Database
FDSQLiteBackup1.DestDatabase := System.IOUtils.TPath.Combine(pathname,
databasename + '.sqlite3');
FDSQLiteBackup1.Backup;
fdmProfileConnection.AddProfile(databasename + '.sqlite3', profilename);
fdmProfileConnection.LoadProfiles;
fCurrentProfile := fdmProfileConnection.Profiles.Items[0];
connectDatabase;
end else
Application.Terminate;
end);
end;
Do not show any additional forms in MainForm.OnCreate/OnShow. Trying this on iOS 9.2 freeze app at "launch screen".
Instead of this, show new form asynchronously, like this:
procedure TForm4.FormShow(Sender: TObject);
begin
TTask.Run(procedure
begin
TThread.Synchronize(nil, procedure // work with visual controls - only throught Synchronize or Queue
begin
Form5:=TForm5.Create(Application);
Form5.ShowModal;
end)
end);
end;
of cource, you can separate this code to external procedures:
procedure ShowMyForm;
begin
Form5:=TForm5.Create(Application);
Form5.ShowModal;
end;
procedure TaskProc;
begin
TThread.Synchronize(nil, ShowMyForm);
end;
procedure TForm4.FormShow(Sender: TObject);
begin
TTask.Run(TaskProc);
end;
========
Another way - do not use any additional forms. Create frame and put it (at runtime) on MainForm with Align = Contents. After all needed actions - hide or release (due to ARC dont forget to set nil to frame variable) this frame.
i have the current scenario, im using omnithreadlibrary for some generic background work like this:
TMethod = procedure of object;
TThreadExecuter = class;
IPresentationAnimation = interface
['{57DB6925-5A8B-4B2B-9CDD-0D45AA645592}']
procedure IsBusy();
procedure IsAvaliable();
end;
procedure TThreadExecuter.Execute(AMethod: TMethod); overload;
var ATask : IOmniTaskControl;
begin
ATask := CreateTask(
procedure(const ATask : IOmniTask) begin AMethod(); end
).OnTerminated(
procedure begin ATask := nil; end
).Unobserved().Run();
while Assigned(ATask) do
begin
Sleep(10);
Application.ProcessMessages;
end;
end;
procedure TThreadExecuter.Execute(ASender: TCustomForm; AMethod: TMethod); overload;
var AAnimator : IPresentationAnimation;
begin
if(Assigned(ASender)) then
begin
TInterfaceConsolidation.Implements(ASender, IPresentationAnimation, AAnimator, False);
if(Assigned(AAnimator)) then AAnimator.IsBusy()
else ASender.Enabled := False;
end;
try
Self.Execute(AMethod);
finally
if(Assigned(ASender)) then
begin
if(Assigned(AAnimator)) then AAnimator.IsAvaliable()
else ASender.Enabled := True;
end;
end;
end;
so before i start executing i block the interface like this:
TMyForm = class(TForm, IPresentationAnimation);
procedure TMyForm.LoadData();
begin
TThreadExecuter.Execute(Self, Self.List);
end;
procedure TMyForm.IsBusy();
begin
try
Self.FWorker := TPresentationFormWorker.Create(Self);
Self.FWorker.Parent := Self;
Self.FWorker.Show();
finally
Self.Enabled := False;
end;
end;
and when the thread finish i release the block like this:
procedure TMyForm.IsAvaliable();
begin
try
Self.FWorker.Release();
finally
Self.Enabled := True;
end;
end;
note: TPresentationFormWorker is a animated form that i put in form of the busy one.
the problem is that when the form is "busy" executing the thread even after i disable it, i can still interact with him, for example:
i can click in any button and when the thread finish the execution the action of the button are triggered;
i can typing in any control, e.g a Edit some nonsense information and when the thread finish the execution the content i provided to the control are erased back to before (ui rollback? lol);
so my guess is that while the thread are working thanks to the application.processmessages the interaction i made to the disable form are sended to the queue and once the thread finish they are all send back to the form.
my question is: is possible to actually disable the form, when i say disable i mean block all messages until certain point that i manually allow that can start accept again?
thx in advance.
I'm attempting to switch from using Toolbar2000 to the regular toolbar because there doesn't seem to be a Delphi XE2 version and it looks like it uses some Assembly and I just don't really want to deal with it if I don't have to. (and I really like the fade-in effect with the Delphi Toolbar)
But, what I don't like is that the background of the button gets the regular blueish button treatment. I know how to change the color, but can I just not make the color change and not have a border painted around the button?
I've implemented the 'OnAdvancedCustomDrawButton' but the flags available don't seem to work right and I'm not sure how they interact with the gradient color and the hot track color and I wind up having some weird flashing or weird black backgrounds.
Here's how I'm creating the Toolbar
ToolBar1 := TToolBar.Create(Self);
ToolBar1.DoubleBuffered := true;
ToolBar1.OnAdvancedCustomDrawButton := Toolbar1CustomDrawButton;
ToolBar1.Transparent := false;
ToolBar1.Parent := Self;
ToolBar1.GradientEndColor := $7ca0c2; //RGB(194, 160, 124);
ToolBar1.GradientStartColor := $edeeed; //RGB(237, 238, 124);
ToolBar1.Indent := 5;
ToolBar1.Images := Normal;
ToolBar1.DrawingStyle := dsGradient;
ToolBar1.HotImages := Over;
ToolBar1.AutoSize := True;
ToolBar1.Visible := False;
and here's how I'm creating the buttons (in a loop):
ToolButton := TToolButton.Create(ToolBar1);
ToolButton.Parent := ToolBar1;
ToolButton.ImageIndex := ToolButtonImages[Index].ImageIndex;
ToolButton.OnClick := ToolButtonClick;
and here's my AdvancedCustomDrawButton function
procedure TMyForm.Toolbar1CustomDrawButton(Sender: TToolBar; Button: TToolButton;
State: TCustomDrawState; Stage: TCustomDrawStage;
var Flags: TTBCustomDrawFlags; var DefaultDraw: Boolean);
begin
Flags := [tbNoEdges, tbNoOffset];
DefaultDraw := True;
end;
Set drawing style of the toolbar to dsNormal and set Flags to [tbNoEdges] in custom draw handler.
update:
While the above works for 2K and XP, Vista and 7 seem to not to draw the border when button background is not drawn. Unfortunately achieving this with the VCL supplied TTBCustomDrawFlags is impossible, so we cannot get rid of the borders in a custom drawing handler.
If the toolbar is on the form itself we can put a handler for WM_NOTIFY since notification messages are sent to the parent window:
type
TForm1 = class(TForm)
..
private
procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
..
..
procedure TForm1.WMNotify(var Msg: TWMNotify);
begin
inherited;
if (Msg.NMHdr.code = NM_CUSTOMDRAW) and
Assigned(Toolbar1) and (Toolbar1.HandleAllocated) and
(Msg.NMHdr.hwndFrom = ToolBar1.Handle) then
case PNMTBCustomDraw(Msg.NMHdr).nmcd.dwDrawStage of
CDDS_PREPAINT: Msg.Result := Msg.Result or CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: Msg.Result := TBCDRF_NOEDGES or TBCDRF_NOBACKGROUND;
// NOEDGES for 2K, XP, // NOBACKGROUND for Vista 7
end;
end;
If the toolbar is parented in another window, like a panel, then we need to subclass the toolbar:
type
TForm1 = class(TForm)
..
private
FSaveToolbarWndProc: TWndMethod;
procedure ToolbarWndProc(var Msg: TMessage);
..
..
uses
commctrl;
procedure TForm1.FormCreate(Sender: TObject);
begin
..
FSaveToolbarWndProc := ToolBar1.WindowProc;
ToolBar1.WindowProc := ToolbarWndProc;
end;
procedure TForm1.ToolbarWndProc(var Msg: TMessage);
begin
FSaveToolbarWndProc(Msg);
if (Msg.Msg = CN_NOTIFY) and
(TWMNotify(Msg).NMHdr.hwndFrom = ToolBar1.Handle) and
(TWMNotify(Msg).NMHdr.code = NM_CUSTOMDRAW) then begin
case PNMTBCustomDraw(TWmNotify(Msg).NMHdr)^.nmcd.dwDrawStage of
CDDS_PREPAINT: Msg.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: Msg.Result := TBCDRF_NOEDGES or TBCDRF_NOBACKGROUND;
end;
end;
end;
(Note that drawing style still needs to be dsNormal.)
With this solution you don't need to put a handler for custom drawing. But if you need/want to anyway, you might need to 'or' the Msg.Result with the one VCL's window procedure returns, i.e the 'case' would look like:
CDDS_PREPAINT: Msg.Result := Msg.Result or CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT: Msg.Result :=
Msg.Result or TBCDRF_NOEDGES or TBCDRF_NOBACKGROUND;
same goes for when we handle WM_NOTIFY on the form.
There may be other ways to achieve the same, custom drawing is a broad topic. If you want to delve into it, I suggest you to start from the links below for the problem at hand:
About Custom Draw
NM_CUSTOMDRAW (toolbar) notification code
NMCUSTOMDRAW structure
NMTBCUSTOMDRAW structure
We use mouse left click to trigger actions in menu items of TPopupMenu. How to trigger different action on mouse middle click in these menu items? In other word, mouse left and middle click on TPopupmenu's menu items are both different action.
The global Menus.PopupList variable keeps track of all PopupMenus and handles all massages send to them. You can override this PopupList with your own instance, as follows:
type
TMyPopupList = class(TPopupList)
private
FMenuItem: TMenuItem;
protected
procedure WndProc(var Message: TMessage); override;
end;
{ TMyPopupList }
procedure TMyPopupList.WndProc(var Message: TMessage);
var
FindKind: TFindItemKind;
I: Integer;
Item: Integer;
Action: TBasicAction;
Menu: TMenu;
begin
case Message.Msg of
WM_MENUSELECT:
with TWMMenuSelect(Message) do
begin
FindKind := fkCommand;
if MenuFlag and MF_POPUP <> 0 then
FindKind := fkHandle;
for I := 0 to Count - 1 do
begin
if FindKind = fkHandle then
begin
if Menu <> 0 then
Item := GetSubMenu(Menu, IDItem)
else
Item := -1;
end
else
Item := IDItem;
FMenuItem := TPopupMenu(Items[I]).FindItem(Item, FindKind);
if FMenuItem <> nil then
Break;
end;
end;
WM_MBUTTONUP:
if FMenuItem <> nil then
begin
GetMenuItemSecondAction(FMenuItem, Action);
Menu := FMenuItem.GetParentMenu;
if Action <> nil then
begin
Menu := FMenuItem.GetParentMenu;
SendMessage(Menu.WindowHandle, WM_IME_KEYDOWN, VK_ESCAPE, 0);
Action.Execute;
Exit;
end;
end;
end;
inherited WndProc(Message);
end;
initialization
PopupList.Free;
PopupList := TMyPopupList.Create;
The GetMenuItemSecondAction routine you have to write yourself. Maybe this answer provides some help about adding your own actions to a component.
Note that the code under WM_MENUSELECT is simply copied from Menus.TPopupList.WndProc. You could also retrieve the MenuItem in the WM_MBUTTONUP handling by using MenuItemFromPoint.
But as the many comments have already said: think twice (or more) before implementing this UI functionality.
You are not notified of such an event. If you were there would be an entry for middle mouse button click in the list of menu notifications.
So perhaps you could use some sort of hack behind the back of the menu system if you really want to do this. However, as discussed in the comments, there are good reasons for thinking that your proposed UI may not be very appropriate.
If the middle click is not a suitable choice, how about using some key combination with mouse click like Ctrl-Click, to trigger another action? The TPopupMenu doesn't have any event related to customized click.
That is preferred over a middle mouse button click.
And then it is much simpler. Just check in your action execute handler if the CTRL button is pressed:
procedure TForm1.Action1Execute(Sender: TObject);
begin
if (GetKeyState(VK_CONTROL) and $8000 = 0) then
// process normal click
else
// process ctrl click
end;
I try to combine 2 answers from author NGLN and come out with the following.
Define a new class inherit from TPopupList:
TMyPopupList = class(TPopupList)
protected
procedure WndProc(var Message: TMessage); override;
end;
procedure TMyPopupList.WndProc(var Message: TMessage);
var H: HWND;
begin
case Message.Msg of
WM_MBUTTONDOWN: begin
H := FindWindow(PChar('#32768'), nil);
SendMessage(H, WM_IME_KEYDOWN, VK_RETURN, 0);
end;
end;
inherited WndProc(Message);
end;
initialization
PopupList.Free;
PopupList := TMyPopupList.Create;
end.
The Item1Click is an OnClick event handler of TMenuItem that perform based on mouse click:
procedure TForm1.Item1Click(Sender: TObject);
begin
if (GetKeyState(VK_MBUTTON) and $80 > 0) then
Caption := 'Middle Click'
else
Caption := 'Normal Click';
end;
Note: #32768 is the default window class name for a pop-up menu, see MSDN documentation.