GitHub-Mirror/x2utils
1
0
Fork 0
mirror of synced 2024-09-07 21:45:03 +00:00
Code Issues Projects Releases Wiki Activity

Support for Delphi 10.2 Tokyo

Browse Source 
Added packages
Changed hardcoded IFDEF to CompilerVersion comparison
This commit is contained in:
Mark van Renswoude 2017-07-06 17:05:07 +02:00
parent 7a42f3674c
commit 1e7a087355
13 changed files with 1180 additions and 859 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored
View File

@ -1,3 +1,3 @@
__history/
*.local
*.identcache
__history/
*.local
*.identcache

70
Packages/D10/X2Utils.dpk Normal file
View File

@ -0,0 +1,70 @@
package X2Utils;
{$R *.res}
{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES ON}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$ENDIF IMPLICITBUILDING}
{$DESCRIPTION 'X2Utils'}
{$LIBSUFFIX 'D10'}
{$RUNONLY}
{$IMPLICITBUILD ON}
requires
rtl,
vcl,
xmlrtl;
contains
X2UtApp in '..\..\X2UtApp.pas',
X2UtBits in '..\..\X2UtBits.pas',
X2UtGraphics in '..\..\X2UtGraphics.pas',
X2UtHandCursor in '..\..\X2UtHandCursor.pas',
X2UtHashes in '..\..\X2UtHashes.pas',
X2UtHashesVariants in '..\..\X2UtHashesVariants.pas',
X2UtMisc in '..\..\X2UtMisc.pas',
X2UtOS in '..\..\X2UtOS.pas',
X2UtStrings in '..\..\X2UtStrings.pas',
X2UtImageInfo in '..\..\X2UtImageInfo.pas',
X2UtTempFile in '..\..\X2UtTempFile.pas',
X2UtIniParser in '..\..\X2UtIniParser.pas',
X2UtProcess in '..\..\X2UtProcess.pas',
X2UtSingleInstance in '..\..\X2UtSingleInstance.pas',
X2UtStreams in '..\..\X2UtStreams.pas',
X2UtNamedFormat in '..\..\X2UtNamedFormat.pas',
X2UtPersist in '..\..\X2UtPersist.pas',
X2UtPersistForm in '..\..\X2UtPersistForm.pas',
X2UtPersistIntf in '..\..\X2UtPersistIntf.pas',
X2UtPersistRegistry in '..\..\X2UtPersistRegistry.pas',
X2UtElevation in '..\..\X2UtElevation.pas',
X2UtPersistXML in '..\..\X2UtPersistXML.pas',
X2UtPersistXMLBinding in '..\..\X2UtPersistXMLBinding.pas',
XMLDataBindingUtils in '..\..\XMLDataBindingUtils.pas',
X2UtDelphiCompatibility in '..\..\X2UtDelphiCompatibility.pas',
X2UtCursors in '..\..\X2UtCursors.pas',
X2UtService.GUIContext.Form in '..\..\X2UtService.GUIContext.Form.pas' {X2ServiceContextGUIForm},
X2UtService.GUIContext in '..\..\X2UtService.GUIContext.pas',
X2UtService.Intf in '..\..\X2UtService.Intf.pas',
X2UtService in '..\..\X2UtService.pas',
X2UtService.ServiceContext in '..\..\X2UtService.ServiceContext.pas';
end.

241
Packages/D10/X2Utils.dproj Normal file
View File

@ -0,0 +1,241 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{3cd28184-f9a5-4320-9ad8-80ef25ba762e}</ProjectGuid>
<MainSource>X2Utils.dpk</MainSource>
<Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<DCC_DependencyCheckOutputName>P:\algemeen\bin\D2007\X2Utils2007.bpl</DCC_DependencyCheckOutputName>
<FrameworkType>VCL</FrameworkType>
<ProjectVersion>18.2</ProjectVersion>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<Platform Condition="'$(Platform)'==''">Win32</Platform>
<TargetedPlatforms>3</TargetedPlatforms>
<AppType>Package</AppType>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''">
<Base_Android>true</Base_Android>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
<Base_Win32>true</Base_Win32>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
<Base_Win64>true</Base_Win64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
<Cfg_1_Win32>true</Cfg_1_Win32>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win64)'!=''">
<Cfg_1_Win64>true</Cfg_1_Win64>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''">
<Cfg_2_Win32>true</Cfg_2_Win32>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win64)'!=''">
<Cfg_2_Win64>true</Cfg_2_Win64>
<CfgParent>Cfg_2</CfgParent>
<Cfg_2>true</Cfg_2>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
<RuntimeOnlyPackage>true</RuntimeOnlyPackage>
<DCC_ImageBase>00400000</DCC_ImageBase>
<DCC_WriteableConstants>true</DCC_WriteableConstants>
<DCC_Description>X2Utils</DCC_Description>
<DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace>
<GenPackage>true</GenPackage>
<VerInfo_Locale>1043</VerInfo_Locale>
<GenDll>true</GenDll>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
<DllSuffix>D10</DllSuffix>
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
<SanitizedProjectName>X2Utils</SanitizedProjectName>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Android)'!=''">
<VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey=</VerInfo_Keys>
<BT_BuildType>Debug</BT_BuildType>
<VerInfo_IncludeVerInfo>false</VerInfo_IncludeVerInfo>
<EnabledSysJars>android-support-v4.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<DCC_BplOutput>$(DELPHIBIN)</DCC_BplOutput>
<DCC_DcuOutput>$(DELPHILIB)</DCC_DcuOutput>
<DCC_DcpOutput>$(DELPHIBIN)</DCC_DcpOutput>
<Icon_MainIcon>X2Utils_Icon.ico</Icon_MainIcon>
<DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace>
<DCC_BplOutput>$(DELPHIBIN64)</DCC_BplOutput>
<VerInfo_Locale>1033</VerInfo_Locale>
<DCC_DcpOutput>$(DELPHIBIN64)</DCC_DcpOutput>
<DCC_DcuOutput>$(DELPHILIB64)</DCC_DcuOutput>
<Icon_MainIcon>X2Utils_Icon.ico</Icon_MainIcon>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<Version>7.0</Version>
<DCC_DebugInformation>0</DCC_DebugInformation>
<DCC_WriteableConstants>True</DCC_WriteableConstants>
<DCC_LocalDebugSymbols>False</DCC_LocalDebugSymbols>
<DCC_GenerateStackFrames>True</DCC_GenerateStackFrames>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win64)'!=''">
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<Version>7.0</Version>
<DCC_WriteableConstants>True</DCC_WriteableConstants>
<DCC_GenerateStackFrames>True</DCC_GenerateStackFrames>
<DCC_ObjOutput>$(DELPHILIB)</DCC_ObjOutput>
<DCC_HppOutput>$(DELPHILIB)</DCC_HppOutput>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win32)'!=''">
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2_Win64)'!=''">
<VerInfo_Locale>1033</VerInfo_Locale>
</PropertyGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType>Package</Borland.ProjectType>
<BorlandProject>
<Delphi.Personality>
<Parameters>
<Parameters Name="UseLauncher">False</Parameters>
<Parameters Name="LoadAllSymbols">True</Parameters>
<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
</Parameters>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">True</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1043</VersionInfo>
<VersionInfo Name="CodePage">1252</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"/>
<VersionInfoKeys Name="FileDescription"/>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"/>
<VersionInfoKeys Name="LegalCopyright"/>
<VersionInfoKeys Name="LegalTrademarks"/>
<VersionInfoKeys Name="OriginalFilename"/>
<VersionInfoKeys Name="ProductName"/>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
<Source>
<Source Name="MainSource">X2Utils.dpk</Source>
</Source>
<Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dcloffice2k250.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclofficexp250.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality>
<Platforms>
<Platform value="Android">False</Platform>
<Platform value="Win32">True</Platform>
<Platform value="Win64">True</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/>
<ItemGroup>
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="rtl.dcp"/>
<DCCReference Include="vcl.dcp"/>
<DCCReference Include="xmlrtl.dcp"/>
<DCCReference Include="..\..\X2UtApp.pas"/>
<DCCReference Include="..\..\X2UtBits.pas"/>
<DCCReference Include="..\..\X2UtGraphics.pas"/>
<DCCReference Include="..\..\X2UtHandCursor.pas"/>
<DCCReference Include="..\..\X2UtHashes.pas"/>
<DCCReference Include="..\..\X2UtHashesVariants.pas"/>
<DCCReference Include="..\..\X2UtMisc.pas"/>
<DCCReference Include="..\..\X2UtOS.pas"/>
<DCCReference Include="..\..\X2UtStrings.pas"/>
<DCCReference Include="..\..\X2UtImageInfo.pas"/>
<DCCReference Include="..\..\X2UtTempFile.pas"/>
<DCCReference Include="..\..\X2UtIniParser.pas"/>
<DCCReference Include="..\..\X2UtProcess.pas"/>
<DCCReference Include="..\..\X2UtSingleInstance.pas"/>
<DCCReference Include="..\..\X2UtStreams.pas"/>
<DCCReference Include="..\..\X2UtNamedFormat.pas"/>
<DCCReference Include="..\..\X2UtPersist.pas"/>
<DCCReference Include="..\..\X2UtPersistForm.pas"/>
<DCCReference Include="..\..\X2UtPersistIntf.pas"/>
<DCCReference Include="..\..\X2UtPersistRegistry.pas"/>
<DCCReference Include="..\..\X2UtElevation.pas"/>
<DCCReference Include="..\..\X2UtPersistXML.pas"/>
<DCCReference Include="..\..\X2UtPersistXMLBinding.pas"/>
<DCCReference Include="..\..\XMLDataBindingUtils.pas"/>
<DCCReference Include="..\..\X2UtDelphiCompatibility.pas"/>
<DCCReference Include="..\..\X2UtCursors.pas"/>
<DCCReference Include="..\..\X2UtService.GUIContext.Form.pas">
<Form>X2ServiceContextGUIForm</Form>
</DCCReference>
<DCCReference Include="..\..\X2UtService.GUIContext.pas"/>
<DCCReference Include="..\..\X2UtService.Intf.pas"/>
<DCCReference Include="..\..\X2UtService.pas"/>
<DCCReference Include="..\..\X2UtService.ServiceContext.pas"/>
<BuildConfiguration Include="Debug">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Release">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
</Project>

BIN
Packages/D10/X2Utils.res Normal file
View File

Binary file not shown.

10
Packages/D10/X2Utils.stat Normal file
View File

@ -0,0 +1,10 @@
[Stats]
EditorSecs=43
DesignerSecs=1
InspectorSecs=1
CompileSecs=1667
OtherSecs=12
StartTime=6-7-2017 15:40:36
RealKeys=0
EffectiveKeys=0
DebugSecs=1

BIN
Packages/D10/X2Utils_Icon.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 26 KiB

4
X2UtElevation.pas
View File

@ -336,11 +336,11 @@ begin
end;
except
on E: Exception do
{$IFDEF VER230}
{$IF CompilerVersion >= 23}
raise EOleRegistrationError.Create(E.Message, 0, 0);
{$ELSE}
raise EOleRegistrationError.Create(E.Message);
{$ENDIF}
{$IFEND}
end;
end;

264
X2UtService.GUIContext.Form.dfm
View File

@ -1,132 +1,132 @@
object X2ServiceContextGUIForm: TX2ServiceContextGUIForm
Left = 0
Top = 0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'X2ServiceContextGUIForm'
ClientHeight = 204
ClientWidth = 439
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
DesignSize = (
439
204)
PixelsPerInch = 96
TextHeight = 13
object btnClose: TButton
Left = 8
Top = 171
Width = 75
Height = 25
Anchors = [akLeft, akBottom]
Caption = '&Close'
TabOrder = 0
OnClick = btnCloseClick
end
object gbStatus: TGroupBox
AlignWithMargins = True
Left = 8
Top = 8
Width = 423
Height = 57
Margins.Left = 8
Margins.Top = 8
Margins.Right = 8
Margins.Bottom = 0
Align = alTop
Caption = ' Status '
TabOrder = 1
ExplicitWidth = 358
object lblStatus: TLabel
Left = 34
Top = 26
Width = 50
Height = 13
Caption = 'Starting...'
end
object shpStatus: TShape
Left = 12
Top = 24
Width = 16
Height = 16
Brush.Color = 33023
Shape = stCircle
end
end
object gbCustomControl: TGroupBox
AlignWithMargins = True
Left = 8
Top = 73
Width = 423
Height = 88
Margins.Left = 8
Margins.Top = 8
Margins.Right = 8
Margins.Bottom = 0
Align = alTop
Caption = ' Custom control '
TabOrder = 2
ExplicitWidth = 358
DesignSize = (
423
88)
object lblControlCode: TLabel
Left = 12
Top = 27
Width = 25
Height = 13
Caption = 'Code'
end
object edtControlCode: TEdit
Left = 72
Top = 24
Width = 256
Height = 21
Anchors = [akLeft, akTop, akRight]
TabOrder = 0
Text = '128'
OnChange = edtControlCodeChange
ExplicitWidth = 191
end
object btnSend: TButton
Left = 334
Top = 24
Width = 75
Height = 21
Anchors = [akTop, akRight]
Caption = '&Send'
TabOrder = 1
OnClick = btnSendClick
ExplicitLeft = 269
end
object cmbControlCodePredefined: TComboBox
Left = 72
Top = 51
Width = 256
Height = 21
Style = csDropDownList
Anchors = [akLeft, akTop, akRight]
TabOrder = 2
ExplicitWidth = 220
end
object btnSendPredefined: TButton
Left = 334
Top = 51
Width = 75
Height = 21
Anchors = [akTop, akRight]
Caption = '&Send'
TabOrder = 3
OnClick = btnSendPredefinedClick
ExplicitLeft = 269
end
end
end
object X2ServiceContextGUIForm: TX2ServiceContextGUIForm
Left = 0
Top = 0
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'X2ServiceContextGUIForm'
ClientHeight = 204
ClientWidth = 439
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
DesignSize = (
439
204)
PixelsPerInch = 96
TextHeight = 13
object btnClose: TButton
Left = 8
Top = 171
Width = 75
Height = 25
Anchors = [akLeft, akBottom]
Caption = '&Close'
TabOrder = 0
OnClick = btnCloseClick
end
object gbStatus: TGroupBox
AlignWithMargins = True
Left = 8
Top = 8
Width = 423
Height = 57
Margins.Left = 8
Margins.Top = 8
Margins.Right = 8
Margins.Bottom = 0
Align = alTop
Caption = ' Status '
TabOrder = 1
ExplicitWidth = 358
object lblStatus: TLabel
Left = 34
Top = 26
Width = 50
Height = 13
Caption = 'Starting...'
end
object shpStatus: TShape
Left = 12
Top = 24
Width = 16
Height = 16
Brush.Color = 33023
Shape = stCircle
end
end
object gbCustomControl: TGroupBox
AlignWithMargins = True
Left = 8
Top = 73
Width = 423
Height = 88
Margins.Left = 8
Margins.Top = 8
Margins.Right = 8
Margins.Bottom = 0
Align = alTop
Caption = ' Custom control '
TabOrder = 2
ExplicitWidth = 358
DesignSize = (
423
88)
object lblControlCode: TLabel
Left = 12
Top = 27
Width = 25
Height = 13
Caption = 'Code'
end
object edtControlCode: TEdit
Left = 72
Top = 24
Width = 256
Height = 21
Anchors = [akLeft, akTop, akRight]
TabOrder = 0
Text = '128'
OnChange = edtControlCodeChange
ExplicitWidth = 191
end
object btnSend: TButton
Left = 334
Top = 24
Width = 75
Height = 21
Anchors = [akTop, akRight]
Caption = '&Send'
TabOrder = 1
OnClick = btnSendClick
ExplicitLeft = 269
end
object cmbControlCodePredefined: TComboBox
Left = 72
Top = 51
Width = 256
Height = 21
Style = csDropDownList
Anchors = [akLeft, akTop, akRight]
TabOrder = 2
ExplicitWidth = 220
end
object btnSendPredefined: TButton
Left = 334
Top = 51
Width = 75
Height = 21
Anchors = [akTop, akRight]
Caption = '&Send'
TabOrder = 3
OnClick = btnSendPredefinedClick
ExplicitLeft = 269
end
end
end

684
X2UtService.GUIContext.Form.pas
View File

@ -1,342 +1,342 @@
unit X2UtService.GUIContext.Form;
interface
uses
System.Classes,
Vcl.Controls,
Vcl.ExtCtrls,
Vcl.Forms,
Vcl.Graphics,
Vcl.StdCtrls,
Winapi.Messages,
X2UtService.Intf;
type
TX2ServiceContextGUIForm = class(TForm)
btnClose: TButton;
gbStatus: TGroupBox;
lblStatus: TLabel;
shpStatus: TShape;
gbCustomControl: TGroupBox;
lblControlCode: TLabel;
edtControlCode: TEdit;
btnSend: TButton;
cmbControlCodePredefined: TComboBox;
btnSendPredefined: TButton;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure edtControlCodeChange(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure btnSendPredefinedClick(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
private
FContext: IX2ServiceContext;
FService: IX2Service;
FServiceThread: TThread;
FAllowClose: Boolean;
protected
procedure DoShow; override;
procedure UpdatePredefinedControlCodes; virtual;
function GetControlCode: Byte;
procedure SetStatus(const AMessage: string; AColor: TColor);
property ServiceThread: TThread read FServiceThread;
public
property Context: IX2ServiceContext read FContext write FContext;
property Service: IX2Service read FService write FService;
end;
implementation
uses
System.Generics.Collections,
System.Math,
System.SyncObjs,
System.SysUtils,
Winapi.Windows;
{$R *.dfm}
const
StatusColorStarting = $00B0FFB0;
StatusColorStarted = clGreen;
StatusColorStopping = $008080FF;
StatusColorStopped = clRed;
type
TX2ServiceThread = class(TThread)
private
FContext: IX2ServiceContext;
FService: IX2Service;
FWakeEvent: TEvent;
FSendCodeList: TList<Integer>;
FOnStarted: TThreadProcedure;
FOnStartFailed: TThreadProcedure;
FOnStopped: TThreadProcedure;
FOnStopFailed: TThreadProcedure;
protected
procedure Execute; override;
procedure TerminatedSet; override;
procedure FlushSendCodeList;
property Context: IX2ServiceContext read FContext;
property Service: IX2Service read FService;
property WakeEvent: TEvent read FWakeEvent;
public
constructor Create(AContext: IX2ServiceContext; AService: IX2Service);
destructor Destroy; override;
procedure SendControlCode(ACode: Byte);
property OnStarted: TThreadProcedure read FOnStarted write FOnStarted;
property OnStartFailed: TThreadProcedure read FOnStartFailed write FOnStartFailed;
property OnStopped: TThreadProcedure read FOnStopped write FOnStopped;
property OnStopFailed: TThreadProcedure read FOnStopFailed write FOnStopFailed;
end;
{ TX2ServiceContextGUIForm }
procedure TX2ServiceContextGUIForm.FormCreate(Sender: TObject);
begin
btnClose.Left := (ClientWidth - btnClose.Width) div 2;
end;
procedure TX2ServiceContextGUIForm.DoShow;
var
serviceThread: TX2ServiceThread;
begin
inherited DoShow;
if not Assigned(FServiceThread) then
begin
UpdatePredefinedControlCodes;
SetStatus('Starting...', StatusColorStarting);
serviceThread := TX2ServiceThread.Create(Context, Service);
serviceThread.OnStarted :=
procedure
begin
SetStatus('Started', StatusColorStarted);
end;
serviceThread.OnStartFailed :=
procedure
begin
SetStatus('Start failed', StatusColorStopped);
FServiceThread := nil;
end;
serviceThread.OnStopped :=
procedure
begin
SetStatus('Stopped', StatusColorStopped);
FAllowClose := True;
Close;
end;
serviceThread.OnStopFailed :=
procedure
begin
SetStatus('Stop failed', StatusColorStarted);
end;
FServiceThread := serviceThread;
FServiceThread.Start;
end;
end;
procedure TX2ServiceContextGUIForm.edtControlCodeChange(Sender: TObject);
begin
edtControlCode.Text := IntToStr(GetControlCode);
end;
procedure TX2ServiceContextGUIForm.btnSendClick(Sender: TObject);
begin
(ServiceThread as TX2ServiceThread).SendControlCode(GetControlCode);
end;
procedure TX2ServiceContextGUIForm.btnSendPredefinedClick(Sender: TObject);
var
code: Byte;
begin
if cmbControlCodePredefined.ItemIndex > -1 then
begin
code := Byte(cmbControlCodePredefined.Items.Objects[cmbControlCodePredefined.ItemIndex]);
(ServiceThread as TX2ServiceThread).SendControlCode(code);
end;
end;
procedure TX2ServiceContextGUIForm.btnCloseClick(Sender: TObject);
begin
Close;
end;
procedure TX2ServiceContextGUIForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if not FAllowClose then
begin
SetStatus('Stopping...', StatusColorStopping);
CanClose := False;
ServiceThread.Terminate;
end;
end;
procedure TX2ServiceContextGUIForm.UpdatePredefinedControlCodes;
var
serviceCustomControl: IX2ServiceCustomControl;
begin
cmbControlCodePredefined.Items.Clear;
if Supports(Service, IX2ServiceCustomControl, serviceCustomControl) then
begin
serviceCustomControl.EnumCustomControlCodes(
procedure(ACode: Byte; const ADescription: string)
begin
cmbControlCodePredefined.Items.AddObject(Format('%s (%d)', [ADescription, ACode]), TObject(ACode));
end);
cmbControlCodePredefined.Enabled := True;
cmbControlCodePredefined.ItemIndex := 0;
btnSendPredefined.Enabled := cmbControlCodePredefined.Items.Count > 0;
end else
begin
cmbControlCodePredefined.Enabled := False;
btnSendPredefined.Enabled := False;
end;
end;
function TX2ServiceContextGUIForm.GetControlCode: Byte;
begin
Result := Byte(Min(Max(StrToIntDef(edtControlCode.Text, 0), 128), 255));
end;
procedure TX2ServiceContextGUIForm.SetStatus(const AMessage: string; AColor: TColor);
begin
shpStatus.Brush.Color := AColor;
lblStatus.Caption := AMessage;
end;
{ TX2ServiceThread }
constructor TX2ServiceThread.Create(AContext: IX2ServiceContext; AService: IX2Service);
begin
inherited Create(True);
FContext := AContext;
FService := AService;
FWakeEvent := TEvent.Create(nil, False, False, '');
FSendCodeList := TList<Integer>.Create;
end;
destructor TX2ServiceThread.Destroy;
begin
FreeAndNil(FWakeEvent);
FreeAndNil(FSendCodeList);
inherited Destroy;
end;
procedure TX2ServiceThread.Execute;
begin
try
Service.Start(Context);
except
if Assigned(FOnStartFailed) then
Synchronize(FOnStartFailed);
exit;
end;
if Assigned(FOnStarted) then
Synchronize(FOnStarted);
while True do
begin
try
WakeEvent.WaitFor(INFINITE);
if Terminated then
begin
Service.Stop;
if Assigned(FOnStopped) then
Synchronize(FOnStopped);
break;
end;
FlushSendCodeList;
except
if Assigned(FOnStopFailed) then
Synchronize(FOnStopFailed);
end;
end;
end;
procedure TX2ServiceThread.FlushSendCodeList;
var
code: Byte;
begin
System.TMonitor.Enter(FSendCodeList);
try
for code in FSendCodeList do
Service.DoCustomControl(code);
FSendCodeList.Clear;
finally
System.TMonitor.Exit(FSendCodeList);
end;
end;
procedure TX2ServiceThread.TerminatedSet;
begin
inherited TerminatedSet;
WakeEvent.SetEvent;
end;
procedure TX2ServiceThread.SendControlCode(ACode: Byte);
begin
System.TMonitor.Enter(FSendCodeList);
try
FSendCodeList.Add(ACode);
finally
System.TMonitor.Exit(FSendCodeList);
end;
WakeEvent.SetEvent;
end;
end.
unit X2UtService.GUIContext.Form;
interface
uses
System.Classes,
Vcl.Controls,
Vcl.ExtCtrls,
Vcl.Forms,
Vcl.Graphics,
Vcl.StdCtrls,
Winapi.Messages,
X2UtService.Intf;
type
TX2ServiceContextGUIForm = class(TForm)
btnClose: TButton;
gbStatus: TGroupBox;
lblStatus: TLabel;
shpStatus: TShape;
gbCustomControl: TGroupBox;
lblControlCode: TLabel;
edtControlCode: TEdit;
btnSend: TButton;
cmbControlCodePredefined: TComboBox;
btnSendPredefined: TButton;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure edtControlCodeChange(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure btnSendPredefinedClick(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
private
FContext: IX2ServiceContext;
FService: IX2Service;
FServiceThread: TThread;
FAllowClose: Boolean;
protected
procedure DoShow; override;
procedure UpdatePredefinedControlCodes; virtual;
function GetControlCode: Byte;
procedure SetStatus(const AMessage: string; AColor: TColor);
property ServiceThread: TThread read FServiceThread;
public
property Context: IX2ServiceContext read FContext write FContext;
property Service: IX2Service read FService write FService;
end;
implementation
uses
System.Generics.Collections,
System.Math,
System.SyncObjs,
System.SysUtils,
Winapi.Windows;
{$R *.dfm}
const
StatusColorStarting = $00B0FFB0;
StatusColorStarted = clGreen;
StatusColorStopping = $008080FF;
StatusColorStopped = clRed;
type
TX2ServiceThread = class(TThread)
private
FContext: IX2ServiceContext;
FService: IX2Service;
FWakeEvent: TEvent;
FSendCodeList: TList<Integer>;
FOnStarted: TThreadProcedure;
FOnStartFailed: TThreadProcedure;
FOnStopped: TThreadProcedure;
FOnStopFailed: TThreadProcedure;
protected
procedure Execute; override;
procedure TerminatedSet; override;
procedure FlushSendCodeList;
property Context: IX2ServiceContext read FContext;
property Service: IX2Service read FService;
property WakeEvent: TEvent read FWakeEvent;
public
constructor Create(AContext: IX2ServiceContext; AService: IX2Service);
destructor Destroy; override;
procedure SendControlCode(ACode: Byte);
property OnStarted: TThreadProcedure read FOnStarted write FOnStarted;
property OnStartFailed: TThreadProcedure read FOnStartFailed write FOnStartFailed;
property OnStopped: TThreadProcedure read FOnStopped write FOnStopped;
property OnStopFailed: TThreadProcedure read FOnStopFailed write FOnStopFailed;
end;
{ TX2ServiceContextGUIForm }
procedure TX2ServiceContextGUIForm.FormCreate(Sender: TObject);
begin
btnClose.Left := (ClientWidth - btnClose.Width) div 2;
end;
procedure TX2ServiceContextGUIForm.DoShow;
var
serviceThread: TX2ServiceThread;
begin
inherited DoShow;
if not Assigned(FServiceThread) then
begin
UpdatePredefinedControlCodes;
SetStatus('Starting...', StatusColorStarting);
serviceThread := TX2ServiceThread.Create(Context, Service);
serviceThread.OnStarted :=
procedure
begin
SetStatus('Started', StatusColorStarted);
end;
serviceThread.OnStartFailed :=
procedure
begin
SetStatus('Start failed', StatusColorStopped);
FServiceThread := nil;
end;
serviceThread.OnStopped :=
procedure
begin
SetStatus('Stopped', StatusColorStopped);
FAllowClose := True;
Close;
end;
serviceThread.OnStopFailed :=
procedure
begin
SetStatus('Stop failed', StatusColorStarted);
end;
FServiceThread := serviceThread;
FServiceThread.Start;
end;
end;
procedure TX2ServiceContextGUIForm.edtControlCodeChange(Sender: TObject);
begin
edtControlCode.Text := IntToStr(GetControlCode);
end;
procedure TX2ServiceContextGUIForm.btnSendClick(Sender: TObject);
begin
(ServiceThread as TX2ServiceThread).SendControlCode(GetControlCode);
end;
procedure TX2ServiceContextGUIForm.btnSendPredefinedClick(Sender: TObject);
var
code: Byte;
begin
if cmbControlCodePredefined.ItemIndex > -1 then
begin
code := Byte(cmbControlCodePredefined.Items.Objects[cmbControlCodePredefined.ItemIndex]);
(ServiceThread as TX2ServiceThread).SendControlCode(code);
end;
end;
procedure TX2ServiceContextGUIForm.btnCloseClick(Sender: TObject);
begin
Close;
end;
procedure TX2ServiceContextGUIForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if not FAllowClose then
begin
SetStatus('Stopping...', StatusColorStopping);
CanClose := False;
ServiceThread.Terminate;
end;
end;
procedure TX2ServiceContextGUIForm.UpdatePredefinedControlCodes;
var
serviceCustomControl: IX2ServiceCustomControl;
begin
cmbControlCodePredefined.Items.Clear;
if Supports(Service, IX2ServiceCustomControl, serviceCustomControl) then
begin
serviceCustomControl.EnumCustomControlCodes(
procedure(ACode: Byte; const ADescription: string)
begin
cmbControlCodePredefined.Items.AddObject(Format('%s (%d)', [ADescription, ACode]), TObject(ACode));
end);
cmbControlCodePredefined.Enabled := True;
cmbControlCodePredefined.ItemIndex := 0;
btnSendPredefined.Enabled := cmbControlCodePredefined.Items.Count > 0;
end else
begin
cmbControlCodePredefined.Enabled := False;
btnSendPredefined.Enabled := False;
end;
end;
function TX2ServiceContextGUIForm.GetControlCode: Byte;
begin
Result := Byte(Min(Max(StrToIntDef(edtControlCode.Text, 0), 128), 255));
end;
procedure TX2ServiceContextGUIForm.SetStatus(const AMessage: string; AColor: TColor);
begin
shpStatus.Brush.Color := AColor;
lblStatus.Caption := AMessage;
end;
{ TX2ServiceThread }
constructor TX2ServiceThread.Create(AContext: IX2ServiceContext; AService: IX2Service);
begin
inherited Create(True);
FContext := AContext;
FService := AService;
FWakeEvent := TEvent.Create(nil, False, False, '');
FSendCodeList := TList<Integer>.Create;
end;
destructor TX2ServiceThread.Destroy;
begin
FreeAndNil(FWakeEvent);
FreeAndNil(FSendCodeList);
inherited Destroy;
end;
procedure TX2ServiceThread.Execute;
begin
try
Service.Start(Context);
except
if Assigned(FOnStartFailed) then
Synchronize(FOnStartFailed);
exit;
end;
if Assigned(FOnStarted) then
Synchronize(FOnStarted);
while True do
begin
try
WakeEvent.WaitFor(INFINITE);
if Terminated then
begin
Service.Stop;
if Assigned(FOnStopped) then
Synchronize(FOnStopped);
break;
end;
FlushSendCodeList;
except
if Assigned(FOnStopFailed) then
Synchronize(FOnStopFailed);
end;
end;
end;
procedure TX2ServiceThread.FlushSendCodeList;
var
code: Byte;
begin
System.TMonitor.Enter(FSendCodeList);
try
for code in FSendCodeList do
Service.DoCustomControl(code);
FSendCodeList.Clear;
finally
System.TMonitor.Exit(FSendCodeList);
end;
end;
procedure TX2ServiceThread.TerminatedSet;
begin
inherited TerminatedSet;
WakeEvent.SetEvent;
end;
procedure TX2ServiceThread.SendControlCode(ACode: Byte);
begin
System.TMonitor.Enter(FSendCodeList);
try
FSendCodeList.Add(ACode);
finally
System.TMonitor.Exit(FSendCodeList);
end;
WakeEvent.SetEvent;
end;
end.

140
X2UtService.GUIContext.pas
View File

@ -1,70 +1,70 @@
unit X2UtService.GUIContext;
interface
uses
System.Classes,
X2UtService.Intf;
type
TX2ServiceContextGUI = class(TInterfacedObject, IX2ServiceContext, IX2InteractiveServiceContext)
protected
procedure StartService(AService: IX2Service); virtual;
public
constructor Create(AService: IX2Service);
{ IX2ServiceContext }
function GetMode: TX2ServiceMode;
{ IX2InteractiveServiceContext }
procedure RunInteractive(AProc: TThreadProcedure);
end;
implementation
uses
Vcl.Forms,
X2UtService.GUIContext.Form;
{ TX2ServiceContextGUI }
constructor TX2ServiceContextGUI.Create(AService: IX2Service);
begin
inherited Create;
StartService(AService);
end;
function TX2ServiceContextGUI.GetMode: TX2ServiceMode;
begin
Result := smInteractive;
end;
procedure TX2ServiceContextGUI.StartService(AService: IX2Service);
var
serviceForm: TX2ServiceContextGUIForm;
begin
Application.Initialize;
Application.MainFormOnTaskBar := True;
Application.CreateForm(TX2ServiceContextGUIForm, serviceForm);
serviceForm.Caption := AService.DisplayName;
serviceForm.Context := Self;
serviceForm.Service := AService;
Application.Run;
end;
procedure TX2ServiceContextGUI.RunInteractive(AProc: TThreadProcedure);
begin
TThread.Queue(nil, AProc);
end;
end.
unit X2UtService.GUIContext;
interface
uses
System.Classes,
X2UtService.Intf;
type
TX2ServiceContextGUI = class(TInterfacedObject, IX2ServiceContext, IX2InteractiveServiceContext)
protected
procedure StartService(AService: IX2Service); virtual;
public
constructor Create(AService: IX2Service);
{ IX2ServiceContext }
function GetMode: TX2ServiceMode;
{ IX2InteractiveServiceContext }
procedure RunInteractive(AProc: TThreadProcedure);
end;
implementation
uses
Vcl.Forms,
X2UtService.GUIContext.Form;
{ TX2ServiceContextGUI }
constructor TX2ServiceContextGUI.Create(AService: IX2Service);
begin
inherited Create;
StartService(AService);
end;
function TX2ServiceContextGUI.GetMode: TX2ServiceMode;
begin
Result := smInteractive;
end;
procedure TX2ServiceContextGUI.StartService(AService: IX2Service);
var
serviceForm: TX2ServiceContextGUIForm;
begin
Application.Initialize;
Application.MainFormOnTaskBar := True;
Application.CreateForm(TX2ServiceContextGUIForm, serviceForm);
serviceForm.Caption := AService.DisplayName;
serviceForm.Context := Self;
serviceForm.Service := AService;
Application.Run;
end;
procedure TX2ServiceContextGUI.RunInteractive(AProc: TThreadProcedure);
begin
TThread.Queue(nil, AProc);
end;
end.

204
X2UtService.Intf.pas
View File

@ -1,102 +1,102 @@
unit X2UtService.Intf;
interface
uses
System.Classes,
System.SysUtils;
type
TX2ServiceMode = (smService, smInteractive);
IX2ServiceContext = interface
['{0AC283A7-B46C-4E4E-8F36-F8AA1272E04B}']
function GetMode: TX2ServiceMode;
property Mode: TX2ServiceMode read GetMode;
end;
IX2InteractiveServiceContext = interface(IX2ServiceContext)
['{82E69997-013D-4349-8060-B9F31B72CDF4}']
procedure RunInteractive(AProc: TThreadProcedure);
end;
IX2Service = interface
['{C8597906-87B8-444E-847B-37A034F72FFC}']
function GetServiceName: string;
function GetDisplayName: string;
{ Called when the service starts. Return True if succesful.
Storing a reference to AContext is allowed, but must be released when Stop is called. }
function Start(AContext: IX2ServiceContext): Boolean;
{ Called when the service is about to stop.
Return True if succesful. }
function Stop: Boolean;
{ Called for control codes in the user-defined range of 128 to 255. }
function DoCustomControl(ACode: Byte): Boolean;
property ServiceName: string read GetServiceName;
property DisplayName: string read GetDisplayName;
end;
TX2ServiceCustomControlProc = reference to procedure(ACode: Byte; const ADescription: string);
{ Implement this to enable discovery of supported custom control codes
for use in interactive contexts. }
IX2ServiceCustomControl = interface
['{D6363AC5-3DD5-4897-90A7-6F63D82B6A74}']
procedure EnumCustomControlCodes(Yield: TX2ServiceCustomControlProc);
end;
TX2CustomService = class(TInterfacedObject, IX2Service)
private
FContext: IX2ServiceContext;
protected
property Context: IX2ServiceContext read FContext;
public
{ IX2Service }
function GetServiceName: string; virtual; abstract;
function GetDisplayName: string; virtual; abstract;
function Start(AContext: IX2ServiceContext): Boolean; virtual;
function Stop: Boolean; virtual;
function DoCustomControl(ACode: Byte): Boolean; virtual;
end;
implementation
{ TX2CustomService }
function TX2CustomService.Start(AContext: IX2ServiceContext): Boolean;
begin
FContext := AContext;
Result := True;
end;
function TX2CustomService.Stop: Boolean;
begin
FContext := nil;
Result := True;
end;
function TX2CustomService.DoCustomControl(ACode: Byte): Boolean;
begin
Result := True;
end;
end.
unit X2UtService.Intf;
interface
uses
System.Classes,
System.SysUtils;
type
TX2ServiceMode = (smService, smInteractive);
IX2ServiceContext = interface
['{0AC283A7-B46C-4E4E-8F36-F8AA1272E04B}']
function GetMode: TX2ServiceMode;
property Mode: TX2ServiceMode read GetMode;
end;
IX2InteractiveServiceContext = interface(IX2ServiceContext)
['{82E69997-013D-4349-8060-B9F31B72CDF4}']
procedure RunInteractive(AProc: TThreadProcedure);
end;
IX2Service = interface
['{C8597906-87B8-444E-847B-37A034F72FFC}']
function GetServiceName: string;
function GetDisplayName: string;
{ Called when the service starts. Return True if succesful.
Storing a reference to AContext is allowed, but must be released when Stop is called. }
function Start(AContext: IX2ServiceContext): Boolean;
{ Called when the service is about to stop.
Return True if succesful. }
function Stop: Boolean;
{ Called for control codes in the user-defined range of 128 to 255. }
function DoCustomControl(ACode: Byte): Boolean;
property ServiceName: string read GetServiceName;
property DisplayName: string read GetDisplayName;
end;
TX2ServiceCustomControlProc = reference to procedure(ACode: Byte; const ADescription: string);
{ Implement this to enable discovery of supported custom control codes
for use in interactive contexts. }
IX2ServiceCustomControl = interface
['{D6363AC5-3DD5-4897-90A7-6F63D82B6A74}']
procedure EnumCustomControlCodes(Yield: TX2ServiceCustomControlProc);
end;
TX2CustomService = class(TInterfacedObject, IX2Service)
private
FContext: IX2ServiceContext;
protected
property Context: IX2ServiceContext read FContext;
public
{ IX2Service }
function GetServiceName: string; virtual; abstract;
function GetDisplayName: string; virtual; abstract;
function Start(AContext: IX2ServiceContext): Boolean; virtual;
function Stop: Boolean; virtual;
function DoCustomControl(ACode: Byte): Boolean; virtual;
end;
implementation
{ TX2CustomService }
function TX2CustomService.Start(AContext: IX2ServiceContext): Boolean;
begin
FContext := AContext;
Result := True;
end;
function TX2CustomService.Stop: Boolean;
begin
FContext := nil;
Result := True;
end;
function TX2CustomService.DoCustomControl(ACode: Byte): Boolean;
begin
Result := True;
end;
end.

292
X2UtService.ServiceContext.pas
View File

@ -1,146 +1,146 @@
unit X2UtService.ServiceContext;
interface
uses
X2UtService.Intf;
type
TX2ServiceContextService = class(TInterfacedObject, IX2ServiceContext)
protected
procedure StartService(AService: IX2Service); virtual;
public
class function IsInstallUninstall: Boolean;
constructor Create(AService: IX2Service);
{ IX2ServiceContext }
function GetMode: TX2ServiceMode;
end;
implementation
uses
System.Classes,
System.SysUtils,
Vcl.SvcMgr,
X2UtElevation;
type
TX2ServiceModule = class(TService)
private
FContext: IX2ServiceContext;
FService: IX2Service;
protected
function GetServiceController: TServiceController; override;
procedure HandleStart(Sender: TService; var Started: Boolean); virtual;
procedure HandleStop(Sender: TService; var Stopped: Boolean); virtual;
function DoCustomControl(CtrlCode: Cardinal): Boolean; override;
property Context: IX2ServiceContext read FContext;
property Service: IX2Service read FService;
public
constructor Create(AOwner: TComponent; AContext: IX2ServiceContext; AService: IX2Service); reintroduce;
end;
var
ServiceModuleInstance: TX2ServiceModule;
procedure ServiceController(CtrlCode: Cardinal); stdcall;
begin
if Assigned(ServiceModuleInstance) then
ServiceModuleInstance.Controller(CtrlCode);
end;
{ TX2ServiceContextService }
class function TX2ServiceContextService.IsInstallUninstall: Boolean;
begin
Result := FindCmdLineSwitch('install', ['-', '/'], True) or
FindCmdLineSwitch('uninstall', ['-', '/'], True);
end;
constructor TX2ServiceContextService.Create(AService: IX2Service);
begin
inherited Create;
if IsInstallUninstall and (not IsElevated) then
raise Exception.Create('Elevation is required for install or uninstall');
StartService(AService);
end;
function TX2ServiceContextService.GetMode: TX2ServiceMode;
begin
Result := smService;
end;
procedure TX2ServiceContextService.StartService(AService: IX2Service);
begin
if Assigned(ServiceModuleInstance) then
raise EInvalidOperation.Create('An instance of TX2ServiceContextService is already running');
Application.Initialize;
ServiceModuleInstance := TX2ServiceModule.Create(Application, Self, AService);
try
ServiceModuleInstance.DisplayName := AService.DisplayName;
ServiceModuleInstance.Name := AService.ServiceName;
Application.Run;
finally
ServiceModuleInstance := nil;
end;
end;
{ TX2ServiceModule }
constructor TX2ServiceModule.Create(AOwner: TComponent; AContext: IX2ServiceContext; AService: IX2Service);
begin
// Skip default constructor to prevent DFM streaming
CreateNew(AOwner);
FContext := AContext;
FService := AService;
OnStart := HandleStart;
OnStop := HandleStop;
end;
function TX2ServiceModule.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
function TX2ServiceModule.DoCustomControl(CtrlCode: Cardinal): Boolean;
begin
Result := True;
if (CtrlCode >= 128) and (CtrlCode <= 255) then
Result := Service.DoCustomControl(Byte(CtrlCode));
end;
procedure TX2ServiceModule.HandleStart(Sender: TService; var Started: Boolean);
begin
Started := Service.Start(Context);
end;
procedure TX2ServiceModule.HandleStop(Sender: TService; var Stopped: Boolean);
begin
Stopped := Service.Stop;
end;
end.
unit X2UtService.ServiceContext;
interface
uses
X2UtService.Intf;
type
TX2ServiceContextService = class(TInterfacedObject, IX2ServiceContext)
protected
procedure StartService(AService: IX2Service); virtual;
public
class function IsInstallUninstall: Boolean;
constructor Create(AService: IX2Service);
{ IX2ServiceContext }
function GetMode: TX2ServiceMode;
end;
implementation
uses
System.Classes,
System.SysUtils,
Vcl.SvcMgr,
X2UtElevation;
type
TX2ServiceModule = class(TService)
private
FContext: IX2ServiceContext;
FService: IX2Service;
protected
function GetServiceController: TServiceController; override;
procedure HandleStart(Sender: TService; var Started: Boolean); virtual;
procedure HandleStop(Sender: TService; var Stopped: Boolean); virtual;
function DoCustomControl(CtrlCode: Cardinal): Boolean; override;
property Context: IX2ServiceContext read FContext;
property Service: IX2Service read FService;
public
constructor Create(AOwner: TComponent; AContext: IX2ServiceContext; AService: IX2Service); reintroduce;
end;
var
ServiceModuleInstance: TX2ServiceModule;
procedure ServiceController(CtrlCode: Cardinal); stdcall;
begin
if Assigned(ServiceModuleInstance) then
ServiceModuleInstance.Controller(CtrlCode);
end;
{ TX2ServiceContextService }
class function TX2ServiceContextService.IsInstallUninstall: Boolean;
begin
Result := FindCmdLineSwitch('install', ['-', '/'], True) or
FindCmdLineSwitch('uninstall', ['-', '/'], True);
end;
constructor TX2ServiceContextService.Create(AService: IX2Service);
begin
inherited Create;
if IsInstallUninstall and (not IsElevated) then
raise Exception.Create('Elevation is required for install or uninstall');
StartService(AService);
end;
function TX2ServiceContextService.GetMode: TX2ServiceMode;
begin
Result := smService;
end;
procedure TX2ServiceContextService.StartService(AService: IX2Service);
begin
if Assigned(ServiceModuleInstance) then
raise EInvalidOperation.Create('An instance of TX2ServiceContextService is already running');
Application.Initialize;
ServiceModuleInstance := TX2ServiceModule.Create(Application, Self, AService);
try
ServiceModuleInstance.DisplayName := AService.DisplayName;
ServiceModuleInstance.Name := AService.ServiceName;
Application.Run;
finally
ServiceModuleInstance := nil;
end;
end;
{ TX2ServiceModule }
constructor TX2ServiceModule.Create(AOwner: TComponent; AContext: IX2ServiceContext; AService: IX2Service);
begin
// Skip default constructor to prevent DFM streaming
CreateNew(AOwner);
FContext := AContext;
FService := AService;
OnStart := HandleStart;
OnStop := HandleStop;
end;
function TX2ServiceModule.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
function TX2ServiceModule.DoCustomControl(CtrlCode: Cardinal): Boolean;
begin
Result := True;
if (CtrlCode >= 128) and (CtrlCode <= 255) then
Result := Service.DoCustomControl(Byte(CtrlCode));
end;
procedure TX2ServiceModule.HandleStart(Sender: TService; var Started: Boolean);
begin
Started := Service.Start(Context);
end;
procedure TX2ServiceModule.HandleStop(Sender: TService; var Stopped: Boolean);
begin
Stopped := Service.Stop;
end;
end.

124
X2UtService.pas
View File

@ -1,62 +1,62 @@
unit X2UtService;
interface
uses
X2UtService.Intf;
type
TX2Service = class(TObject)
public
class function Run(AService: IX2Service): IX2ServiceContext;
end;
function IsUserInteractive: Boolean;
implementation
uses
System.SysUtils,
Winapi.Windows,
X2UtService.GUIContext,
X2UtService.ServiceContext;
function IsUserInteractive: Boolean;
var
windowStation: HWINSTA;
userObject: TUserObjectFlags;
lengthNeeded: Cardinal;
begin
Result := True;
windowStation := GetProcessWindowStation;
if windowStation <> 0 then
begin
lengthNeeded := 0;
FillChar(userObject, SizeOf(userObject), 0);
if GetUserObjectInformation(windowStation, UOI_FLAGS, @userObject, SizeOf(userObject), lengthNeeded) and
((userObject.dwFlags and WSF_VISIBLE) = 0) then
begin
Result := False;
end;
end;
end;
{ TX2Service }
class function TX2Service.Run(AService: IX2Service): IX2ServiceContext;
begin
if TX2ServiceContextService.IsInstallUninstall or (not IsUserInteractive) then
Result := TX2ServiceContextService.Create(AService)
else
Result := TX2ServiceContextGUI.Create(AService);
end;
end.
unit X2UtService;
interface
uses
X2UtService.Intf;
type
TX2Service = class(TObject)
public
class function Run(AService: IX2Service): IX2ServiceContext;
end;
function IsUserInteractive: Boolean;
implementation
uses
System.SysUtils,
Winapi.Windows,
X2UtService.GUIContext,
X2UtService.ServiceContext;
function IsUserInteractive: Boolean;
var
windowStation: HWINSTA;
userObject: TUserObjectFlags;
lengthNeeded: Cardinal;
begin
Result := True;
windowStation := GetProcessWindowStation;
if windowStation <> 0 then
begin
lengthNeeded := 0;
FillChar(userObject, SizeOf(userObject), 0);
if GetUserObjectInformation(windowStation, UOI_FLAGS, @userObject, SizeOf(userObject), lengthNeeded) and
((userObject.dwFlags and WSF_VISIBLE) = 0) then
begin
Result := False;
end;
end;
end;
{ TX2Service }
class function TX2Service.Run(AService: IX2Service): IX2ServiceContext;
begin
if TX2ServiceContextService.IsInstallUninstall or (not IsUserInteractive) then
Result := TX2ServiceContextService.Create(AService)
else
Result := TX2ServiceContextGUI.Create(AService);
end;
end.