1 {
2  /***************************************************************************
3                         w32manifest.pas  -  Lazarus IDE unit
4                         ---------------------------------------
5               TProjectXPManifest is responsible for the inclusion of the
6                    manifest in windows executables.
7 
8 
9  ***************************************************************************/
10 
11  ***************************************************************************
12  *                                                                         *
13  *   This source is free software; you can redistribute it and/or modify   *
14  *   it under the terms of the GNU General Public License as published by  *
15  *   the Free Software Foundation; either version 2 of the License, or     *
16  *   (at your option) any later version.                                   *
17  *                                                                         *
18  *   This code is distributed in the hope that it will be useful, but      *
19  *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
20  *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
21  *   General Public License for more details.                              *
22  *                                                                         *
23  *   A copy of the GNU General Public License is available on the World    *
24  *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
25  *   obtain it by writing to the Free Software Foundation,                 *
26  *   Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA.   *
27  *                                                                         *
28  ***************************************************************************
29 
30   The manifest file is needed for windows XP themes.
31   The file is created in the directory, where the project exe is created.
32 }
33 unit W32Manifest;
34 
35 {$mode objfpc}{$H+}
36 
37 interface
38 
39 uses
40   Classes, SysUtils, FileUtil, Laz2_XMLCfg, LCLProc, Controls, Forms,
41   CodeToolManager, LazConf, LResources,
42   ProjectResourcesIntf, resource;
43 
44 const
45   DefaultXPManifestTextName = 'CompanyName.ProductName.AppName';
46   DefaultXPManifestTextDesc = 'Your application description.';
47 type
48   TXPManifestExecutionLevel = (
49     xmelAsInvoker,
50     xmelHighestAvailable,
51     xmelRequireAdministrator
52   );
53 
54   TXPManifestDpiAware = (
55     xmdaFalse,
56     xmdaTrue,
57     xmdaPerMonitor,
58     xmdaTruePM,
59     xmdaPerMonitorV2
60   );
61 
62 type
63   { TProjectXPManifest }
64 
65   TProjectXPManifest = class(TAbstractProjectResource)
66   private
67     FExecutionLevel: TXPManifestExecutionLevel;
68     FDpiAware: TXPManifestDpiAware;
69     FUIAccess: Boolean;
70     FUseManifest: boolean;
71     FTextName: string;
72     FTextDesc: string;
73     procedure SetDpiAware(AValue: TXPManifestDpiAware);
74     procedure SetExecutionLevel(AValue: TXPManifestExecutionLevel);
75     procedure SetUIAccess(AValue: Boolean);
76     procedure SetUseManifest(const AValue: boolean);
77     procedure SetTextName(const AValue: string);
78     procedure SetTextDesc(const AValue: string);
79   public
80     constructor Create; override;
UpdateResourcesnull81     function UpdateResources(AResources: TAbstractProjectResources; const {%H-}MainFilename: string): Boolean; override;
82     procedure WriteToProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
83     procedure ReadFromProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
84 
85     property UseManifest: boolean read FUseManifest write SetUseManifest;
86     property DpiAware: TXPManifestDpiAware read FDpiAware write SetDpiAware;
87     property ExecutionLevel: TXPManifestExecutionLevel read FExecutionLevel write SetExecutionLevel;
88     property UIAccess: Boolean read FUIAccess write SetUIAccess;
89     property TextName: string read FTextName write SetTextName;
90     property TextDesc: string read FTextDesc write SetTextDesc;
91   end;
92 
93 const
94   ExecutionLevelToStr: array[TXPManifestExecutionLevel] of String = (
95     'asInvoker',
96     'highestAvailable',
97     'requireAdministrator'
98   );
99 
100   ManifestDpiAwareValues: array[TXPManifestDpiAware] of string = (
101     'False',
102     'True',
103     'Per-monitor',
104     'True/PM',
105     'True/PM'
106   );
107 
108   ManifestDpiAwarenessValues: array[TXPManifestDpiAware] of string = (
109     '',
110     '',
111     '',
112     '',
113     '<dpiAwareness>PerMonitorV2, PerMonitor</dpiAwareness>'
114   );
115 
116 implementation
117 
118 const
119   sManifestFileData: String =
120     '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>'#$D#$A+
121     '<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">'#$D#$A+
122     ' <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="%s" type="win32"/>'#$D#$A+
123     ' <description>%s</description>'#$D#$A+
124     ' <dependency>'#$D#$A+
125     '  <dependentAssembly>'#$D#$A+
126     '   <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="*" publicKeyToken="6595b64144ccf1df" language="*"/>'#$D#$A+
127     '  </dependentAssembly>'#$D#$A+
128     ' </dependency>'#$D#$A+
129     ' <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">'#$D#$A+
130     '  <security>'#$D#$A+
131     '   <requestedPrivileges>'#$D#$A+
132     '    <requestedExecutionLevel level="%s" uiAccess="%s"/>'#$D#$A+
133     '   </requestedPrivileges>'#$D#$A+
134     '  </security>'#$D#$A+
135     ' </trustInfo>'#$D#$A+
136     ' <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1">'#$D#$A+
137     '  <application>'#$D#$A+
138     '   <!-- Windows Vista -->'#$D#$A+
139     '   <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}" />'#$D#$A+
140     '   <!-- Windows 7 -->'#$D#$A+
141     '   <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}" />'#$D#$A+
142     '   <!-- Windows 8 -->'#$D#$A+
143     '   <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}" />'#$D#$A+
144     '   <!-- Windows 8.1 -->'#$D#$A+
145     '   <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}" />'#$D#$A+
146     '   <!-- Windows 10 -->'#$D#$A+
147     '   <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}" />'#$D#$A+
148     '   </application>'#$D#$A+
149     '  </compatibility>'#$D#$A+
150     ' <asmv3:application xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">'#$D#$A+
151     '  <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">'#$D#$A+
152     '   <dpiAware>%s</dpiAware>'#$D#$A+
153     '  </asmv3:windowsSettings>'#$D#$A+
154     '  <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2016/WindowsSettings">'#$D#$A+
155     '   %s'#$D#$A+
156     '  </asmv3:windowsSettings>'#$D#$A+
157     ' </asmv3:application>'#$D#$A+
158     '</assembly>';
159 
StrToXPManifestDpiAwarenull160 function StrToXPManifestDpiAware(const s: string): TXPManifestDpiAware;
161 begin
162   for Result:=Low(TXPManifestDpiAware) to High(TXPManifestDpiAware) do
163     if CompareText(s,ManifestDpiAwareValues[Result])=0 then exit;
164   Result:=xmdaFalse;
165 end;
166 
StrToXPManifestExecutionLevelnull167 function StrToXPManifestExecutionLevel(const s: string): TXPManifestExecutionLevel;
168 begin
169   for Result:=Low(TXPManifestExecutionLevel) to High(TXPManifestExecutionLevel) do
170     if CompareText(s,ExecutionLevelToStr[Result])=0 then exit;
171   Result:=xmelAsInvoker;
172 end;
173 
174 procedure TProjectXPManifest.SetUseManifest(const AValue: boolean);
175 begin
176   if FUseManifest = AValue then exit;
177   FUseManifest := AValue;
178   Modified := True;
179 end;
180 
181 procedure TProjectXPManifest.SetDpiAware(AValue: TXPManifestDpiAware);
182 begin
183   if FDpiAware = AValue then Exit;
184   FDpiAware := AValue;
185   Modified := True;
186 end;
187 
188 procedure TProjectXPManifest.SetExecutionLevel(AValue: TXPManifestExecutionLevel);
189 begin
190   if FExecutionLevel = AValue then Exit;
191   FExecutionLevel := AValue;
192   Modified := True;
193 end;
194 
195 procedure TProjectXPManifest.SetTextDesc(const AValue: string);
196 begin
197   if FTextDesc = AValue then Exit;
198   FTextDesc := AValue;
199   Modified := True;
200 end;
201 
202 procedure TProjectXPManifest.SetTextName(const AValue: string);
203 begin
204   if FTextName = AValue then Exit;
205   FTextName := AValue;
206   Modified := True;
207 end;
208 
209 procedure TProjectXPManifest.SetUIAccess(AValue: Boolean);
210 begin
211   if FUIAccess = AValue then Exit;
212   FUIAccess := AValue;
213   Modified := True;
214 end;
215 
216 constructor TProjectXPManifest.Create;
217 begin
218   inherited Create;
219   FIsDefaultOption := True;
220   UseManifest := False;
221   DpiAware := xmdaFalse;
222   ExecutionLevel := xmelAsInvoker;
223   UIAccess := False;
224   TextName := DefaultXPManifestTextName;
225   TextDesc := DefaultXPManifestTextDesc;
226 end;
227 
TProjectXPManifest.UpdateResourcesnull228 function TProjectXPManifest.UpdateResources(AResources: TAbstractProjectResources;
229   const MainFilename: string): Boolean;
230 var
231   Res: TGenericResource;
232   RName, RType: TResourceDesc;
233   ManifestFileData: String;
234 begin
235   Result := True;
236   if UseManifest then
237   begin
238     RType := TResourceDesc.Create(RT_MANIFEST);
239     RName := TResourceDesc.Create(1);
240     Res := TGenericResource.Create(RType, RName);
241     RType.Free; //no longer needed
242     RName.Free;
243     ManifestFileData := Format(sManifestFileData, [
244       TextName,
245       TextDesc,
246       ExecutionLevelToStr[ExecutionLevel],
247       BoolToStr(UIAccess, 'true', 'false'),
248       ManifestDpiAwareValues[DpiAware],
249       ManifestDpiAwarenessValues[DpiAware]]);
250     Res.RawData.Write(ManifestFileData[1], Length(ManifestFileData));
251     AResources.AddSystemResource(Res);
252   end;
253 end;
254 
255 procedure TProjectXPManifest.WriteToProjectFile(AConfig: TObject;
256   const Path: String);
257 begin
258   TXMLConfig(AConfig).SetDeleteValue(Path+'General/UseXPManifest/Value', UseManifest, False);
259   TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/DpiAware/Value', ManifestDpiAwareValues[DpiAware], ManifestDpiAwareValues[xmdaFalse]);
260   TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/ExecutionLevel/Value', ExecutionLevelToStr[ExecutionLevel], ExecutionLevelToStr[xmelAsInvoker]);
261   TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/UIAccess/Value', UIAccess, False);
262   TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/TextName/Value', TextName, DefaultXPManifestTextName);
263   TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/TextDesc/Value', TextDesc, DefaultXPManifestTextDesc);
264 end;
265 
266 procedure TProjectXPManifest.ReadFromProjectFile(AConfig: TObject;
267   const Path: String);
268 var
269   Cfg: TXMLConfig;
270 begin
271   Cfg := TXMLConfig(AConfig);
272   UseManifest := Cfg.GetValue(Path+'General/UseXPManifest/Value', False);
273 
274   //support prev values "True/False"
275   if Cfg.GetValue(Path+'Version/Value',0)<=9 then
276   begin
277     if Cfg.GetValue(Path+'General/XPManifest/DpiAware/Value', False) then
278       DpiAware := xmdaTrue
279     else
280       DpiAware := xmdaFalse;
281   end else
282     DpiAware := StrToXPManifestDpiAware(Cfg.GetValue(Path+'General/XPManifest/DpiAware/Value', ''));
283 
284   if Cfg.GetValue(Path+'Version/Value',0)<=9 then
285     ExecutionLevel := TXPManifestExecutionLevel(Cfg.GetValue(Path+'General/XPManifest/ExecutionLevel/Value', 0))
286   else
287     ExecutionLevel := StrToXPManifestExecutionLevel(Cfg.GetValue(Path+'General/XPManifest/ExecutionLevel/Value', ''));
288 
289   UIAccess := Cfg.GetValue(Path+'General/XPManifest/UIAccess/Value', False);
290   TextName := Cfg.GetValue(Path+'General/XPManifest/TextName/Value', TextName);
291   TextDesc := Cfg.GetValue(Path+'General/XPManifest/TextDesc/Value', TextDesc);
292 end;
293 
294 initialization
295   RegisterProjectResource(TProjectXPManifest);
296 
297 end.
298 
299