/ide/w32manifest.pas
http://github.com/graemeg/lazarus · Pascal · 208 lines · 154 code · 20 blank · 34 comment · 6 complexity · 5d3e932ce54ca5a73b4428ce070fde9e MD5 · raw file
- {
- /***************************************************************************
- w32manifest.pas - Lazarus IDE unit
- ---------------------------------------
- TProjectXPManifest is responsible for the inclusion of the
- manifest in windows executables.
- ***************************************************************************/
- ***************************************************************************
- * *
- * This source is free software; you can redistribute it and/or modify *
- * it under the terms of the GNU General Public License as published by *
- * the Free Software Foundation; either version 2 of the License, or *
- * (at your option) any later version. *
- * *
- * This code is distributed in the hope that it will be useful, but *
- * WITHOUT ANY WARRANTY; without even the implied warranty of *
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
- * General Public License for more details. *
- * *
- * A copy of the GNU General Public License is available on the World *
- * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
- * obtain it by writing to the Free Software Foundation, *
- * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
- * *
- ***************************************************************************
- The manifest file is needed for windows XP themes.
- The file is created in the directory, where the project exe is created.
- }
- unit W32Manifest;
- {$mode objfpc}{$H+}
- interface
- uses
- Classes, SysUtils, FileUtil, Laz2_XMLCfg, LCLProc, Controls, Forms,
- CodeToolManager, LazConf, LResources,
- ProjectResourcesIntf, resource;
-
- type
- TXPManifestExecutionLevel = (
- xmelAsInvoker,
- xmelHighestAvailable,
- xmelRequireAdministrator
- );
- { TProjectXPManifest }
- TProjectXPManifest = class(TAbstractProjectResource)
- private
- FExecutionLevel: TXPManifestExecutionLevel;
- FIsDpiaAware: boolean;
- FUIAccess: Boolean;
- FUseManifest: boolean;
- procedure SetDpiAware(const AValue: boolean);
- procedure SetExecutionLevel(AValue: TXPManifestExecutionLevel);
- procedure SetUIAccess(AValue: Boolean);
- procedure SetUseManifest(const AValue: boolean);
- public
- constructor Create; override;
- function UpdateResources(AResources: TAbstractProjectResources; const {%H-}MainFilename: string): Boolean; override;
- procedure WriteToProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
- procedure ReadFromProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
- property UseManifest: boolean read FUseManifest write SetUseManifest;
- property DpiAware: boolean read FIsDpiaAware write SetDpiAware;
- property ExecutionLevel: TXPManifestExecutionLevel read FExecutionLevel write SetExecutionLevel;
- property UIAccess: Boolean read FUIAccess write SetUIAccess;
- end;
- const
- ExecutionLevelToStr: array[TXPManifestExecutionLevel] of String = (
- 'asInvoker',
- 'highestAvailable',
- 'requireAdministrator'
- );
- implementation
- const
- sManifestFileDataStart: String =
- '<?xml version="1.0" encoding="UTF-8" standalone="yes"?>'#$D#$A+
- '<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">'#$D#$A+
- ' <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="CompanyName.ProductName.YourApp" type="win32"/>'#$D#$A+
- ' <description>Your application description here.</description>'#$D#$A+
- ' <dependency>'#$D#$A+
- ' <dependentAssembly>'#$D#$A+
- ' <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="*" publicKeyToken="6595b64144ccf1df" language="*"/>'#$D#$A+
- ' </dependentAssembly>'#$D#$A+
- ' </dependency>'#$D#$A+
- ' <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">'#$D#$A+
- ' <security>'#$D#$A+
- ' <requestedPrivileges>'#$D#$A+
- ' <requestedExecutionLevel level="%s" uiAccess="%s"/>'#$D#$A+
- ' </requestedPrivileges>'#$D#$A+
- ' </security>'#$D#$A+
- ' </trustInfo>'#$D#$A+
- ' <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1">'#$D#$A+
- ' <application>'#$D#$A+
- ' <!-- Windows Vista -->'#$D#$A+
- ' <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}" />'#$D#$A+
- ' <!-- Windows 7 -->'#$D#$A+
- ' <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}" />'#$D#$A+
- ' <!-- Windows 8 -->'#$D#$A+
- ' <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}" />'#$D#$A+
- ' <!-- Windows 8.1 -->'#$D#$A+
- ' <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}" />'#$D#$A+
- ' <!-- Windows 10 -->'#$D#$A+
- ' <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}" />'#$D#$A+
- ' </application>'#$D#$A+
- ' </compatibility>'#$D#$A;
- sManifestFileDataEnd: String =
- '</assembly>';
- sManifestFileDataDpiAware: String =
- ' <asmv3:application xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">'#$D#$A+
- ' <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">'#$D#$A+
- ' <dpiAware>true</dpiAware>'#$D#$A+
- ' </asmv3:windowsSettings>'#$D#$A+
- ' </asmv3:application>'#$D#$A;
- procedure TProjectXPManifest.SetUseManifest(const AValue: boolean);
- begin
- if FUseManifest = AValue then exit;
- FUseManifest := AValue;
- Modified := True;
- end;
- procedure TProjectXPManifest.SetDpiAware(const AValue: boolean);
- begin
- if FIsDpiaAware = AValue then exit;
- FIsDpiaAware := AValue;
- Modified := True;
- end;
- procedure TProjectXPManifest.SetExecutionLevel(AValue: TXPManifestExecutionLevel);
- begin
- if FExecutionLevel = AValue then Exit;
- FExecutionLevel := AValue;
- Modified := True;
- end;
- procedure TProjectXPManifest.SetUIAccess(AValue: Boolean);
- begin
- if FUIAccess = AValue then Exit;
- FUIAccess := AValue;
- Modified := True;
- end;
- constructor TProjectXPManifest.Create;
- begin
- inherited Create;
- FIsDefaultOption := True;
- UseManifest := False;
- DpiAware := False;
- ExecutionLevel := xmelAsInvoker;
- UIAccess := False;
- end;
- function TProjectXPManifest.UpdateResources(AResources: TAbstractProjectResources;
- const MainFilename: string): Boolean;
- var
- Res: TGenericResource;
- RName, RType: TResourceDesc;
- ManifestFileData: String;
- begin
- Result := True;
- if UseManifest then
- begin
- RType := TResourceDesc.Create(RT_MANIFEST);
- RName := TResourceDesc.Create(1);
- Res := TGenericResource.Create(RType, RName);
- RType.Free; //no longer needed
- RName.Free;
- ManifestFileData := Format(sManifestFileDataStart, [ExecutionLevelToStr[ExecutionLevel], BoolToStr(UIAccess, 'true', 'false')]);
- if DpiAware then
- ManifestFileData := ManifestFileData + sManifestFileDataDpiAware;
- ManifestFileData := ManifestFileData + sManifestFileDataEnd;
- Res.RawData.Write(ManifestFileData[1], Length(ManifestFileData));
- AResources.AddSystemResource(Res);
- end;
- end;
- procedure TProjectXPManifest.WriteToProjectFile(AConfig: TObject;
- const Path: String);
- begin
- TXMLConfig(AConfig).SetDeleteValue(Path+'General/UseXPManifest/Value', UseManifest, False);
- TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/DpiAware/Value', DpiAware, False);
- TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/ExecutionLevel/Value', Ord(ExecutionLevel), 0);
- TXMLConfig(AConfig).SetDeleteValue(Path+'General/XPManifest/UIAccess/Value', UIAccess, False);
- end;
- procedure TProjectXPManifest.ReadFromProjectFile(AConfig: TObject;
- const Path: String);
- begin
- UseManifest := TXMLConfig(AConfig).GetValue(Path+'General/UseXPManifest/Value', False);
- DpiAware := TXMLConfig(AConfig).GetValue(Path+'General/XPManifest/DpiAware/Value', False);
- ExecutionLevel := TXPManifestExecutionLevel(TXMLConfig(AConfig).GetValue(Path+'General/XPManifest/ExecutionLevel/Value', 0));
- UIAccess := TXMLConfig(AConfig).GetValue(Path+'General/XPManifest/UIAccess/Value', False);
- end;
- initialization
- RegisterProjectResource(TProjectXPManifest);
- end.