GitHub-Mirror/x2utils
1
0
Fork 0
mirror of synced 2024-09-16 16:46:09 +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/ __history/
*.local *.local
*.identcache *.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; end;
except except
on E: Exception do on E: Exception do
{$IFDEF VER230} {$IF CompilerVersion >= 23}
raise EOleRegistrationError.Create(E.Message, 0, 0); raise EOleRegistrationError.Create(E.Message, 0, 0);
{$ELSE} {$ELSE}
raise EOleRegistrationError.Create(E.Message); raise EOleRegistrationError.Create(E.Message);
{$ENDIF} {$IFEND}
end; end;
end; end;

264
X2UtService.GUIContext.Form.dfm
View File

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

684
X2UtService.GUIContext.Form.pas
View File

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

140
X2UtService.GUIContext.pas
View File

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

204
X2UtService.Intf.pas
View File

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

292
X2UtService.ServiceContext.pas
View File

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

124
X2UtService.pas
View File

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