PageRenderTime 32ms CodeModel.GetById 19ms app.highlight 5ms RepoModel.GetById 1ms app.codeStats 1ms

/ide/w32manifest.pas

http://github.com/graemeg/lazarus
Pascal | 208 lines | 154 code | 20 blank | 34 comment | 6 complexity | 5d3e932ce54ca5a73b4428ce070fde9e MD5 | raw file
  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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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}
 33unit W32Manifest;
 34
 35{$mode objfpc}{$H+}
 36
 37interface
 38
 39uses
 40  Classes, SysUtils, FileUtil, Laz2_XMLCfg, LCLProc, Controls, Forms,
 41  CodeToolManager, LazConf, LResources,
 42  ProjectResourcesIntf, resource;
 43   
 44type
 45  TXPManifestExecutionLevel = (
 46    xmelAsInvoker,
 47    xmelHighestAvailable,
 48    xmelRequireAdministrator
 49  );
 50
 51  { TProjectXPManifest }
 52
 53  TProjectXPManifest = class(TAbstractProjectResource)
 54  private
 55    FExecutionLevel: TXPManifestExecutionLevel;
 56    FIsDpiaAware: boolean;
 57    FUIAccess: Boolean;
 58    FUseManifest: boolean;
 59    procedure SetDpiAware(const AValue: boolean);
 60    procedure SetExecutionLevel(AValue: TXPManifestExecutionLevel);
 61    procedure SetUIAccess(AValue: Boolean);
 62    procedure SetUseManifest(const AValue: boolean);
 63  public
 64    constructor Create; override;
 65    function UpdateResources(AResources: TAbstractProjectResources; const {%H-}MainFilename: string): Boolean; override;
 66    procedure WriteToProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
 67    procedure ReadFromProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
 68
 69    property UseManifest: boolean read FUseManifest write SetUseManifest;
 70    property DpiAware: boolean read FIsDpiaAware write SetDpiAware;
 71    property ExecutionLevel: TXPManifestExecutionLevel read FExecutionLevel write SetExecutionLevel;
 72    property UIAccess: Boolean read FUIAccess write SetUIAccess;
 73  end;
 74
 75const
 76  ExecutionLevelToStr: array[TXPManifestExecutionLevel] of String = (
 77    'asInvoker',
 78    'highestAvailable',
 79    'requireAdministrator'
 80  );
 81implementation
 82
 83const
 84  sManifestFileDataStart: String =
 85    '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>'#$D#$A+
 86    '<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">'#$D#$A+
 87    ' <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="CompanyName.ProductName.YourApp" type="win32"/>'#$D#$A+
 88    ' <description>Your application description here.</description>'#$D#$A+
 89    ' <dependency>'#$D#$A+
 90    '  <dependentAssembly>'#$D#$A+
 91    '   <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="*" publicKeyToken="6595b64144ccf1df" language="*"/>'#$D#$A+
 92    '  </dependentAssembly>'#$D#$A+
 93    ' </dependency>'#$D#$A+
 94    ' <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">'#$D#$A+
 95    '  <security>'#$D#$A+
 96    '   <requestedPrivileges>'#$D#$A+
 97    '    <requestedExecutionLevel level="%s" uiAccess="%s"/>'#$D#$A+
 98    '   </requestedPrivileges>'#$D#$A+
 99    '  </security>'#$D#$A+
100    ' </trustInfo>'#$D#$A+
101    ' <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1">'#$D#$A+
102    '  <application>'#$D#$A+
103    '   <!-- Windows Vista -->'#$D#$A+
104    '   <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}" />'#$D#$A+
105    '   <!-- Windows 7 -->'#$D#$A+
106    '   <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}" />'#$D#$A+
107    '   <!-- Windows 8 -->'#$D#$A+
108    '   <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}" />'#$D#$A+
109    '   <!-- Windows 8.1 -->'#$D#$A+
110    '   <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}" />'#$D#$A+
111    '   <!-- Windows 10 -->'#$D#$A+
112    '   <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}" />'#$D#$A+
113    '   </application>'#$D#$A+
114    '  </compatibility>'#$D#$A;
115  sManifestFileDataEnd: String =
116    '</assembly>';
117  sManifestFileDataDpiAware: String =
118    ' <asmv3:application xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">'#$D#$A+
119    '  <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">'#$D#$A+
120    '   <dpiAware>true</dpiAware>'#$D#$A+
121    '  </asmv3:windowsSettings>'#$D#$A+
122    ' </asmv3:application>'#$D#$A;
123
124procedure TProjectXPManifest.SetUseManifest(const AValue: boolean);
125begin
126  if FUseManifest = AValue then exit;
127  FUseManifest := AValue;
128  Modified := True;
129end;
130
131procedure TProjectXPManifest.SetDpiAware(const AValue: boolean);
132begin
133  if FIsDpiaAware = AValue then exit;
134  FIsDpiaAware := AValue;
135  Modified := True;
136end;
137
138procedure TProjectXPManifest.SetExecutionLevel(AValue: TXPManifestExecutionLevel);
139begin
140  if FExecutionLevel = AValue then Exit;
141  FExecutionLevel := AValue;
142  Modified := True;
143end;
144
145procedure TProjectXPManifest.SetUIAccess(AValue: Boolean);
146begin
147  if FUIAccess = AValue then Exit;
148  FUIAccess := AValue;
149  Modified := True;
150end;
151
152constructor TProjectXPManifest.Create;
153begin
154  inherited Create;
155  FIsDefaultOption := True;
156  UseManifest := False;
157  DpiAware := False;
158  ExecutionLevel := xmelAsInvoker;
159  UIAccess := False;
160end;
161
162function TProjectXPManifest.UpdateResources(AResources: TAbstractProjectResources;
163  const MainFilename: string): Boolean;
164var
165  Res: TGenericResource;
166  RName, RType: TResourceDesc;
167  ManifestFileData: String;
168begin
169  Result := True;
170  if UseManifest then
171  begin
172    RType := TResourceDesc.Create(RT_MANIFEST);
173    RName := TResourceDesc.Create(1);
174    Res := TGenericResource.Create(RType, RName);
175    RType.Free; //no longer needed
176    RName.Free;
177    ManifestFileData := Format(sManifestFileDataStart, [ExecutionLevelToStr[ExecutionLevel], BoolToStr(UIAccess, 'true', 'false')]);
178    if DpiAware then
179      ManifestFileData := ManifestFileData + sManifestFileDataDpiAware;
180    ManifestFileData := ManifestFileData + sManifestFileDataEnd;
181    Res.RawData.Write(ManifestFileData[1], Length(ManifestFileData));
182    AResources.AddSystemResource(Res);
183  end;
184end;
185
186procedure TProjectXPManifest.WriteToProjectFile(AConfig: TObject;
187  const Path: String);
188begin
189  TXMLConfig(AConfig).SetDeleteValue(Path+'General/UseXPManifest/Value', UseManifest, False);
190  TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/DpiAware/Value', DpiAware, False);
191  TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/ExecutionLevel/Value', Ord(ExecutionLevel), 0);
192  TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/UIAccess/Value', UIAccess, False);
193end;
194
195procedure TProjectXPManifest.ReadFromProjectFile(AConfig: TObject;
196  const Path: String);
197begin
198  UseManifest := TXMLConfig(AConfig).GetValue(Path+'General/UseXPManifest/Value', False);
199  DpiAware := TXMLConfig(AConfig).GetValue(Path+'General/XPManifest/DpiAware/Value', False);
200  ExecutionLevel := TXPManifestExecutionLevel(TXMLConfig(AConfig).GetValue(Path+'General/XPManifest/ExecutionLevel/Value', 0));
201  UIAccess := TXMLConfig(AConfig).GetValue(Path+'General/XPManifest/UIAccess/Value', False);
202end;
203
204initialization
205  RegisterProjectResource(TProjectXPManifest);
206
207end.
208