diff --git a/Packages/D2007/X2Utils.dpk b/Packages/D2007/X2Utils.dpk
index f4b7e6f..0e12d8b 100644
--- a/Packages/D2007/X2Utils.dpk
+++ b/Packages/D2007/X2Utils.dpk
@@ -52,6 +52,7 @@ contains
X2UtPersist in '..\..\X2UtPersist.pas',
X2UtPersistForm in '..\..\X2UtPersistForm.pas',
X2UtPersistIntf in '..\..\X2UtPersistIntf.pas',
- X2UtPersistRegistry in '..\..\X2UtPersistRegistry.pas';
+ X2UtPersistRegistry in '..\..\X2UtPersistRegistry.pas',
+ X2UtElevation in '..\..\X2UtElevation.pas';
end.
diff --git a/Packages/D2007/X2Utils.dproj b/Packages/D2007/X2Utils.dproj
index b87d6d7..da6ddd4 100644
--- a/Packages/D2007/X2Utils.dproj
+++ b/Packages/D2007/X2Utils.dproj
@@ -33,16 +33,6 @@
FalseTrueFalseX2UtilsTrueFalseTrue2007TrueFalse1000FalseFalseFalseFalseFalse104312521.0.0.01.0.0.0X2Utils.dpk
-
-
-
-
-
-
-
-
-
-
Microsoft Office 2000 Sample Automation Server Wrapper Components
Microsoft Office XP Sample Automation Server Wrapper Components
@@ -52,14 +42,12 @@
MainSource
-
-
-
+
@@ -78,5 +66,8 @@
+
+
+
\ No newline at end of file
diff --git a/X2UtElevation.pas b/X2UtElevation.pas
new file mode 100644
index 0000000..821d00c
--- /dev/null
+++ b/X2UtElevation.pas
@@ -0,0 +1,347 @@
+{
+ Helper functions and classes for writing UAC-compatible elevated COM objects.
+ Backwards-compatible with previous Windows versions.
+}
+unit X2UtElevation;
+
+interface
+uses
+ ActiveX,
+ ComObj;
+
+
+ { Checks if the current process has the elevation token. }
+ function IsElevated: Boolean;
+
+ { Creates an elevated instance of COM object. Returns False if the
+ user cancelled the elevation prompt. }
+ function CoCreateElevatedInstance(AParentWnd: THandle; AClassID: TCLSID;
+ AIID: TIID; var AIntf): Boolean;
+
+
+type
+ (*
+ Registers a COM object for elevation.
+
+ The ResourceID must point to a String Table resource in the current
+ module and contains the program name to display in the elevation prompt.
+
+ An example .rc file:
+
+ STRINGTABLE
+ {
+ 42, "Elevated COM Object"
+ }
+ *)
+ TElevatedClassFactory = class(TTypedComObjectFactory)
+ private
+ FResourceID: string;
+ public
+ constructor Create(const AResourceID: string; AComServer: TComServerObject;
+ ATypedComClass: TTypedComClass; const AClassID: TGUID;
+ AInstancing: TClassInstancing;
+ AThreadingModel: TThreadingModel = tmSingle);
+
+ procedure UpdateRegistry(Register: Boolean); override;
+
+ property ResourceID: string read FResourceID;
+ end;
+
+
+implementation
+uses
+ ComConst,
+ SysUtils,
+ Windows,
+
+ X2UtOS;
+
+
+type
+ BIND_OPTS3 = packed record
+ cbStruct: DWORD;
+ grfFlags: DWORD;
+ grfMode: DWORD;
+ dwTickCountDeadline: DWORD;
+ dwTrackFlags: DWORD;
+ dwClassContext: DWORD;
+ locale: LCID;
+ pServerInfo: PCOSERVERINFO;
+ hwnd: HWND;
+ end;
+ PBIND_OPTS3 = ^BIND_OPTS3;
+
+ TOKEN_INFORMATION_CLASS = (
+ TokenICPad,
+ TokenUser,
+ TokenGroups,
+ TokenPrivileges,
+ TokenOwner,
+ TokenPrimaryGroup,
+ TokenDefaultDacl,
+ TokenSource,
+ TokenType,
+ TokenImpersonationLevel,
+ TokenStatistics,
+ TokenRestrictedSids,
+ TokenSessionId,
+ TokenGroupsAndPrivileges,
+ TokenSessionReference,
+ TokenSandBoxInert,
+ TokenAuditPolicy,
+ TokenOrigin,
+ TokenElevationType,
+ TokenLinkedToken,
+ TokenElevation,
+ TokenHasRestrictions,
+ TokenAccessInformation,
+ TokenVirtualizationAllowed,
+ TokenVirtualizationEnabled,
+ TokenIntegrityLevel,
+ TokenUIAccess,
+ TokenMandatoryPolicy,
+ TokenLogonSid,
+ MaxTokenInfoClass
+ );
+
+ TOKEN_ELEVATION = packed record
+ TokenIsElevated: DWORD;
+ end;
+ PTOKEN_ELEVATION = ^TOKEN_ELEVATION;
+
+
+ { Who in the advapi32 team came up with this name?! Descriptive for sure. }
+ TConvertStringSecurityDescriptorToSecurityDescriptorA = function(StringSecurityDescriptor: PAnsiChar;
+ StringSDRevision: Cardinal;
+ var SecurityDescriptor: PSecurityDescriptor;
+ var SecurityDescriptorSize: Cardinal): LongBool; stdcall;
+
+ TCoGetObject = function(pszName: PWideChar; pBindOptions: PBIND_OPTS3;
+ const iid: TIID; out ppv): HResult; stdcall; //external 'ole32.dll' name 'CoGetObject';
+
+ TOpenProcessToken = function(ProcessHandle: THandle; DesiredAccess: DWORD;
+ var TokenHandle: THandle): BOOL; stdcall;
+
+ TGetTokenInformation = function(TokenHandle: THandle;
+ TokenInformationClass: TOKEN_INFORMATION_CLASS;
+ TokenInformation: Pointer;
+ TokenInformationLength: DWORD;
+ var ReturnLength: DWORD): BOOL; stdcall;
+
+
+var
+ ConvertStringSecurityDescriptorToSecurityDescriptorA: TConvertStringSecurityDescriptorToSecurityDescriptorA;
+ CoGetObject: TCoGetObject;
+ OpenProcessToken: TOpenProcessToken;
+ GetTokenInformation: TGetTokenInformation;
+
+
+
+{ Helper functions }
+function IsElevated: Boolean;
+var
+ tokenHandle: THandle;
+ tokenInfo: TOKEN_ELEVATION;
+ dummy: Cardinal;
+
+begin
+ Result := False;
+ if (not Assigned(OpenProcessToken)) or
+ (not Assigned(GetTokenInformation)) then
+ Exit;
+
+
+ if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, tokenHandle) then
+ begin
+ dummy := 0;
+
+ if GetTokenInformation(tokenHandle, TokenElevation, @tokenInfo, SizeOf(TOKEN_ELEVATION), dummy) then
+ Result := (tokenInfo.TokenIsElevated <> 0);
+
+ CloseHandle(tokenHandle);
+ end;
+end;
+
+
+function CoCreateElevatedInstance(AParentWnd: THandle; AClassID: TCLSID;
+ AIID: TIID; var AIntf): Boolean;
+var
+ bindOptions: BIND_OPTS3;
+ monikerName: WideString;
+ status: HRESULT;
+
+begin
+ Result := True;
+
+ if OS.SupportsUAC and (not IsElevated) then
+ begin
+ { Use elevation moniker }
+ monikerName := 'Elevation:Administrator!new:' + GUIDToString(AClassID);
+
+ FillChar(bindOptions, SizeOf(bindOptions), 0);
+ bindOptions.cbStruct := SizeOf(bindOptions);
+ bindOptions.dwClassContext := CLSCTX_LOCAL_SERVER;
+ bindOptions.hwnd := AParentWnd;
+
+ status := CoGetObject(PWideChar(monikerName), @bindOptions, aIID, AIntf);
+ if HResultCode(status) = ERROR_CANCELLED then
+ Result := False
+ else
+ OleCheck(status);
+ end else
+ { Use good ole' CoCreateInstance }
+ OleCheck(CoCreateInstance(AClassID, nil, CLSCTX_ALL, AIID, AIntf));
+end;
+
+
+{ Internal helper functions }
+procedure LoadAPIFunctions;
+var
+ dllHandle: THandle;
+
+begin
+ dllHandle := GetModuleHandle(advapi32);
+ if dllHandle <> 0 then
+ begin
+ @ConvertStringSecurityDescriptorToSecurityDescriptorA := GetProcAddress(dllHandle, 'ConvertStringSecurityDescriptorToSecurityDescriptorA');
+ @OpenProcessToken := GetProcAddress(dllHandle, 'OpenProcessToken');
+ @GetTokenInformation := GetProcAddress(dllHandle, 'GetTokenInformation');
+ end;
+
+ dllHandle := GetModuleHandle('ole32.dll');
+ if dllHandle <> 0 then
+ @CoGetObject := GetProcAddress(dllHandle, 'CoGetObject');
+end;
+
+
+procedure CreateRegKeyDWORD(const AKey, AValue: string; AData: DWORD; ARootKey: HKEY = HKEY_CLASSES_ROOT);
+var
+ keyHandle: HKEY;
+ status: Integer;
+ disposition: Integer;
+
+begin
+ status := RegCreateKeyEx(ARootKey, PChar(AKey), 0, '',
+ REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil,
+ keyHandle, @disposition);
+
+ if status = ERROR_SUCCESS then
+ begin
+ status := RegSetValueEx(keyHandle, PChar(AValue), 0, REG_DWORD,
+ @AData, SizeOf(DWORD));
+ RegCloseKey(keyHandle);
+ end;
+
+ if status <> ERROR_SUCCESS then
+ raise EOleRegistrationError.CreateRes(@SCreateRegKeyError);
+end;
+
+
+procedure SetAccessPermission(const AKey: string);
+const
+ LocalCallSecDesc = 'O:BAG:BAD:(A;;0x3;;;IU)(A;;0x3;;;SY)';
+
+const
+ SDDL_REVISION_1 = 1;
+
+var
+ descriptor: PSecurityDescriptor;
+ size: Cardinal;
+ keyHandle: HKEY;
+
+begin
+ if not Assigned(ConvertStringSecurityDescriptorToSecurityDescriptorA) then
+ Exit;
+
+ if not ConvertStringSecurityDescriptorToSecurityDescriptorA(LocalCallSecDesc,
+ SDDL_REVISION_1,
+ descriptor, size) then
+ RaiseLastOSError;
+
+ try
+ if RegOpenKeyExA(HKEY_CLASSES_ROOT, PChar(AKey), 0, KEY_READ or KEY_WRITE, keyHandle) = ERROR_SUCCESS then
+ try
+ if RegSetValueExA(keyHandle, PChar('AccessPermission'), 0, REG_BINARY, descriptor, size) <> ERROR_SUCCESS then
+ RaiseLastOSError;
+ finally
+ RegCloseKey(keyHandle);
+ end else
+ RaiseLastOSError;
+ finally
+ LocalFree(Cardinal(descriptor));
+ end;
+end;
+
+
+{ TElevatedClassFactory }
+constructor TElevatedClassFactory.Create(const AResourceID: string;
+ AComServer: TComServerObject;
+ ATypedComClass: TTypedComClass;
+ const AClassID: TGUID;
+ AInstancing: TClassInstancing;
+ AThreadingModel: TThreadingModel);
+begin
+ inherited Create(AComServer, ATypedComClass, AClassID, AInstancing,
+ AThreadingModel);
+
+ FResourceID := AResourceID;
+end;
+
+
+procedure TElevatedClassFactory.UpdateRegistry(Register: Boolean);
+var
+ classIDAsString: string;
+ filePath: string;
+ fileName: string;
+ appRegKey: string;
+ classRegKey: string;
+
+begin
+ if not OS.SupportsUAC then
+ begin
+ inherited;
+ Exit;
+ end;
+
+ try
+ classIDAsString := GUIDToString(Self.ClassID);
+ filePath := ComServer.ServerFileName;
+ fileName := ExtractFileName(filePath);
+
+ appRegKey := 'AppID\' + classIDAsString;
+ classRegKey := 'CLSID\' + classIDAsString;
+
+ if Register then
+ begin
+ inherited;
+
+ { Out-of-process }
+ CreateRegKey(appRegKey, '', Description);
+ CreateRegKey(appRegKey, 'DllSurrogate', '');
+ CreateRegKey('AppID\' + fileName, 'AppID', classIDAsString);
+
+ { Over-The-Shoulder elevation }
+ SetAccessPermission(appRegKey);
+
+ { COM object elevation }
+ CreateRegKey(classRegKey, 'AppID', classIDAsString);
+ CreateRegKey(classRegKey, 'LocalizedString', '@' + filePath + ',-' + fResourceId);
+ CreateRegKeyDWORD(classRegKey + '\Elevation', 'Enabled', 1);
+ end else begin
+ DeleteRegKey(classRegKey + '\Elevation');
+ DeleteRegKey(appRegKey);
+ DeleteRegKey('AppID\' + fileName);
+
+ inherited;
+ end;
+ except
+ on E: Exception do
+ raise EOleRegistrationError.Create(E.Message);
+ end;
+end;
+
+
+initialization
+ LoadAPIFunctions;
+
+end.
diff --git a/X2UtOS.pas b/X2UtOS.pas
index ef4d8b2..ecc8def 100644
--- a/X2UtOS.pas
+++ b/X2UtOS.pas
@@ -14,9 +14,25 @@ uses
Windows;
type
+ TOSVersionInfoEx = packed record
+ dwOSVersionInfoSize: DWORD;
+ dwMajorVersion: DWORD;
+ dwMinorVersion: DWORD;
+ dwBuildNumber: DWORD;
+ dwPlatformId: DWORD;
+ szCSDVersion: array[0..127] of AnsiChar;
+ wServicePackMajor: WORD;
+ wServicePackMinor: WORD;
+ wSuiteMask: WORD;
+ wProductType: Byte;
+ wReserved: Byte;
+ end;
+
+
//:$ Enumeration of the recognized Operating System versions
TX2OSVersion = (osWin95, osWin98, osWinME, osWinNT3, osWinNT4,
- osWin2K, osWinXP, osWin2003, osWinVista, osUnknown);
+ osWin2K, osWinXP, osWin2003, osWinVista, osWinServer2008,
+ osWin7, osUnknown);
//:$ Record to hold the Common Controls version
TX2CCVersion = record
@@ -33,19 +49,19 @@ type
FName: String;
FVersionString: String;
FBuild: Cardinal;
- FRawInfo: TOSVersionInfo;
+ FRawInfo: TOSVersionInfoEx;
public
//:$ Contains the name of the OS
- property Name: String read FName write FName;
+ property Name: String read FName write FName;
//:$ Contains a string representation of the OS' version
- property VersionString: String read FVersionString write FVersionString;
+ property VersionString: String read FVersionString write FVersionString;
//:$ Contains the build number of the OS
- property Build: Cardinal read FBuild write FBuild;
+ property Build: Cardinal read FBuild write FBuild;
//:$ Contains the raw version information as provided by the OS
- property RawInfo: TOSVersionInfo read FRawInfo write FRawInfo;
+ property RawInfo: TOSVersionInfoEx read FRawInfo write FRawInfo;
end;
{
@@ -57,22 +73,27 @@ type
FVersion: TX2OSVersion;
FVersionEx: TX2OSVersionEx;
- function GetXPManifest(): Boolean;
+ function GetSupportsUAC: Boolean;
+ function GetXPManifest: Boolean;
protected
- procedure GetVersion(); virtual;
- procedure GetCCVersion(); virtual;
+ procedure GetVersion; virtual;
+ procedure GetCCVersion; virtual;
public
- constructor Create();
- destructor Destroy(); override;
+ constructor Create;
+ destructor Destroy; override;
//:$ Returns the formatted version information
//:: If Build is False, the return value will not include the
//:: OS' Build number.
function FormatVersion(Build: Boolean = True): String;
+
//:$ Contains the Common Controls version
property ComCtlVersion: TX2CCVersion read FCCVersion;
+ //:$ Checks if the OS supports User Account Control
+ property SupportsUAC: Boolean read GetSupportsUAC;
+
//:$ Checks if the application uses an XP manifest
//:: If present, Common Controls version 6 or higher is available.
property XPManifest: Boolean read GetXPManifest;
@@ -84,8 +105,30 @@ type
property VersionEx: TX2OSVersionEx read FVersionEx;
end;
- function OS(): TX2OS;
+ function OS: TX2OS;
+
+const
+ { NT Product types: used by dwProductType field }
+ VER_NT_WORKSTATION = $0000001;
+ VER_NT_DOMAIN_CONTROLLER = $0000002;
+ VER_NT_SERVER = $0000003;
+
+ { NT product suite mask values: used by wSuiteMask field }
+ VER_SUITE_SMALLBUSINESS = $00000001;
+ VER_SUITE_ENTERPRISE = $00000002;
+ VER_SUITE_BACKOFFICE = $00000004;
+ VER_SUITE_COMMUNICATIONS = $00000008;
+ VER_SUITE_TERMINAL = $00000010;
+ VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020;
+ VER_SUITE_EMBEDDEDNT = $00000040;
+ VER_SUITE_DATACENTER = $00000080;
+ VER_SUITE_SINGLEUSERTS = $00000100;
+ VER_SUITE_PERSONAL = $00000200;
+ VER_SUITE_SERVERAPPLIANCE = $00000400;
+ VER_SUITE_BLADE = VER_SUITE_SERVERAPPLIANCE;
+
+
implementation
uses
SysUtils;
@@ -115,7 +158,7 @@ var
function OS;
begin
if not Assigned(GOS) then
- GOS := TX2OS.Create();
+ GOS := TX2OS.Create;
Result := GOS;
end;
@@ -128,9 +171,9 @@ constructor TX2OS.Create;
begin
inherited;
- FVersionEx := TX2OSVersionEx.Create();
- GetVersion();
- GetCCVersion();
+ FVersionEx := TX2OSVersionEx.Create;
+ GetVersion;
+ GetCCVersion;
end;
destructor TX2OS.Destroy;
@@ -146,73 +189,102 @@ end;
========================================}
procedure TX2OS.GetVersion;
var
- pVersion: TOSVersionInfo;
+ versionInfo: TOSVersionInfoEx;
+ versionInfoPtr: POSVersionInfo;
begin
FVersion := osUnknown;
{ Get version information }
- pVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
- GetVersionEx(pVersion);
+ FillChar(versionInfo, SizeOf(versionInfo), 0);
+ versionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfoEx);
+
+ versionInfoPtr := @versionInfo;
+
+ if not GetVersionEx(versionInfoPtr^) then
+ begin
+ { Maybe this is an older Windows version, not supporting the Ex fields }
+ versionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
+ if not GetVersionEx(versionInfoPtr^) then
+ RaiseLastOSError;
+ end;
with FVersionEx do
begin
{ No Kylix support yet, sorry! }
- RawInfo := pVersion;
+ RawInfo := versionInfo;
Name := 'Windows';
- case pVersion.dwMajorVersion of
+ case versionInfo.dwMajorVersion of
3: { Windows NT 3.51 }
- FVersion := osWinNT3;
+ FVersion := osWinNT3;
4: { Windows 95/98/ME/NT 4 }
- case pVersion.dwMinorVersion of
+ case versionInfo.dwMinorVersion of
0: { Windows 95/NT 4 }
- case pVersion.dwPlatformId of
+ case versionInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT: { Windows NT 4 }
- FVersion := osWinNT4;
+ FVersion := osWinNT4;
VER_PLATFORM_WIN32_WINDOWS: { Windows 95 }
- FVersion := osWin95;
+ FVersion := osWin95;
end;
10: { Windows 98 }
- FVersion := osWin98;
+ FVersion := osWin98;
90: { Windows ME }
- FVersion := osWinME;
+ FVersion := osWinME;
end;
5: { Windows 2000/XP/2003 }
- case pVersion.dwMinorVersion of
+ case versionInfo.dwMinorVersion of
0: { Windows 2000 }
- FVersion := osWin2K;
+ FVersion := osWin2K;
1: { Windows XP }
- FVersion := osWinXP;
+ FVersion := osWinXP;
2: { Windows Server 2003 }
- FVersion := osWin2003;
+ FVersion := osWin2003;
+ end;
+ 6: { Windows Vista/Server 2008/7 }
+ if versionInfo.wProductType = VER_NT_WORKSTATION then
+ begin
+ case versionInfo.dwMinorVersion of
+ 0: { Windows Vista }
+ FVersion := osWinVista;
+ 1: { Windows 7 }
+ FVersion := osWin7;
+ end;
+ end else
+ begin
+ case versionInfo.dwMinorVersion of
+ 0, { Windows Server 2008 }
+ 1: { Windows Server 2008 R2 }
+ FVersion := osWinServer2008;
+ end;
end;
- 6: { Windows Vista/Server 2008 }
- FVersion := osWinVista;
end;
case Version of
- osWin95: VersionString := '95';
- osWin98: VersionString := '98';
- osWinME: VersionString := 'ME';
- osWinNT3: VersionString := 'NT 3.51';
- osWinNT4: VersionString := 'NT 4';
- osWin2K: VersionString := '2000';
- osWinXP: VersionString := 'XP';
- osWin2003: VersionString := 'Server 2003';
- osWinVista: VersionString := 'Vista';
- osUnknown: VersionString := Format('%d.%d', [pVersion.dwMajorVersion,
- pVersion.dwMinorVersion]);
+ osWin95: VersionString := '95';
+ osWin98: VersionString := '98';
+ osWinME: VersionString := 'ME';
+ osWinNT3: VersionString := 'NT 3.51';
+ osWinNT4: VersionString := 'NT 4';
+ osWin2K: VersionString := '2000';
+ osWinXP: VersionString := 'XP';
+ osWin2003: VersionString := 'Server 2003';
+ osWinVista: VersionString := 'Vista';
+ osWin7: VersionString := '7';
+ osWinServer2008: VersionString := 'Server 2008';
+ else
+ VersionString := Format('%d.%d', [versionInfo.dwMajorVersion,
+ versionInfo.dwMinorVersion]);
end;
- if StrLen(pVersion.szCSDVersion) > 0 then
- VersionString := VersionString + ' ' + pVersion.szCSDVersion;
+ if StrLen(versionInfo.szCSDVersion) > 0 then
+ VersionString := VersionString + ' ' + versionInfo.szCSDVersion;
- case pVersion.dwPlatformId of
+ case versionInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT:
- Build := pVersion.dwBuildNumber;
+ Build := versionInfo.dwBuildNumber;
VER_PLATFORM_WIN32_WINDOWS:
- Build := LoWord(pVersion.dwBuildNumber);
+ Build := LoWord(versionInfo.dwBuildNumber);
end;
end;
end;
@@ -234,7 +306,7 @@ begin
begin
FillChar(viVersion, SizeOf(viVersion), #0);
viVersion.cbSize := SizeOf(viVersion);
-
+
DllGetVersion(@viVersion);
with FCCVersion do
@@ -249,27 +321,34 @@ begin
end;
end;
-function TX2OS.GetXPManifest;
-begin
- Result := (FCCVersion.Major >= 6);
-end;
-
function TX2OS.FormatVersion;
var
sBuild: String;
begin
- sBuild := '';
+ sBuild := '';
if Build then
- sBuild := Format(' build %d', [FVersionEx.Build]);
+ sBuild := Format(' build %d', [FVersionEx.Build]);
with FVersionEx do
Result := Format('%s %s%s', [Name, VersionString, sBuild]);
end;
+function TX2OS.GetXPManifest;
+begin
+ Result := (FCCVersion.Major >= 6);
+end;
+
+
+function TX2OS.GetSupportsUAC: Boolean;
+begin
+ Result := (FVersionEx.RawInfo.dwMajorVersion >= 6);
+end;
+
+
initialization
finalization
FreeAndNil(GOS);