You've already forked CEF4Delphi
mirror of
https://github.com/salvadordf/CEF4Delphi.git
synced 2025-08-24 21:49:02 +02:00
Added KioskBrowser for Lazarus
Fixed issue #565: TTouchKeyboard doesn't work in the KioskBrowser demo while running in Windows 11
This commit is contained in:
Salvador Díaz Fau
@@ -9,7 +9,8 @@ uses
|
||||
Forms,
|
||||
{$ENDIF }
|
||||
uCEFApplication,
|
||||
uKioskBrowser in 'uKioskBrowser.pas' {Form1};
|
||||
uKioskBrowser in 'uKioskBrowser.pas' {Form1},
|
||||
uVirtualTouchKeyboard in 'uVirtualTouchKeyboard.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
@@ -33,7 +34,7 @@ begin
|
||||
Application.MainFormOnTaskbar := True;
|
||||
{$ENDIF}
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
Application.Run;
|
||||
end;
|
||||
|
||||
DestroyGlobalCEFApp;
|
||||
|
||||
@@ -139,6 +139,7 @@
|
||||
<DCCReference Include="uKioskBrowser.pas">
|
||||
<Form>Form1</Form>
|
||||
</DCCReference>
|
||||
<DCCReference Include="uVirtualTouchKeyboard.pas"/>
|
||||
<BuildConfiguration Include="Base">
|
||||
<Key>Base</Key>
|
||||
</BuildConfiguration>
|
||||
@@ -165,6 +166,12 @@
|
||||
</Excluded_Packages>
|
||||
</Delphi.Personality>
|
||||
<Deployment Version="5">
|
||||
<DeployFile LocalName="..\..\..\bin\KioskBrowser.exe" Configuration="Debug" Class="ProjectOutput">
|
||||
<Platform Name="Win32">
|
||||
<RemoteName>KioskBrowser.exe</RemoteName>
|
||||
<Overwrite>true</Overwrite>
|
||||
</Platform>
|
||||
</DeployFile>
|
||||
<DeployFile LocalName="..\..\bin\KioskBrowser.exe" Configuration="Debug" Class="ProjectOutput"/>
|
||||
<DeployFile LocalName="Win32\Debug\SimpleBrowser.exe" Configuration="Debug" Class="ProjectOutput"/>
|
||||
<DeployClass Name="AdditionalDebugSymbols">
|
||||
|
||||
@@ -15,28 +15,18 @@ object Form1: TForm1
|
||||
Visible = True
|
||||
OnCloseQuery = FormCloseQuery
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
OnShow = FormShow
|
||||
TextHeight = 13
|
||||
object CEFWindowParent1: TCEFWindowParent
|
||||
Left = 0
|
||||
Top = 0
|
||||
Width = 1038
|
||||
Height = 444
|
||||
Height = 624
|
||||
Align = alClient
|
||||
TabStop = True
|
||||
TabOrder = 0
|
||||
end
|
||||
object TouchKeyboard1: TTouchKeyboard
|
||||
Left = 0
|
||||
Top = 444
|
||||
Width = 1038
|
||||
Height = 180
|
||||
Align = alBottom
|
||||
GradientEnd = clSilver
|
||||
GradientStart = clGray
|
||||
Layout = 'Standard'
|
||||
Visible = False
|
||||
end
|
||||
object Timer1: TTimer
|
||||
Enabled = False
|
||||
Interval = 300
|
||||
|
||||
@@ -5,15 +5,11 @@ unit uKioskBrowser;
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF DELPHI16_UP}
|
||||
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
|
||||
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls,
|
||||
{$ELSE}
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics,
|
||||
Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
|
||||
{$ENDIF}
|
||||
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
|
||||
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
|
||||
Vcl.StdCtrls, Vcl.ExtCtrls,
|
||||
uCEFChromium, uCEFWindowParent, uCEFInterfaces, uCEFConstants, uCEFTypes,
|
||||
uCEFWinControl, uCEFChromiumCore, Vcl.Touch.Keyboard;
|
||||
uCEFWinControl, uCEFChromiumCore, uVirtualTouchKeyboard;
|
||||
|
||||
const
|
||||
HOMEPAGE_URL = 'https://www.google.com';
|
||||
@@ -33,12 +29,12 @@ type
|
||||
Timer1: TTimer;
|
||||
Chromium1: TChromium;
|
||||
CEFWindowParent1: TCEFWindowParent;
|
||||
TouchKeyboard1: TTouchKeyboard;
|
||||
|
||||
procedure Timer1Timer(Sender: TObject);
|
||||
|
||||
procedure FormShow(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
|
||||
procedure Chromium1AfterCreated(Sender: TObject; const browser: ICefBrowser);
|
||||
@@ -57,6 +53,8 @@ type
|
||||
FCanClose : boolean; // Set to True in TChromium.OnBeforeClose
|
||||
FClosing : boolean; // Set to True in the CloseQuery event.
|
||||
|
||||
FVirtualTouchKeyboard : TVirtualTouchKeyboard;
|
||||
|
||||
procedure HandleKeyUp(const aMsg : TMsg; var aHandled : boolean);
|
||||
procedure HandleKeyDown(const aMsg : TMsg; var aHandled : boolean);
|
||||
|
||||
@@ -164,6 +162,7 @@ begin
|
||||
GlobalCEFApp.RootCache := 'RootCache';
|
||||
GlobalCEFApp.EnablePrintPreview := True;
|
||||
GlobalCEFApp.TouchEvents := STATE_ENABLED;
|
||||
GlobalCEFApp.AddCustomCommandLine('--kiosk');
|
||||
GlobalCEFApp.EnableGPU := True;
|
||||
{$IFDEF DEBUG}
|
||||
GlobalCEFApp.LogFile := 'debug.log';
|
||||
@@ -201,13 +200,19 @@ begin
|
||||
FCanClose := False;
|
||||
FClosing := False;
|
||||
Chromium1.DefaultURL := HOMEPAGE_URL;
|
||||
FVirtualTouchKeyboard := TVirtualTouchKeyboard.Create;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
FVirtualTouchKeyboard.Free;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormShow(Sender: TObject);
|
||||
begin
|
||||
// We use a normal form while debugging.
|
||||
{$IFNDEF DEBUG}
|
||||
self.Position := wsMaximized;
|
||||
self.WindowState := wsMaximized;
|
||||
{$ENDIF}
|
||||
|
||||
// You *MUST* call CreateBrowser to create and initialize the browser.
|
||||
@@ -238,7 +243,7 @@ procedure TForm1.Chromium1BeforeContextMenu(Sender: TObject;
|
||||
begin
|
||||
model.AddSeparator;
|
||||
|
||||
if TouchKeyboard1.Visible then
|
||||
if FVirtualTouchKeyboard.Visible then
|
||||
model.AddItem(KIOSKBROWSER_CONTEXTMENU_HIDEKEYBOARD, 'Hide virtual keyboard')
|
||||
else
|
||||
model.AddItem(KIOSKBROWSER_CONTEXTMENU_SHOWKEYBOARD, 'Show virtual keyboard');
|
||||
@@ -390,12 +395,12 @@ end;
|
||||
|
||||
procedure TForm1.ShowKeyboardMsg(var aMessage : TMessage);
|
||||
begin
|
||||
TouchKeyboard1.Visible := True;
|
||||
FVirtualTouchKeyboard.Show;
|
||||
end;
|
||||
|
||||
procedure TForm1.HideKeyboardMsg(var aMessage : TMessage);
|
||||
begin
|
||||
TouchKeyboard1.Visible := False;
|
||||
FVirtualTouchKeyboard.Hide;
|
||||
end;
|
||||
|
||||
procedure TForm1.FocusEnabledMsg(var aMessage : TMessage);
|
||||
|
||||
257
demos/Delphi_VCL/KioskBrowser/uVirtualTouchKeyboard.pas
Normal file
257
demos/Delphi_VCL/KioskBrowser/uVirtualTouchKeyboard.pas
Normal file
@@ -0,0 +1,257 @@
|
||||
unit uVirtualTouchKeyboard;
|
||||
|
||||
{$IFDEF FPC}{$MODE Delphi}{$ENDIF}
|
||||
|
||||
// This unit uses undocumented Windows interfaces!
|
||||
|
||||
// ITipInvocation, IInputHostManagerBroker and IImmersiveShellBroker are
|
||||
// available in Windows 8, 10 and 11 but the code in this unit works best in a
|
||||
// fully updated Windows 10 or 11 system.
|
||||
|
||||
// Some ITipInvocation code examples use alternative ways to detect when the
|
||||
// virtual keyboard is visible but the tests showed that using
|
||||
// IInputHostManagerBroker is much safer and easier.
|
||||
|
||||
// The code in this unit is a translation of these examples :
|
||||
// https://stackoverflow.com/questions/38774139/show-touch-keyboard-tabtip-exe-in-windows-10-anniversary-edition
|
||||
// https://fire-monkey.ru/topic/5621-%D1%81%D0%B5%D0%BD%D1%81%D0%BE%D1%80%D0%BD%D0%B0%D1%8F-%D0%BA%D0%BB%D0%B0%D0%B2%D0%B8%D0%B0%D1%82%D1%83%D1%80%D0%B0-windows/
|
||||
// https://stackoverflow.com/questions/50623154/c-sharp-wpf-windows-10-1803-touchkeyboard-unreliable-issue-prism-clickonce
|
||||
// https://github.com/TransposonY/GestureSign/blob/master/GestureSign.CorePlugins/TouchKeyboard/TouchKeyboard.cs
|
||||
// https://stackoverflow.com/questions/47187216/determine-if-windows-10-touch-keyboard-is-visible-or-hidden
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
Windows, Classes, SysUtils, SHFolder, ActiveX, ShellAPI, jwatlhelp32;
|
||||
{$ELSE}
|
||||
Winapi.Windows, System.Classes, System.SysUtils, Winapi.SHFolder,
|
||||
System.Threading, Winapi.ActiveX, Winapi.ShellAPI, Winapi.TlHelp32;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
const
|
||||
CLSID_UIHostNoLaunch : TGUID = '{4CE576FA-83DC-4F88-951C-9D0782B4E376}';
|
||||
IID_ITipInvocation : TGUID = '{37C994E7-432B-4834-A2F7-DCE1F13B834B}';
|
||||
|
||||
CLSID_ImmersiveShellBroker : TGUID = '{228826af-02e1-4226-a9e0-99a855e455a6}';
|
||||
IID_IImmersiveShellBroker : TGUID = '{9767060c-9476-42e2-8f7b-2f10fd13765c}';
|
||||
IID_IInputHostManagerBroker : TGUID = '{2166ee67-71df-4476-8394-0ced2ed05274}';
|
||||
|
||||
TABTIP_PROCNAME = 'TabTip.exe';
|
||||
|
||||
type
|
||||
TDisplayMode = type integer;
|
||||
|
||||
ITipInvocation = interface
|
||||
['{37C994E7-432B-4834-A2F7-DCE1F13B834B}']
|
||||
procedure Toggle(WND: HWND); safecall;
|
||||
end;
|
||||
|
||||
IInputHostManagerBroker = interface
|
||||
['{2166ee67-71df-4476-8394-0ced2ed05274}']
|
||||
procedure GetIhmLocation(out rect : TRect; out mode : TDisplayMode); safecall;
|
||||
end;
|
||||
|
||||
IImmersiveShellBroker = interface
|
||||
['{9767060c-9476-42e2-8f7b-2f10fd13765c}']
|
||||
procedure Dummy; safecall;
|
||||
function GetInputHostManagerBroker : IInputHostManagerBroker; safecall;
|
||||
end;
|
||||
|
||||
/// <summary>
|
||||
/// Implementation of the virtual touch keyboard available in Windows using
|
||||
/// the undocumented ITipInvocation, IInputHostManagerBroker and
|
||||
/// IImmersiveShellBroker interfaces.
|
||||
/// </summary>
|
||||
TVirtualTouchKeyboard = class
|
||||
protected
|
||||
function GetTabTipPath : string;
|
||||
function GetCommonProgramFilesPath : string;
|
||||
function GetVisible : boolean;
|
||||
function GetExecuting : boolean;
|
||||
|
||||
function ProcessExists(const aExeFileName : string) : Boolean;
|
||||
function GetIhmLocation(var aRect : TRect) : boolean;
|
||||
|
||||
property TabTipPath : string read GetTabTipPath;
|
||||
property CommonProgramFilesPath : string read GetCommonProgramFilesPath;
|
||||
|
||||
public
|
||||
/// <summary>
|
||||
/// Show the virtual keyboard. It opens TabTip.exe if it's not running.
|
||||
/// </summary>
|
||||
procedure Show;
|
||||
/// <summary>
|
||||
/// Hide the virtual keyboard.
|
||||
/// </summary>
|
||||
procedure Hide;
|
||||
/// <summary>
|
||||
/// Toggle virtual keyboard visibility.
|
||||
/// </summary>
|
||||
function Toggle : boolean;
|
||||
/// <summary>
|
||||
/// Execute TabTip.exe
|
||||
/// </summary>
|
||||
function ExecuteTabTip : boolean;
|
||||
/// <summary>
|
||||
/// Returns true if the virtual keyboard is visible.
|
||||
/// </summary>
|
||||
property Visible : boolean read GetVisible;
|
||||
/// <summary>
|
||||
/// Returns true if TabTip.exe is running.
|
||||
/// </summary>
|
||||
property Executing : boolean read GetExecuting;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
function TVirtualTouchKeyboard.GetTabTipPath : string;
|
||||
const
|
||||
TABTIP_SUBPATH = 'microsoft shared\ink\' + TABTIP_PROCNAME;
|
||||
begin
|
||||
Result := CommonProgramFilesPath + TABTIP_SUBPATH;
|
||||
|
||||
if not(FileExists(Result)) then
|
||||
begin
|
||||
Result := 'C:\Program Files\Common Files\' + TABTIP_SUBPATH;
|
||||
|
||||
if not(FileExists(Result)) then
|
||||
Result := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetCommonProgramFilesPath: string;
|
||||
var
|
||||
TempBuffer: array [0..pred(MAX_PATH)] of Char;
|
||||
begin
|
||||
FillChar(TempBuffer, MAX_PATH * SizeOf(Char), 0);
|
||||
|
||||
if succeeded(SHGetFolderPath(0, CSIDL_PROGRAM_FILES_COMMON, 0, 0, @TempBuffer[0])) then
|
||||
Result := IncludeTrailingPathDelimiter(TempBuffer)
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetVisible : boolean;
|
||||
var
|
||||
TempRect : TRect;
|
||||
begin
|
||||
Result := GetIhmLocation(TempRect) and (TempRect.Width > 0) and (TempRect.Height > 0);
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetExecuting : boolean;
|
||||
begin
|
||||
Result := ProcessExists(TABTIP_PROCNAME);
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.ProcessExists(const aExeFileName: string): Boolean;
|
||||
var
|
||||
TempHandle : THandle;
|
||||
TempProcess : TProcessEntry32;
|
||||
begin
|
||||
Result := False;
|
||||
TempHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
|
||||
|
||||
if (TempHandle <> INVALID_HANDLE_VALUE) then
|
||||
try
|
||||
ZeroMemory(@TempProcess, SizeOf(TProcessEntry32));
|
||||
TempProcess.dwSize := Sizeof(TProcessEntry32);
|
||||
|
||||
if Process32First(TempHandle, TempProcess) then
|
||||
repeat
|
||||
if (CompareText(ExtractFileName(TempProcess.szExeFile), aExeFileName) = 0) then
|
||||
begin
|
||||
Result := True;
|
||||
break;
|
||||
end;
|
||||
until not(Process32Next(TempHandle, TempProcess));
|
||||
finally
|
||||
CloseHandle(TempHandle);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.ExecuteTabTip : boolean;
|
||||
var
|
||||
TempPath : string;
|
||||
begin
|
||||
TempPath := TabTipPath;
|
||||
Result := (length(TempPath) > 0) and
|
||||
(ShellExecute(0, 'open', PChar(TempPath + #0), nil, nil, SW_SHOWNORMAL) > 32);
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.Toggle : boolean;
|
||||
var
|
||||
TempInvocation : ITipInvocation;
|
||||
TempResult : HRESULT;
|
||||
begin
|
||||
Result := False;
|
||||
TempResult := CoCreateInstance(CLSID_UIHostNoLaunch,
|
||||
nil,
|
||||
CLSCTX_INPROC_HANDLER or CLSCTX_LOCAL_SERVER,
|
||||
IID_ITipInvocation,
|
||||
TempInvocation);
|
||||
|
||||
if succeeded(TempResult) then
|
||||
begin
|
||||
TempInvocation.Toggle(GetDesktopWindow);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetIhmLocation(var aRect : TRect) : boolean;
|
||||
var
|
||||
TempShellBroker : IImmersiveShellBroker;
|
||||
TempMgrBroker : IInputHostManagerBroker;
|
||||
TempResult : HRESULT;
|
||||
TempRect : TRect;
|
||||
TempMode : TDisplayMode;
|
||||
begin
|
||||
Result := False;
|
||||
TempResult := CoCreateInstance(CLSID_ImmersiveShellBroker,
|
||||
nil,
|
||||
CLSCTX_INPROC_HANDLER or CLSCTX_LOCAL_SERVER,
|
||||
IID_IImmersiveShellBroker,
|
||||
TempShellBroker);
|
||||
|
||||
if succeeded(TempResult) then
|
||||
begin
|
||||
TempMgrBroker := TempShellBroker.GetInputHostManagerBroker;
|
||||
TempMgrBroker.GetIhmLocation(TempRect, TempMode);
|
||||
aRect := TempRect;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TVirtualTouchKeyboard.Show;
|
||||
begin
|
||||
if not(Visible) then
|
||||
begin
|
||||
if Executing then
|
||||
Toggle
|
||||
else
|
||||
if ExecuteTabTip then
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
sleep(500);
|
||||
Toggle;
|
||||
{$ELSE}
|
||||
TThread.ForceQueue(nil,
|
||||
procedure
|
||||
begin
|
||||
Toggle;
|
||||
end, 500);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TVirtualTouchKeyboard.Hide;
|
||||
begin
|
||||
if Visible then
|
||||
Toggle;
|
||||
end;
|
||||
|
||||
end.
|
||||
2
demos/Lazarus_Windows/KioskBrowser/00-Delete.bat
Normal file
2
demos/Lazarus_Windows/KioskBrowser/00-Delete.bat
Normal file
@@ -0,0 +1,2 @@
|
||||
rmdir /S /Q lib
|
||||
rmdir /S /Q backup
|
||||
1139
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.dproj
Normal file
1139
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.dproj
Normal file
File diff suppressed because it is too large
Load Diff
90
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.lpi
Normal file
90
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.lpi
Normal file
@@ -0,0 +1,90 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="12"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<Title Value="KioskBrowser"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
</General>
|
||||
<BuildModes>
|
||||
<Item Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<UseFileFilters Value="True"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
</RunParams>
|
||||
<RequiredPackages>
|
||||
<Item>
|
||||
<PackageName Value="CEF4Delphi_Lazarus"/>
|
||||
</Item>
|
||||
<Item>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item>
|
||||
</RequiredPackages>
|
||||
<Units>
|
||||
<Unit>
|
||||
<Filename Value="KioskBrowser.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="uKioskBrowser.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="uVirtualTouchKeyboard.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="..\..\..\bin\KioskBrowser"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<DebugInfoType Value="dsDwarf3"/>
|
||||
</Debugging>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CustomOptions Value="-dBorland -dVer150 -dDelphi7 -dCompiler6_Up -dPUREPASCAL"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions>
|
||||
<Item>
|
||||
<Name Value="EAbort"/>
|
||||
</Item>
|
||||
<Item>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item>
|
||||
<Item>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
39
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.lpr
Normal file
39
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.lpr
Normal file
@@ -0,0 +1,39 @@
|
||||
program KioskBrowser;
|
||||
|
||||
{$MODE Delphi}
|
||||
|
||||
{$I ..\..\..\source\cef.inc}
|
||||
|
||||
uses
|
||||
Forms, Interfaces,
|
||||
uCEFApplication,
|
||||
uKioskBrowser in 'uKioskBrowser.pas' {Form1},
|
||||
uVirtualTouchKeyboard in 'uVirtualTouchKeyboard.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
{$IFDEF WIN32}
|
||||
const
|
||||
IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020;
|
||||
// CEF needs to set the LARGEADDRESSAWARE ($20) flag which allows 32-bit processes to use up to 3GB of RAM.
|
||||
{$SetPEFlags IMAGE_FILE_LARGE_ADDRESS_AWARE}
|
||||
{$ENDIF}
|
||||
|
||||
begin
|
||||
CreateGlobalCEFApp;
|
||||
|
||||
// You *MUST* call GlobalCEFApp.StartMainProcess in a if..then clause
|
||||
// with the Application initialization inside the begin..end.
|
||||
// Read this https://www.briskbard.com/index.php?lang=en&pageid=cef
|
||||
if GlobalCEFApp.StartMainProcess then
|
||||
begin
|
||||
Application.Initialize;
|
||||
{$IFDEF DELPHI11_UP}
|
||||
Application.MainFormOnTaskbar := True;
|
||||
{$ENDIF}
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end;
|
||||
|
||||
DestroyGlobalCEFApp;
|
||||
end.
|
||||
BIN
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.res
Normal file
BIN
demos/Lazarus_Windows/KioskBrowser/KioskBrowser.res
Normal file
Binary file not shown.
50
demos/Lazarus_Windows/KioskBrowser/uKioskBrowser.lfm
Normal file
50
demos/Lazarus_Windows/KioskBrowser/uKioskBrowser.lfm
Normal file
@@ -0,0 +1,50 @@
|
||||
object Form1: TForm1
|
||||
Left = 0
|
||||
Height = 624
|
||||
Top = 0
|
||||
Width = 1038
|
||||
BorderStyle = bsSingle
|
||||
Caption = 'qwerty'
|
||||
ClientHeight = 624
|
||||
ClientWidth = 1038
|
||||
Color = clBtnFace
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Position = poDefault
|
||||
Visible = True
|
||||
OnCloseQuery = FormCloseQuery
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
OnShow = FormShow
|
||||
object CEFWindowParent1: TCEFWindowParent
|
||||
Left = 0
|
||||
Height = 624
|
||||
Top = 0
|
||||
Width = 1038
|
||||
Align = alClient
|
||||
TabStop = True
|
||||
TabOrder = 0
|
||||
end
|
||||
object Timer1: TTimer
|
||||
Enabled = False
|
||||
Interval = 300
|
||||
OnTimer = Timer1Timer
|
||||
Left = 56
|
||||
Top = 88
|
||||
end
|
||||
object Chromium1: TChromium
|
||||
OnCanFocus = Chromium1CanFocus
|
||||
OnProcessMessageReceived = Chromium1ProcessMessageReceived
|
||||
OnBeforeContextMenu = Chromium1BeforeContextMenu
|
||||
OnContextMenuCommand = Chromium1ContextMenuCommand
|
||||
OnPreKeyEvent = Chromium1PreKeyEvent
|
||||
OnKeyEvent = Chromium1KeyEvent
|
||||
OnBeforePopup = Chromium1BeforePopup
|
||||
OnAfterCreated = Chromium1AfterCreated
|
||||
OnBeforeClose = Chromium1BeforeClose
|
||||
OnOpenUrlFromTab = Chromium1OpenUrlFromTab
|
||||
Left = 56
|
||||
Top = 152
|
||||
end
|
||||
end
|
||||
444
demos/Lazarus_Windows/KioskBrowser/uKioskBrowser.pas
Normal file
444
demos/Lazarus_Windows/KioskBrowser/uKioskBrowser.pas
Normal file
@@ -0,0 +1,444 @@
|
||||
unit uKioskBrowser;
|
||||
|
||||
{$MODE Delphi}
|
||||
|
||||
{$I ..\..\..\source\cef.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics,
|
||||
Controls, Forms, Dialogs, StdCtrls, ExtCtrls,
|
||||
uCEFChromium, uCEFWindowParent, uCEFInterfaces, uCEFConstants, uCEFTypes,
|
||||
uCEFWinControl, uCEFChromiumCore, uVirtualTouchKeyboard;
|
||||
|
||||
const
|
||||
HOMEPAGE_URL = 'https://www.google.com';
|
||||
|
||||
SHOWKEYBOARD_PROCMSG = 'showkeyboard';
|
||||
HIDEKEYBOARD_PROCMSG = 'hidekeyboard';
|
||||
|
||||
CEF_SHOWKEYBOARD = WM_APP + $B01;
|
||||
CEF_HIDEKEYBOARD = WM_APP + $B02;
|
||||
|
||||
KIOSKBROWSER_CONTEXTMENU_EXIT = MENU_ID_USER_FIRST + 1;
|
||||
KIOSKBROWSER_CONTEXTMENU_HIDEKEYBOARD = MENU_ID_USER_FIRST + 2;
|
||||
KIOSKBROWSER_CONTEXTMENU_SHOWKEYBOARD = MENU_ID_USER_FIRST + 3;
|
||||
|
||||
type
|
||||
TForm1 = class(TForm)
|
||||
Timer1: TTimer;
|
||||
Chromium1: TChromium;
|
||||
CEFWindowParent1: TCEFWindowParent;
|
||||
|
||||
procedure Timer1Timer(Sender: TObject);
|
||||
|
||||
procedure FormShow(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
|
||||
procedure Chromium1AfterCreated(Sender: TObject; const browser: ICefBrowser);
|
||||
procedure Chromium1CanFocus(Sender: TObject);
|
||||
procedure Chromium1ContextMenuCommand(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; const params: ICefContextMenuParams; commandId: Integer; eventFlags: TCefEventFlags; out Result: Boolean);
|
||||
procedure Chromium1BeforeContextMenu(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; const params: ICefContextMenuParams; const model: ICefMenuModel);
|
||||
procedure Chromium1BeforeClose(Sender: TObject; const browser: ICefBrowser);
|
||||
procedure Chromium1BeforePopup(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; popup_id: Integer; const targetUrl, targetFrameName: ustring; targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean; const popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; var extra_info: ICefDictionaryValue; var noJavascriptAccess, Result: Boolean);
|
||||
procedure Chromium1KeyEvent(Sender: TObject; const browser: ICefBrowser; const event: PCefKeyEvent; osEvent: TCefEventHandle; out Result: Boolean);
|
||||
procedure Chromium1OpenUrlFromTab(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; const targetUrl: ustring; targetDisposition: TCefWindowOpenDisposition; userGesture: Boolean; out Result: Boolean);
|
||||
procedure Chromium1PreKeyEvent(Sender: TObject; const browser: ICefBrowser; const event: PCefKeyEvent; osEvent: TCefEventHandle; out isKeyboardShortcut, Result: Boolean);
|
||||
procedure Chromium1ProcessMessageReceived(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; sourceProcess: TCefProcessId; const message: ICefProcessMessage; out Result: Boolean);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
|
||||
protected
|
||||
// Variables to control when can we destroy the form safely
|
||||
FCanClose : boolean; // Set to True in TChromium.OnBeforeClose
|
||||
FClosing : boolean; // Set to True in the CloseQuery event.
|
||||
|
||||
FVirtualTouchKeyboard : TVirtualTouchKeyboard;
|
||||
|
||||
procedure HandleKeyUp(const aMsg : TMsg; var aHandled : boolean);
|
||||
procedure HandleKeyDown(const aMsg : TMsg; var aHandled : boolean);
|
||||
|
||||
procedure ShowKeyboardMsg(var aMessage : TMessage); message CEF_SHOWKEYBOARD;
|
||||
procedure HideKeyboardMsg(var aMessage : TMessage); message CEF_HIDEKEYBOARD;
|
||||
procedure FocusEnabledMsg(var aMessage : TMessage); message CEF_FOCUSENABLED;
|
||||
procedure BrowserCreatedMsg(var aMessage : TMessage); message CEF_AFTERCREATED;
|
||||
|
||||
// You have to handle this two messages to call NotifyMoveOrResizeStarted or some page elements will be misaligned.
|
||||
procedure WMMove(var aMessage : TWMMove); message WM_MOVE;
|
||||
procedure WMMoving(var aMessage : TMessage); message WM_MOVING;
|
||||
|
||||
// You also have to handle these two messages to set GlobalCEFApp.OsmodalLoop
|
||||
procedure WMEnterMenuLoop(var aMessage: TMessage); message WM_ENTERMENULOOP;
|
||||
procedure WMExitMenuLoop(var aMessage: TMessage); message WM_EXITMENULOOP;
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
procedure CreateGlobalCEFApp;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
uses
|
||||
uCEFApplication, uCEFMiscFunctions, uCEFProcessMessage;
|
||||
|
||||
// This is a simplified Kiosk browser using a virtual keyboard.
|
||||
// The default URL is defined in the HOMEPAGE_URL constant.
|
||||
|
||||
// To close this app press the ESC key or select the 'Exit' option in the context menu.
|
||||
|
||||
// This demo uses a TChromium and a TCEFWindowParent
|
||||
|
||||
// Destruction steps
|
||||
// =================
|
||||
// 1. FormCloseQuery sets CanClose to FALSE, destroys CEFWindowParent1 and calls TChromium.CloseBrowser which triggers the TChromium.OnBeforeClose event.
|
||||
// 2. TChromium.OnBeforeClose sets FCanClose := True and sends WM_CLOSE to the form.
|
||||
|
||||
function NodeIsTextArea(const aNode : ICefDomNode) : boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
|
||||
begin
|
||||
Result := (CompareText(aNode.ElementTagName, 'textarea') = 0);
|
||||
end;
|
||||
|
||||
function NodeIsInput(const aNode : ICefDomNode) : boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
|
||||
begin
|
||||
Result := (CompareText(aNode.ElementTagName, 'input') = 0);
|
||||
end;
|
||||
|
||||
function InputNeedsKeyboard(const aNode : ICefDomNode) : boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
|
||||
var
|
||||
TempType : string;
|
||||
begin
|
||||
if not(aNode.HasElementAttribute('type')) then
|
||||
Result := True
|
||||
else
|
||||
begin
|
||||
TempType := aNode.GetElementAttribute('type');
|
||||
Result := (CompareText(TempType, 'date') = 0) or
|
||||
(CompareText(TempType, 'datetime-local') = 0) or
|
||||
(CompareText(TempType, 'email') = 0) or
|
||||
(CompareText(TempType, 'month') = 0) or
|
||||
(CompareText(TempType, 'number') = 0) or
|
||||
(CompareText(TempType, 'password') = 0) or
|
||||
(CompareText(TempType, 'search') = 0) or
|
||||
(CompareText(TempType, 'tel') = 0) or
|
||||
(CompareText(TempType, 'text') = 0) or
|
||||
(CompareText(TempType, 'time') = 0) or
|
||||
(CompareText(TempType, 'url') = 0) or
|
||||
(CompareText(TempType, 'week') = 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function NodeNeedsKeyboard(const aNode : ICefDomNode) : boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
|
||||
begin
|
||||
Result := NodeIsTextArea(aNode) or
|
||||
(NodeIsInput(aNode) and InputNeedsKeyboard(aNode));
|
||||
end;
|
||||
|
||||
procedure GlobalCEFApp_OnFocusedNodeChanged(const browser: ICefBrowser; const frame: ICefFrame; const node: ICefDomNode);
|
||||
var
|
||||
TempMsg : ICefProcessMessage;
|
||||
begin
|
||||
if assigned(frame) and frame.IsValid then
|
||||
begin
|
||||
// This procedure is called in the Render process and checks if the focused node is an
|
||||
// INPUT or TEXTAREA to show or hide the virtual keyboard.
|
||||
// It sends a process message to the browser process to handle the virtual keyboard.
|
||||
if (node <> nil) and NodeNeedsKeyboard(node) then
|
||||
TempMsg := TCefProcessMessageRef.New(SHOWKEYBOARD_PROCMSG)
|
||||
else
|
||||
TempMsg := TCefProcessMessageRef.New(HIDEKEYBOARD_PROCMSG);
|
||||
|
||||
frame.SendProcessMessage(PID_BROWSER, TempMsg);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure CreateGlobalCEFApp;
|
||||
begin
|
||||
GlobalCEFApp := TCefApplication.Create;
|
||||
GlobalCEFApp.RootCache := 'RootCache';
|
||||
GlobalCEFApp.EnablePrintPreview := True;
|
||||
GlobalCEFApp.TouchEvents := STATE_ENABLED;
|
||||
GlobalCEFApp.AddCustomCommandLine('--kiosk');
|
||||
GlobalCEFApp.EnableGPU := True;
|
||||
{$IFDEF DEBUG}
|
||||
GlobalCEFApp.LogFile := 'debug.log';
|
||||
GlobalCEFApp.LogSeverity := LOGSEVERITY_INFO;
|
||||
{$ENDIF}
|
||||
GlobalCEFApp.OnFocusedNodeChanged := GlobalCEFApp_OnFocusedNodeChanged;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
begin
|
||||
CanClose := FCanClose;
|
||||
|
||||
if not(FClosing) then
|
||||
begin
|
||||
FClosing := True;
|
||||
Visible := False;
|
||||
Chromium1.CloseBrowser(True);
|
||||
CEFWindowParent1.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
// We use a normal form while debugging.
|
||||
{$IFNDEF DEBUG}
|
||||
BorderIcons := [];
|
||||
BorderStyle := bsNone;
|
||||
BorderWidth := 0;
|
||||
Caption := '';
|
||||
{$ENDIF}
|
||||
FCanClose := False;
|
||||
FClosing := False;
|
||||
Chromium1.DefaultURL := HOMEPAGE_URL;
|
||||
FVirtualTouchKeyboard := TVirtualTouchKeyboard.Create;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
FVirtualTouchKeyboard.Free;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormShow(Sender: TObject);
|
||||
begin
|
||||
// We use a normal form while debugging.
|
||||
{$IFNDEF DEBUG}
|
||||
self.WindowState := wsMaximized;
|
||||
{$ENDIF}
|
||||
|
||||
// You *MUST* call CreateBrowser to create and initialize the browser.
|
||||
// This will trigger the AfterCreated event when the browser is fully
|
||||
// initialized and ready to receive commands.
|
||||
|
||||
// GlobalCEFApp.GlobalContextInitialized has to be TRUE before creating any browser
|
||||
// If it's not initialized yet, we use a simple timer to create the browser later.
|
||||
if not(Chromium1.CreateBrowser(CEFWindowParent1)) then Timer1.Enabled := True;
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1AfterCreated(Sender: TObject;
|
||||
const browser: ICefBrowser);
|
||||
begin
|
||||
PostMessage(Handle, CEF_AFTERCREATED, 0, 0);
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1BeforeClose(Sender: TObject;
|
||||
const browser: ICefBrowser);
|
||||
begin
|
||||
FCanClose := True;
|
||||
PostMessage(Handle, WM_CLOSE, 0, 0);
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1BeforeContextMenu(Sender: TObject;
|
||||
const browser: ICefBrowser; const frame: ICefFrame;
|
||||
const params: ICefContextMenuParams; const model: ICefMenuModel);
|
||||
begin
|
||||
model.AddSeparator;
|
||||
|
||||
if FVirtualTouchKeyboard.Visible then
|
||||
model.AddItem(KIOSKBROWSER_CONTEXTMENU_HIDEKEYBOARD, 'Hide virtual keyboard')
|
||||
else
|
||||
model.AddItem(KIOSKBROWSER_CONTEXTMENU_SHOWKEYBOARD, 'Show virtual keyboard');
|
||||
|
||||
model.AddSeparator;
|
||||
model.AddItem(KIOSKBROWSER_CONTEXTMENU_EXIT, 'Exit');
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1CanFocus(Sender: TObject);
|
||||
begin
|
||||
// The browser required some time to create associated internal objects
|
||||
// before being able to accept the focus. Now we can set the focus on the
|
||||
// TBufferPanel control
|
||||
PostMessage(Handle, CEF_FOCUSENABLED, 0, 0);
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1ContextMenuCommand(Sender: TObject;
|
||||
const browser: ICefBrowser; const frame: ICefFrame;
|
||||
const params: ICefContextMenuParams; commandId: Integer;
|
||||
eventFlags: TCefEventFlags; out Result: Boolean);
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
case commandId of
|
||||
KIOSKBROWSER_CONTEXTMENU_EXIT : PostMessage(Handle, WM_CLOSE, 0, 0);
|
||||
KIOSKBROWSER_CONTEXTMENU_HIDEKEYBOARD : PostMessage(Handle, CEF_HIDEKEYBOARD, 0, 0);
|
||||
KIOSKBROWSER_CONTEXTMENU_SHOWKEYBOARD : PostMessage(Handle, CEF_SHOWKEYBOARD, 0, 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1KeyEvent(Sender: TObject; const browser: ICefBrowser;
|
||||
const event: PCefKeyEvent; osEvent: TCefEventHandle; out Result: Boolean);
|
||||
var
|
||||
TempMsg : TMsg;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
if (event <> nil) and (osEvent <> nil) then
|
||||
case osEvent.Message of
|
||||
WM_KEYUP :
|
||||
begin
|
||||
TempMsg := osEvent^;
|
||||
|
||||
HandleKeyUp(TempMsg, Result);
|
||||
end;
|
||||
|
||||
WM_KEYDOWN :
|
||||
begin
|
||||
TempMsg := osEvent^;
|
||||
|
||||
HandleKeyDown(TempMsg, Result);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1BeforePopup(Sender: TObject;
|
||||
const browser: ICefBrowser; const frame: ICefFrame; popup_id: Integer;
|
||||
const targetUrl, targetFrameName: ustring; targetDisposition: TCefWindowOpenDisposition;
|
||||
userGesture: Boolean; const popupFeatures: TCefPopupFeatures;
|
||||
var windowInfo: TCefWindowInfo; var client: ICefClient;
|
||||
var settings: TCefBrowserSettings; var extra_info: ICefDictionaryValue;
|
||||
var noJavascriptAccess, Result: Boolean);
|
||||
begin
|
||||
// For simplicity, this demo blocks all popup windows and new tabs
|
||||
Result := (targetDisposition in [CEF_WOD_NEW_FOREGROUND_TAB, CEF_WOD_NEW_BACKGROUND_TAB, CEF_WOD_NEW_POPUP, CEF_WOD_NEW_WINDOW]);
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1OpenUrlFromTab(Sender: TObject;
|
||||
const browser: ICefBrowser; const frame: ICefFrame;
|
||||
const targetUrl: ustring; targetDisposition: TCefWindowOpenDisposition;
|
||||
userGesture: Boolean; out Result: Boolean);
|
||||
begin
|
||||
// For simplicity, this demo blocks all popup windows and new tabs
|
||||
Result := (targetDisposition in [CEF_WOD_NEW_FOREGROUND_TAB, CEF_WOD_NEW_BACKGROUND_TAB, CEF_WOD_NEW_POPUP, CEF_WOD_NEW_WINDOW]);
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1PreKeyEvent(Sender: TObject;
|
||||
const browser: ICefBrowser; const event: PCefKeyEvent;
|
||||
osEvent: TCefEventHandle; out isKeyboardShortcut, Result: Boolean);
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
if (event <> nil) and
|
||||
(event.kind in [KEYEVENT_KEYDOWN, KEYEVENT_KEYUP]) and
|
||||
(event.windows_key_code = VK_ESCAPE) then
|
||||
isKeyboardShortcut := True;
|
||||
end;
|
||||
|
||||
procedure TForm1.Chromium1ProcessMessageReceived(Sender: TObject;
|
||||
const browser: ICefBrowser; const frame: ICefFrame;
|
||||
sourceProcess: TCefProcessId; const message: ICefProcessMessage;
|
||||
out Result: Boolean);
|
||||
begin
|
||||
// This function receives the process message from the render process to show or hide the virtual keyboard.
|
||||
// This event is not executed in the main thread so it has to send a custom windows message to the form
|
||||
// to handle the keyboard in the main thread.
|
||||
|
||||
if (message.Name = SHOWKEYBOARD_PROCMSG) then
|
||||
begin
|
||||
PostMessage(Handle, CEF_SHOWKEYBOARD, 0 ,0);
|
||||
Result := True;
|
||||
end
|
||||
else
|
||||
if (message.Name = HIDEKEYBOARD_PROCMSG) then
|
||||
begin
|
||||
PostMessage(Handle, CEF_HIDEKEYBOARD, 0 ,0);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.Timer1Timer(Sender: TObject);
|
||||
begin
|
||||
Timer1.Enabled := False;
|
||||
if not(Chromium1.CreateBrowser(CEFWindowParent1)) and not(Chromium1.Initialized) then
|
||||
Timer1.Enabled := True;
|
||||
end;
|
||||
|
||||
procedure TForm1.WMMove(var aMessage : TWMMove);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (Chromium1 <> nil) then
|
||||
Chromium1.NotifyMoveOrResizeStarted;
|
||||
end;
|
||||
|
||||
procedure TForm1.WMMoving(var aMessage : TMessage);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (Chromium1 <> nil) then
|
||||
Chromium1.NotifyMoveOrResizeStarted;
|
||||
end;
|
||||
|
||||
procedure TForm1.WMEnterMenuLoop(var aMessage: TMessage);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (aMessage.wParam = 0) and (GlobalCEFApp <> nil) then
|
||||
GlobalCEFApp.OsmodalLoop := True;
|
||||
end;
|
||||
|
||||
procedure TForm1.WMExitMenuLoop(var aMessage: TMessage);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if (aMessage.wParam = 0) and (GlobalCEFApp <> nil) then
|
||||
GlobalCEFApp.OsmodalLoop := False;
|
||||
end;
|
||||
|
||||
procedure TForm1.ShowKeyboardMsg(var aMessage : TMessage);
|
||||
begin
|
||||
FVirtualTouchKeyboard.Show;
|
||||
end;
|
||||
|
||||
procedure TForm1.HideKeyboardMsg(var aMessage : TMessage);
|
||||
begin
|
||||
FVirtualTouchKeyboard.Hide;
|
||||
end;
|
||||
|
||||
procedure TForm1.FocusEnabledMsg(var aMessage : TMessage);
|
||||
begin
|
||||
Chromium1.SetFocus(True);
|
||||
end;
|
||||
|
||||
procedure TForm1.BrowserCreatedMsg(var aMessage : TMessage);
|
||||
begin
|
||||
CEFWindowParent1.UpdateSize;
|
||||
end;
|
||||
|
||||
procedure TForm1.HandleKeyUp(const aMsg : TMsg; var aHandled : boolean);
|
||||
var
|
||||
TempMessage : TMessage;
|
||||
TempKeyMsg : TWMKey;
|
||||
begin
|
||||
TempMessage.Msg := aMsg.message;
|
||||
TempMessage.wParam := aMsg.wParam;
|
||||
TempMessage.lParam := aMsg.lParam;
|
||||
TempKeyMsg := TWMKey(TempMessage);
|
||||
|
||||
if (TempKeyMsg.CharCode = VK_ESCAPE) then
|
||||
begin
|
||||
aHandled := True;
|
||||
|
||||
PostMessage(Handle, WM_CLOSE, 0, 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.HandleKeyDown(const aMsg : TMsg; var aHandled : boolean);
|
||||
var
|
||||
TempMessage : TMessage;
|
||||
TempKeyMsg : TWMKey;
|
||||
begin
|
||||
TempMessage.Msg := aMsg.message;
|
||||
TempMessage.wParam := aMsg.wParam;
|
||||
TempMessage.lParam := aMsg.lParam;
|
||||
TempKeyMsg := TWMKey(TempMessage);
|
||||
|
||||
if (TempKeyMsg.CharCode = VK_ESCAPE) then aHandled := True;
|
||||
end;
|
||||
|
||||
end.
|
||||
257
demos/Lazarus_Windows/KioskBrowser/uVirtualTouchKeyboard.pas
Normal file
257
demos/Lazarus_Windows/KioskBrowser/uVirtualTouchKeyboard.pas
Normal file
@@ -0,0 +1,257 @@
|
||||
unit uVirtualTouchKeyboard;
|
||||
|
||||
{$IFDEF FPC}{$MODE Delphi}{$ENDIF}
|
||||
|
||||
// This unit uses undocumented Windows interfaces!
|
||||
|
||||
// ITipInvocation, IInputHostManagerBroker and IImmersiveShellBroker are
|
||||
// available in Windows 8, 10 and 11 but the code in this unit works best in a
|
||||
// fully updated Windows 10 or 11 system.
|
||||
|
||||
// Some ITipInvocation code examples use alternative ways to detect when the
|
||||
// virtual keyboard is visible but the tests showed that using
|
||||
// IInputHostManagerBroker is much safer and easier.
|
||||
|
||||
// The code in this unit is a translation of these examples :
|
||||
// https://stackoverflow.com/questions/38774139/show-touch-keyboard-tabtip-exe-in-windows-10-anniversary-edition
|
||||
// https://fire-monkey.ru/topic/5621-%D1%81%D0%B5%D0%BD%D1%81%D0%BE%D1%80%D0%BD%D0%B0%D1%8F-%D0%BA%D0%BB%D0%B0%D0%B2%D0%B8%D0%B0%D1%82%D1%83%D1%80%D0%B0-windows/
|
||||
// https://stackoverflow.com/questions/50623154/c-sharp-wpf-windows-10-1803-touchkeyboard-unreliable-issue-prism-clickonce
|
||||
// https://github.com/TransposonY/GestureSign/blob/master/GestureSign.CorePlugins/TouchKeyboard/TouchKeyboard.cs
|
||||
// https://stackoverflow.com/questions/47187216/determine-if-windows-10-touch-keyboard-is-visible-or-hidden
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
Windows, Classes, SysUtils, SHFolder, ActiveX, ShellAPI, jwatlhelp32;
|
||||
{$ELSE}
|
||||
Winapi.Windows, System.Classes, System.SysUtils, Winapi.SHFolder,
|
||||
System.Threading, Winapi.ActiveX, Winapi.ShellAPI, Winapi.TlHelp32;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
const
|
||||
CLSID_UIHostNoLaunch : TGUID = '{4CE576FA-83DC-4F88-951C-9D0782B4E376}';
|
||||
IID_ITipInvocation : TGUID = '{37C994E7-432B-4834-A2F7-DCE1F13B834B}';
|
||||
|
||||
CLSID_ImmersiveShellBroker : TGUID = '{228826af-02e1-4226-a9e0-99a855e455a6}';
|
||||
IID_IImmersiveShellBroker : TGUID = '{9767060c-9476-42e2-8f7b-2f10fd13765c}';
|
||||
IID_IInputHostManagerBroker : TGUID = '{2166ee67-71df-4476-8394-0ced2ed05274}';
|
||||
|
||||
TABTIP_PROCNAME = 'TabTip.exe';
|
||||
|
||||
type
|
||||
TDisplayMode = type integer;
|
||||
|
||||
ITipInvocation = interface
|
||||
['{37C994E7-432B-4834-A2F7-DCE1F13B834B}']
|
||||
procedure Toggle(WND: HWND); safecall;
|
||||
end;
|
||||
|
||||
IInputHostManagerBroker = interface
|
||||
['{2166ee67-71df-4476-8394-0ced2ed05274}']
|
||||
procedure GetIhmLocation(out rect : TRect; out mode : TDisplayMode); safecall;
|
||||
end;
|
||||
|
||||
IImmersiveShellBroker = interface
|
||||
['{9767060c-9476-42e2-8f7b-2f10fd13765c}']
|
||||
procedure Dummy; safecall;
|
||||
function GetInputHostManagerBroker : IInputHostManagerBroker; safecall;
|
||||
end;
|
||||
|
||||
/// <summary>
|
||||
/// Implementation of the virtual touch keyboard available in Windows using
|
||||
/// the undocumented ITipInvocation, IInputHostManagerBroker and
|
||||
/// IImmersiveShellBroker interfaces.
|
||||
/// </summary>
|
||||
TVirtualTouchKeyboard = class
|
||||
protected
|
||||
function GetTabTipPath : string;
|
||||
function GetCommonProgramFilesPath : string;
|
||||
function GetVisible : boolean;
|
||||
function GetExecuting : boolean;
|
||||
|
||||
function ProcessExists(const aExeFileName : string) : Boolean;
|
||||
function GetIhmLocation(var aRect : TRect) : boolean;
|
||||
|
||||
property TabTipPath : string read GetTabTipPath;
|
||||
property CommonProgramFilesPath : string read GetCommonProgramFilesPath;
|
||||
|
||||
public
|
||||
/// <summary>
|
||||
/// Show the virtual keyboard. It opens TabTip.exe if it's not running.
|
||||
/// </summary>
|
||||
procedure Show;
|
||||
/// <summary>
|
||||
/// Hide the virtual keyboard.
|
||||
/// </summary>
|
||||
procedure Hide;
|
||||
/// <summary>
|
||||
/// Toggle virtual keyboard visibility.
|
||||
/// </summary>
|
||||
function Toggle : boolean;
|
||||
/// <summary>
|
||||
/// Execute TabTip.exe
|
||||
/// </summary>
|
||||
function ExecuteTabTip : boolean;
|
||||
/// <summary>
|
||||
/// Returns true if the virtual keyboard is visible.
|
||||
/// </summary>
|
||||
property Visible : boolean read GetVisible;
|
||||
/// <summary>
|
||||
/// Returns true if TabTip.exe is running.
|
||||
/// </summary>
|
||||
property Executing : boolean read GetExecuting;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
function TVirtualTouchKeyboard.GetTabTipPath : string;
|
||||
const
|
||||
TABTIP_SUBPATH = 'microsoft shared\ink\' + TABTIP_PROCNAME;
|
||||
begin
|
||||
Result := CommonProgramFilesPath + TABTIP_SUBPATH;
|
||||
|
||||
if not(FileExists(Result)) then
|
||||
begin
|
||||
Result := 'C:\Program Files\Common Files\' + TABTIP_SUBPATH;
|
||||
|
||||
if not(FileExists(Result)) then
|
||||
Result := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetCommonProgramFilesPath: string;
|
||||
var
|
||||
TempBuffer: array [0..pred(MAX_PATH)] of Char;
|
||||
begin
|
||||
FillChar(TempBuffer, MAX_PATH * SizeOf(Char), 0);
|
||||
|
||||
if succeeded(SHGetFolderPath(0, CSIDL_PROGRAM_FILES_COMMON, 0, 0, @TempBuffer[0])) then
|
||||
Result := IncludeTrailingPathDelimiter(TempBuffer)
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetVisible : boolean;
|
||||
var
|
||||
TempRect : TRect;
|
||||
begin
|
||||
Result := GetIhmLocation(TempRect) and (TempRect.Width > 0) and (TempRect.Height > 0);
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetExecuting : boolean;
|
||||
begin
|
||||
Result := ProcessExists(TABTIP_PROCNAME);
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.ProcessExists(const aExeFileName: string): Boolean;
|
||||
var
|
||||
TempHandle : THandle;
|
||||
TempProcess : TProcessEntry32;
|
||||
begin
|
||||
Result := False;
|
||||
TempHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
|
||||
|
||||
if (TempHandle <> INVALID_HANDLE_VALUE) then
|
||||
try
|
||||
ZeroMemory(@TempProcess, SizeOf(TProcessEntry32));
|
||||
TempProcess.dwSize := Sizeof(TProcessEntry32);
|
||||
|
||||
if Process32First(TempHandle, TempProcess) then
|
||||
repeat
|
||||
if (CompareText(ExtractFileName(TempProcess.szExeFile), aExeFileName) = 0) then
|
||||
begin
|
||||
Result := True;
|
||||
break;
|
||||
end;
|
||||
until not(Process32Next(TempHandle, TempProcess));
|
||||
finally
|
||||
CloseHandle(TempHandle);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.ExecuteTabTip : boolean;
|
||||
var
|
||||
TempPath : string;
|
||||
begin
|
||||
TempPath := TabTipPath;
|
||||
Result := (length(TempPath) > 0) and
|
||||
(ShellExecute(0, 'open', PChar(TempPath + #0), nil, nil, SW_SHOWNORMAL) > 32);
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.Toggle : boolean;
|
||||
var
|
||||
TempInvocation : ITipInvocation;
|
||||
TempResult : HRESULT;
|
||||
begin
|
||||
Result := False;
|
||||
TempResult := CoCreateInstance(CLSID_UIHostNoLaunch,
|
||||
nil,
|
||||
CLSCTX_INPROC_HANDLER or CLSCTX_LOCAL_SERVER,
|
||||
IID_ITipInvocation,
|
||||
TempInvocation);
|
||||
|
||||
if succeeded(TempResult) then
|
||||
begin
|
||||
TempInvocation.Toggle(GetDesktopWindow);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TVirtualTouchKeyboard.GetIhmLocation(var aRect : TRect) : boolean;
|
||||
var
|
||||
TempShellBroker : IImmersiveShellBroker;
|
||||
TempMgrBroker : IInputHostManagerBroker;
|
||||
TempResult : HRESULT;
|
||||
TempRect : TRect;
|
||||
TempMode : TDisplayMode;
|
||||
begin
|
||||
Result := False;
|
||||
TempResult := CoCreateInstance(CLSID_ImmersiveShellBroker,
|
||||
nil,
|
||||
CLSCTX_INPROC_HANDLER or CLSCTX_LOCAL_SERVER,
|
||||
IID_IImmersiveShellBroker,
|
||||
TempShellBroker);
|
||||
|
||||
if succeeded(TempResult) then
|
||||
begin
|
||||
TempMgrBroker := TempShellBroker.GetInputHostManagerBroker;
|
||||
TempMgrBroker.GetIhmLocation(TempRect, TempMode);
|
||||
aRect := TempRect;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TVirtualTouchKeyboard.Show;
|
||||
begin
|
||||
if not(Visible) then
|
||||
begin
|
||||
if Executing then
|
||||
Toggle
|
||||
else
|
||||
if ExecuteTabTip then
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
sleep(500);
|
||||
Toggle;
|
||||
{$ELSE}
|
||||
TThread.ForceQueue(nil,
|
||||
procedure
|
||||
begin
|
||||
Toggle;
|
||||
end, 500);
|
||||
{$ENDIF}
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TVirtualTouchKeyboard.Hide;
|
||||
begin
|
||||
if Visible then
|
||||
Toggle;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -2,7 +2,7 @@
|
||||
"UpdateLazPackages" : [
|
||||
{
|
||||
"ForceNotify" : true,
|
||||
"InternalVersion" : 762,
|
||||
"InternalVersion" : 763,
|
||||
"Name" : "cef4delphi_lazarus.lpk",
|
||||
"Version" : "139.0.17"
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user