Good Day all
I searched the web for any directions as to if this is possible but to no avail. I need to write an application that will allow me to select another application and by doing so make the selected application translucent and on-top (like a ghost image overlay).
Is this at all possible with Delphi? I am using Delphi XE and Lazarus. If anybody could just please point me in the general direction of where to start I will be much obliged.
Thanks in advance,
You can do this but is not recommended, because this kind of behavior must be handled by the own application. anyway if you insist because do you have a very good reason to do this, here i leave the code to set the transparency of a window and Make a windows Top Most, just to show how can be done.
Transparency
you must use the SetWindowLong function with the WS_EX_LAYERED flag and the SetLayeredWindowAttributes function with LWA_ALPHA to set the transparency.
Procedure SethWndTrasparent(hWnd: HWND;Transparent:boolean);
var
l : Longint;
lpRect : TRect;
begin
if Transparent then
begin
l := GetWindowLong(hWnd, GWL_EXSTYLE);
l := l or WS_EX_LAYERED;
SetWindowLong(hWnd, GWL_EXSTYLE, l);
SetLayeredWindowAttributes(hWnd, 0, 180, LWA_ALPHA);
end
else
begin
l := GetWindowLong(hWnd, GWL_EXSTYLE);
l := l xor WS_EX_LAYERED;
SetWindowLong(hWnd, GWL_EXSTYLE, l);
GetWindowRect(hWnd, lpRect);
InvalidateRect(hWnd, lpRect, true);
end;
end;
Make a windows Top Most
You must use the SetWindowPos function passing the HWND_TOPMOST value which places the window above all non-topmost windows. The window maintains its topmost position even when it is deactivated.
Procedure SethWndOnTop(hWnd: HWND);
var
lpRect : TRect;
begin
if GetWindowRect(hWnd,lpRect) then
SetWindowPos(hWnd , HWND_TOPMOST, lpRect.left, lpRect.top, lpRect.Right-lpRect.left, lpRect.Bottom-lpRect.Top, SWP_SHOWWINDOW);
end;
Windows can do this but an app has got no hope of doing this robustly.
Related
I'd like to see emojis in color in a TEdit or TMemo control using VCL and Delphi 10+.
Can it be done?
Text entered:
đ¨đźâđ¤đŠđžâđŠđźâđ§đťâđŚđż
What I see:
What I'd like to see:
Your question made me curious, so tried and here is the result:
Drawing colored fonts in general
Apparently FMX supports this out of the box in later versions, but not in Seattle, which I happen to have. I don't know if the VCL also supports it out of the box in your version, but if not, you can achieve using Direct2D. The trick is to draw text using the D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT option.
In Seattle (10), this constant is not defined, and - unfortunately - not used in the default TCanvas-compatible functions. But you can call DrawText or one of the other functions yourself and specify the option.
The general structure is based on this Embarcadero docwiki. The rest is peeked from TDirect2DCanvas, combined with the DrawText documentation.
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
procedure TForm1.FormPaint(Sender: TObject);
const
str: string = 'xyzđ¨đźâđ¤đŠđžâđŠđźâđ§đťâđŚđż';
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
c := TDirect2DCanvas.Create(Canvas.Handle, Rect(0, 0, 100, 100));
c.BeginDraw;
try
r.left := 0;
r.top := 0;
r.right := 100;
r.bottom := 50;
// Brush determines the font color.
c.Brush.Color := clBlack;
c.RenderTarget.DrawText(
PWideChar(str), Length(Str), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;
This little piece of code works in a fairly ugly way (in terms of positioning the text), but you can also peek in TDirect2DCanvas, and copy the implementation of one of its text methods to create a function for outputting text in a specific way that you want. And after that it should be fairly easy to apply this to your own TGraphicControl or TCustomControl descendant to create an emoji-supporting label.
Doing that in TEdit
To manage this in TEdit is harder, since drawing the text (and the emoji) is handled by the control itself. It should be possible to create a TEdit descendant and/or hook into its WM_PAINT message and paint over the text using this same trick, but I'm not sure how well that would work.
I gave that a quick shot, but it doesn't really work well perfectly, especially when editing. So I've made this descendant of TEdit. When focused, it draws the text in a normal way, and the colored emoji will be black and white, and split into two characters (the emoji and the color combination character). When the edit loses its focus, the custom paint code takes over, which works well in that scenario. Maybe you can attempt to polish it to make it work while editing as well, but then you have to take scrolling, positioning the caret and other stuff into account. For a TMemo descendant that would be even harder. I hope you're happy with just colored display for now. :-)
type
TMyEdit = class(Vcl.StdCtrls.TEdit)
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
end;
implementation
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
const
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
constructor TMyEdit.Create(AOwner: TComponent);
begin
inherited;
DoubleBuffered := True;
end;
procedure TMyEdit.PaintWindow(DC: HDC);
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
// Default drawing when focused. Otherwise do the custom draw.
if Focused then
begin
Inherited;
Exit;
end;
c := TDirect2DCanvas.Create(dc, ClientRect);
c.BeginDraw;
try
r.left := ClientRect.Left;
r.top := ClientRect.Top;
r.right := ClientRect.Right;
r.bottom := ClientRect.Bottom;
// Basic font properties
c.Font.Assign(Font);
// Brush determines the font color.
c.Brush.Color := Font.Color;
c.RenderTarget.DrawText(
PWideChar(Text), Length(Text), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;
Is it possible to remove NotifyIcon from the notification area (system tray) when an app terminates abruptly?
if no, how can I remove it when the app runs for the next time?
Abruptly? No. Your program has ceased to exist, so there's no opportunity to run any code to tell the shell that it should remove the icon.
To remove the icon, move your mouse over it. The shell will try to notify your program, realize there's nothing there anymore, and remove the icon by itself.
On Windows 7 and later, notify icons can be identified by a user-defined GUID. On earlier versions, they are identified by a combination of HWND and ID number instead. Since your app is not guaranteed to get the same HWND value the next time it runs, the only way you can do anything to an old icon that is identified by HWND is if you remembered the previous HWND value so you can use it to remove the old icon, before then using a new HWND to add a new icon. But with a GUID-identified icon, the GUID needs to be persistent (as it is stored in the Registry to store app settings associated with the icon), so you should be able to simply keep updating the existing icon as needed, or remove it if desired.
FWIW, since code doesn't exist so far, I thought I'd throw this in. I don't know if it will help or not for the OP, but it should be good guidance in the right direction.
unit csystray;
{ removes dead system tray icons, by Glenn1234 # stackoverflow.com
since this uses "less than supported by Microsoft" means, it may
not work on all operating system. It was tested on Windows XP }
interface
uses commCtrl, shellapi, windows;
type
TTrayInfo = packed record
hWnd: HWnd;
uID: UINT;
uCallBackMessage: UINT;
Reserved1: array[0..1] of longint;
Reserved2: array[0..2] of longint;
hIcon: HICON;
end;
PTBButton = ^TTBButton;
_TBBUTTON = packed record
iBitmap: Integer;
idCommand: Integer;
fsState: Byte;
fsStyle: Byte;
bReserved: array[1..2] of Byte;
dwData: Longint;
iString: Integer;
end;
TTBButton = _TBBUTTON;
procedure RemoveStaleTrayIcons;
implementation
procedure RemoveStaleTrayIcons;
const
VMFLAGS = PROCESS_VM_OPERATION or PROCESS_VM_READ OR PROCESS_VM_WRITE;
var
ProcessID: THandle;
ProcessHandle: THandle;
trayhandle: HWnd;
ExplorerButtonInfo: Pointer;
i: integer;
ButtonCount: Longint;
BytesRead: Longint;
ButtonInfo: TTBButton;
TrayInfo: TTrayInfo;
ClassNameA: Array[0..255] of char;
outlen: integer;
TrayIconData: TNotifyIconData;
begin
// walk down the window hierarchy to find the notification area window
trayhandle := FindWindow('Shell_TrayWnd', '');
trayhandle := FindWindowEx(trayhandle, 0, 'TrayNotifyWnd', nil);
trayhandle := FindWindowEx(trayhandle, 0, 'SysPager', nil);
trayhandle := FindWindowEx(trayhandle, 0, 'ToolbarWindow32', nil);
if trayhandle = 0 then exit;
// find the notification area process and open it up for reading.
GetWindowThreadProcessId(trayhandle, #ProcessID);
ProcessHandle := OpenProcess(VMFLAGS, false, ProcessID);
ExplorerButtonInfo := VirtualAllocEx(ProcessHandle, nil, Sizeof(TTBButton),
MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);
// the notification area is a tool bar. Get the number of buttons.
ButtonCount := SendMessage(trayhandle, TB_BUTTONCOUNT, 0, 0);
if ExplorerButtonInfo <> nil then
try
// iterate the buttons & check.
for i := (ButtonCount - 1) downto 0 do
begin
// get button information.
SendMessage(trayhandle, TB_GETBUTTON, i, LParam(ExplorerButtonInfo));
ReadProcessMemory(ProcessHandle, ExplorerButtonInfo, #ButtonInfo,
Sizeof(TTBButton), BytesRead);
// if there's tray data, read and process
if Buttoninfo.dwData <> 0 then
begin
ReadProcessMemory(ProcessHandle, PChar(ButtonInfo.dwData),
#TrayInfo, Sizeof(TTrayInfo), BytesRead);
// here's the validation test, this fails if the master window is invalid
outlen := GetClassName(TrayInfo.hWnd, ClassNameA, 256);
if outlen < 1 then
begin
// duplicate the shell icon removal, i.e. my component's DeleteTray
TrayIconData.cbSize := sizeof(TrayIconData);
TrayIconData.Wnd := TrayInfo.hWnd;
TrayiconData.uID := TrayInfo.uID;
TrayIconData.uCallbackMessage := TrayInfo.uCallBackMessage;
Shell_NotifyIcon(NIM_DELETE, #TrayIconData);
end;
end;
end;
finally
VirtualFreeEx(ProcessID, ExplorerButtonInfo, Sizeof(TTBButton), MEM_RELEASE);
end;
end;
end.
MY application has had a mode for years where the customer can 'disable access to the OS'. Obviously this feature goes against the grain (at least as far as Windows is concerned) but there are installations where my App is the only program that should ever be visibile to a machine operator amd in this case such a feature is useful.
The technigue I used was built from several 'layers':
Hide the taskbar and button.
Disable task-switching.
Disable my main form system icons.
To disable the taskbar I used:
// Get a handle to the taskbar and its button..
Taskbar := FindWindow('Shell_TrayWnd', Nil);
StartButton := FindWindow('Button', Nil);
// Hide the taskbar and button
if Taskbar <> 0 then
ShowWindow( Taskbar, SW_HIDE );
if StartButton <> 0 then
ShowWindow( StartButton, SW_HIDE );
// Set the work area to the whole screen
R := Rect( 0,0,Screen.Width,Screen.Height );
SystemParametersInfo(
SPI_SETWORKAREA,
0,
#R,
0 );
This worked well and still seems fine on W7.
Researching how to disable task-switching some years ago turned up the only technique of 'pretending' that your App is a screen saver (other than terrible things like renaming your app to 'explorer.exe' and booting into it etc):
procedure EnableTaskSwitching( AState : boolean );
// Enables / disables task switching
begin
SystemParametersInfo(
SPI_SCREENSAVERRUNNING,
Cardinal( not AState),
nil,
0 );
end;
Not surprisingly this seems to have no effect in W7 (I think it works in XP etc).
Does anyone know of another, better, way of enabling / disabling Alt-Tab (and other special windows keys) from working?
If found a solution:
function LowLevelKeyboardProc(nCode: integer; wParam: WPARAM; lParam: LPARAM):
LRESULT; stdcall;
type
PKBDLLHOOKSTRUCT = ^TKBDLLHOOKSTRUCT;
TKBDLLHOOKSTRUCT = record
vkCode: cardinal;
scanCode: cardinal;
flags: cardinal;
time: cardinal;
dwExtraInfo: Cardinal;
end;
PKeyboardLowLevelHookStruct = ^TKeyboardLowLevelHookStruct;
TKeyboardLowLevelHookStruct = TKBDLLHOOKSTRUCT;
const
LLKHF_ALTDOWN = $20;
var
hs: PKeyboardLowLevelHookStruct;
ctrlDown: boolean;
begin
if nCode = HC_ACTION then
begin
hs := PKeyboardLowLevelHookStruct(lParam);
ctrlDown := GetAsyncKeyState(VK_CONTROL) and $8000 <> 0;
if (hs^.vkCode = VK_ESCAPE) and ctrlDown then
Exit(1);
if (hs^.vkCode = VK_TAB) and ((hs^.flags and LLKHF_ALTDOWN) <> 0) then
Exit(1);
if (hs^.vkCode = VK_ESCAPE) and ((hs^.flags and LLKHF_ALTDOWN) <> 0) then
Exit(1);
if (hs^.vkCode = VK_LWIN) or (hs^.vkCode = VK_RWIN) then
Exit(1);
end;
result := CallNextHookEx(0, nCode, wParam, lParam);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
SetWindowsHookEx(WH_KEYBOARD_LL, #LowLevelKeyboardProc, 0, 0);
end;
This disables (as you can see!)
Ctrl+Esc (show start menu)
Alt+Tab (task switch)
Alt+Esc (task switch)
Win (show start menu)
Win+Tab (3D task switch)
Win+D, Win+M, Win+Space, Win+Arrows, Win+P, Win+U, Win+E, Win+F, Win+Digit, ...
Almost any combination including the Windows key (but not all, e.g. Win+L)
As David has pointed out, this is called "Kiosk Mode". A couple of good articles (part 1 and part 2) can be found on About.com.
There is Windows Embedded Standard 7 that you can package in a way that has a true kiosk mode.
dWinLock also provides a solution. IIRC, they install a service that can stop Ctrl+Alt+Del.
How can I find the Screen-relative position of a Window Handle in Delphi? (X,Y)
Use FindWindow() to retrieve the handle of the window and and GetWindowRect() to get the coordinates:
var
NotepadHandle: hwnd;
WindowRect: TRect;
begin
NotepadHandle := FindWindow(nil, 'Untitled - Notepad');
if NotepadHandle <> 0 then
GetWindowRect(NotepadHandle, WindowRect)
end;
try using the GetWindowRect function
var
lpRect: TRect;
begin
GetWindowRect(Edit1.Handle,lpRect);
ShowMessage(Format('%d,%d',[lpRect.Left,lpRect.Top]));
end;
keep in mind, if the window(app) is minimized, you will get some values for the Rect like these (-32000, -32000, -31840, -31972, (-32000, -32000), (-31840, -31972))
I have multiple cursors (which are actually forms) that can be controlled by their respective mouse. (1 cursor for 1 user).
I use SetCursorPos to position the default cursor (the original system cursor) in a position that will not take away the focus from my application, and use ShowCursor(false) to hide it.
I have a class that gets the handle of the mouse and the coordinates.
When the user clicks I use the SetCursorPos and the mouse_event to simulate the clicks in that particular position.
My simulated mouse clicks only work on certain components' OnClick event (It was supposed to be only buttons and labels, but I experimented with the stuff on my project just to know what will or won't work):
It works on:
Buttons (TButton, TBitBtn, TAdvSmoothButton)
TAdvGrid
TMenuItem (but the direct child of the TMainMenu only)
TRadioButton
It doesn't work on:
TLabel
Panels (TPanel, TAdvSmoothPanel)
TCoolBar
TMenuItem (not direct child of TMainMenu)
This is my code:
SetCursorPos(currentX , currentY);
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
Why doesn't it work on some components? Is there a workaround (because I would like to be able to click labels using mouse_event).
EDIT:
I tried checking if the clicking function was really called, so I put ShowMessage('clicked'); before the SetCursorPos and mouse_event...but strangely everything (minor edit: everything except MenuItems) works fine now (except for the fact that I have a Message popping out everytime I try to click something). Does anybody have an idea why this behaves that way?
mouse_event is actually deprecated, you should use SendInput instead, see if that fixes anything (I would also suggest making the mouse move an input message, over using SetCursorPos), also, if your doing this for a specific application, PostMessage might be a much better and simpler alternative
Seems to work here;
procedure TForm1.Panel1Click(Sender: TObject);
begin
ShowMessage('Click');
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Pt: TPoint;
begin
Pt := Panel1.ClientToScreen(Point(0, 0));
SetCursorPos(Pt.x, Pt.y);
// SetCursorPos(Panel1.ClientOrigin.x, Panel1.ClientOrigin.y);
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
end;
or, without SetCursorPos;
procedure TForm1.Button1Click(Sender: TObject);
var
Pt: TPoint;
begin
Pt := Panel1.ClientToScreen(Point(0, 0));
Pt.x := Round(((Pt.x + 1) * 65535) / Screen.Width);
Pt.y := Round(((Pt.y + 1) * 65535) / Screen.Height);
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE or MOUSEEVENTF_LEFTDOWN,
Pt.x, Pt.y, 0, 0);
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE or MOUSEEVENTF_LEFTUP,
Pt.x, Pt.y, 0, 0);
end;
It works by accident right now, those components have probably captured the mouse. You need to pass the mouse pointer coordinates in the 2nd and 3rd arguments. Thus:
//SetCursorPos(currentX , currentY);
mouse_event(MOUSEEVENTF_LEFTDOWN, currentX, currentY, 0, 0);
mouse_event(MOUSEEVENTF_LEFTUP, currentX, currentY, 0, 0);