Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- unit RunElevatedSupport;
- {$WARN SYMBOL_PLATFORM OFF}
- {$R+}
- interface
- uses
- Windows;
- type
- TElevatedProc = function(const AParameters: String): Cardinal;
- TProcessMessagesMeth = procedure of object;
- var
- // Warning: this function will be executed in external process.
- // Do not use any global variables inside this routine!
- // Use only supplied AParameters.
- OnElevateProc: TElevatedProc;
- // Call this routine after you have assigned OnElevateProc
- procedure CheckForElevatedTask;
- // Runs OnElevateProc under full administrator rights
- function RunElevated(const AParameters: String; const AWnd: HWND = 0; const AProcessMessages: TProcessMessagesMeth = nil): Cardinal; overload;
- function IsAdministrator: Boolean;
- function IsAdministratorAccount: Boolean;
- function IsUACEnabled: Boolean;
- function IsElevated: Boolean;
- procedure SetButtonElevated(const AButtonHandle: THandle);
- implementation
- uses
- SysUtils, Registry, ShellAPI, ComObj;
- const
- RunElevatedTaskSwitch = '0CC5C50CB7D643B68CB900BF000FFFD5'; // some unique value, just a GUID with removed '[', ']', and '-'
- function CheckTokenMembership(TokenHandle: THANDLE; SidToCheck: Pointer; var IsMember: BOOL): BOOL; stdcall; external advapi32 name 'CheckTokenMembership';
- function RunElevated(const AParameters: String; const AWnd: HWND = 0; const AProcessMessages: TProcessMessagesMeth = nil): Cardinal; overload;
- var
- SEI: TShellExecuteInfo;
- Host: String;
- Args: String;
- begin
- Assert(Assigned(OnElevateProc), 'OnElevateProc must be assigned before calling RunElevated');
- if IsElevated then
- begin
- if Assigned(OnElevateProc) then
- Result := OnElevateProc(AParameters)
- else
- Result := ERROR_PROC_NOT_FOUND;
- Exit;
- end;
- Host := ParamStr(0);
- Args := Format('/%s %s', [RunElevatedTaskSwitch, AParameters]);
- FillChar(SEI, SizeOf(SEI), 0);
- SEI.cbSize := SizeOf(SEI);
- SEI.fMask := SEE_MASK_NOCLOSEPROCESS;
- {$IFDEF UNICODE}
- SEI.fMask := SEI.fMask or SEE_MASK_UNICODE;
- {$ENDIF}
- SEI.Wnd := AWnd;
- SEI.lpVerb := 'runas';
- SEI.lpFile := PChar(Host);
- SEI.lpParameters := PChar(Args);
- SEI.nShow := SW_NORMAL;
- if not ShellExecuteEx(@SEI) then
- RaiseLastOSError;
- try
- Result := ERROR_GEN_FAILURE;
- if Assigned(AProcessMessages) then
- begin
- repeat
- if not GetExitCodeProcess(SEI.hProcess, Result) then
- Result := ERROR_GEN_FAILURE;
- AProcessMessages;
- until Result <> STILL_ACTIVE;
- end
- else
- begin
- if WaitForSingleObject(SEI.hProcess, INFINITE) <> WAIT_OBJECT_0 then
- if not GetExitCodeProcess(SEI.hProcess, Result) then
- Result := ERROR_GEN_FAILURE;
- end;
- finally
- CloseHandle(SEI.hProcess);
- end;
- end;
- function IsAdministrator: Boolean;
- var
- psidAdmin: Pointer;
- B: BOOL;
- const
- SECURITY_NT_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
- SECURITY_BUILTIN_DOMAIN_RID = $00000020;
- DOMAIN_ALIAS_RID_ADMINS = $00000220;
- SE_GROUP_USE_FOR_DENY_ONLY = $00000010;
- begin
- psidAdmin := nil;
- try
- // Создаём SID группы админов для проверки
- Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
- SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0,
- psidAdmin));
- // Проверяем, входим ли мы в группу админов (с учётов всех проверок на disabled SID)
- if CheckTokenMembership(0, psidAdmin, B) then
- Result := B
- else
- Result := False;
- finally
- if psidAdmin <> nil then
- FreeSid(psidAdmin);
- end;
- end;
- {$R-}
- function IsAdministratorAccount: Boolean;
- var
- psidAdmin: Pointer;
- Token: THandle;
- Count: DWORD;
- TokenInfo: PTokenGroups;
- HaveToken: Boolean;
- I: Integer;
- const
- SECURITY_NT_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
- SECURITY_BUILTIN_DOMAIN_RID = $00000020;
- DOMAIN_ALIAS_RID_ADMINS = $00000220;
- SE_GROUP_USE_FOR_DENY_ONLY = $00000010;
- begin
- Result := Win32Platform <> VER_PLATFORM_WIN32_NT;
- if Result then
- Exit;
- psidAdmin := nil;
- TokenInfo := nil;
- HaveToken := False;
- try
- Token := 0;
- HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, Token);
- if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then
- HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token);
- if HaveToken then
- begin
- Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
- SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0,
- psidAdmin));
- if GetTokenInformation(Token, TokenGroups, nil, 0, Count) or
- (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
- RaiseLastOSError;
- TokenInfo := PTokenGroups(AllocMem(Count));
- Win32Check(GetTokenInformation(Token, TokenGroups, TokenInfo, Count, Count));
- for I := 0 to TokenInfo^.GroupCount - 1 do
- begin
- Result := EqualSid(psidAdmin, TokenInfo^.Groups[I].Sid);
- if Result then
- Break;
- end;
- end;
- finally
- if TokenInfo <> nil then
- FreeMem(TokenInfo);
- if HaveToken then
- CloseHandle(Token);
- if psidAdmin <> nil then
- FreeSid(psidAdmin);
- end;
- end;
- {$R+}
- function IsUACEnabled: Boolean;
- var
- Reg: TRegistry;
- begin
- Result := CheckWin32Version(6, 0);
- if Result then
- begin
- Reg := TRegistry.Create(KEY_READ);
- try
- Reg.RootKey := HKEY_LOCAL_MACHINE;
- if Reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System', False) then
- if Reg.ValueExists('EnableLUA') then
- Result := (Reg.ReadInteger('EnableLUA') <> 0)
- else
- Result := False
- else
- Result := False;
- finally
- FreeAndNil(Reg);
- end;
- end;
- end;
- function IsElevated: Boolean;
- const
- TokenElevation = TTokenInformationClass(20);
- type
- TOKEN_ELEVATION = record
- TokenIsElevated: DWORD;
- end;
- var
- TokenHandle: THandle;
- ResultLength: Cardinal;
- ATokenElevation: TOKEN_ELEVATION;
- HaveToken: Boolean;
- begin
- if CheckWin32Version(6, 0) then
- begin
- TokenHandle := 0;
- HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, TokenHandle);
- if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then
- HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle);
- if HaveToken then
- begin
- try
- ResultLength := 0;
- if GetTokenInformation(TokenHandle, TokenElevation, @ATokenElevation, SizeOf(ATokenElevation), ResultLength) then
- Result := ATokenElevation.TokenIsElevated <> 0
- else
- Result := False;
- finally
- CloseHandle(TokenHandle);
- end;
- end
- else
- Result := False;
- end
- else
- Result := IsAdministrator;
- end;
- procedure SetButtonElevated(const AButtonHandle: THandle);
- const
- BCM_SETSHIELD = $160C;
- var
- Required: BOOL;
- begin
- if not CheckWin32Version(6, 0) then
- Exit;
- if IsElevated then
- Exit;
- Required := True;
- SendMessage(AButtonHandle, BCM_SETSHIELD, 0, LPARAM(Required));
- end;
- procedure CheckForElevatedTask;
- function GetArgsForElevatedTask: String;
- function PrepareParam(const ParamNo: Integer): String;
- begin
- Result := ParamStr(ParamNo);
- if Pos(' ', Result) > 0 then
- Result := AnsiQuotedStr(Result, '"');
- end;
- var
- X: Integer;
- begin
- Result := '';
- for X := 1 to ParamCount do
- begin
- if (AnsiUpperCase(ParamStr(X)) = ('/' + RunElevatedTaskSwitch)) or
- (AnsiUpperCase(ParamStr(X)) = ('-' + RunElevatedTaskSwitch)) then
- Continue;
- Result := Result + PrepareParam(X) + ' ';
- end;
- Result := Trim(Result);
- end;
- var
- ExitCode: Cardinal;
- begin
- if not FindCmdLineSwitch(RunElevatedTaskSwitch) then
- Exit;
- ExitCode := ERROR_GEN_FAILURE;
- try
- if not IsElevated then
- ExitCode := ERROR_ACCESS_DENIED
- else
- if Assigned(OnElevateProc) then
- ExitCode := OnElevateProc(GetArgsForElevatedTask)
- else
- ExitCode := ERROR_PROC_NOT_FOUND;
- except
- on E: Exception do
- begin
- if E is EAbort then
- ExitCode := ERROR_CANCELLED
- else
- if E is EOleSysError then
- ExitCode := Cardinal(EOleSysError(E).ErrorCode)
- else
- if E is EOSError then
- else
- ExitCode := ERROR_GEN_FAILURE;
- end;
- end;
- if ExitCode = STILL_ACTIVE then
- ExitCode := ERROR_GEN_FAILURE;
- TerminateProcess(GetCurrentProcess, ExitCode);
- end;
- end.
- Usage:
- unit Unit1;
- interface
- uses
- Windows{....};
- type
- TForm1 = class(TForm)
- Label1: TLabel;
- Label2: TLabel;
- Label3: TLabel;
- Label4: TLabel;
- Button1: TButton;
- Button2: TButton;
- procedure FormCreate(Sender: TObject);
- procedure Button1Click(Sender: TObject);
- procedure Button2Click(Sender: TObject);
- private
- procedure StartWait;
- procedure EndWait;
- end;
- var
- Form1: TForm1;
- implementation
- uses
- RunElevatedSupport;
- {$R *.dfm}
- const
- ArgInstallUpdate = '/install_update';
- ArgRegisterExtension = '/register_global_file_associations';
- procedure TForm1.FormCreate(Sender: TObject);
- begin
- Label1.Caption := Format('IsAdministrator: %s', [BoolToStr(IsAdministrator, True)]);
- Label2.Caption := Format('IsAdministratorAccount: %s', [BoolToStr(IsAdministratorAccount, True)]);
- Label3.Caption := Format('IsUACEnabled: %s', [BoolToStr(IsUACEnabled, True)]);
- Label4.Caption := Format('IsElevated: %s', [BoolToStr(IsElevated, True)]);
- Button1.Caption := 'Install updates';
- SetButtonElevated(Button1.Handle);
- Button2.Caption := 'Register file associations for all users';
- SetButtonElevated(Button2.Handle);
- end;
- procedure TForm1.Button1Click(Sender: TObject);
- begin
- StartWait;
- try
- SetLastError(RunElevated(ArgInstallUpdate, Handle, Application.ProcessMessages));
- if GetLastError <> ERROR_SUCCESS then
- RaiseLastOSError;
- finally
- EndWait;
- end;
- end;
- procedure TForm1.Button2Click(Sender: TObject);
- begin
- StartWait;
- try
- SetLastError(RunElevated(ArgRegisterExtension, Handle, Application.ProcessMessages));
- if GetLastError <> ERROR_SUCCESS then
- RaiseLastOSError;
- finally
- EndWait;
- end;
- end;
- function DoElevatedTask(const AParameters: String): Cardinal;
- procedure InstallUpdate;
- var
- Msg: String;
- begin
- Msg := 'Hello from InstallUpdate!' + sLineBreak +
- sLineBreak +
- 'This function is running elevated under full administrator rights.' + sLineBreak +
- 'This means that you have write-access to Program Files folder and you''re able to overwrite files (e.g. install updates).' + sLineBreak +
- 'However, note that your executable is still running.' + sLineBreak +
- sLineBreak +
- 'IsAdministrator: ' + BoolToStr(IsAdministrator, True) + sLineBreak +
- 'IsAdministratorAccount: ' + BoolToStr(IsAdministratorAccount, True) + sLineBreak +
- 'IsUACEnabled: ' + BoolToStr(IsUACEnabled, True) + sLineBreak +
- 'IsElevated: ' + BoolToStr(IsElevated, True);
- MessageBox(0, PChar(Msg), 'Hello from InstallUpdate!', MB_OK or MB_ICONINFORMATION);
- end;
- procedure RegisterExtension;
- var
- Msg: String;
- begin
- Msg := 'Hello from RegisterExtension!' + sLineBreak +
- sLineBreak +
- 'This function is running elevated under full administrator rights.' + sLineBreak +
- 'This means that you have write-access to HKEY_LOCAL_MACHINE key and you''re able to write keys and values (e.g. register file extensions globally/for all users).' + sLineBreak +
- 'However, note that this is usually not a good idea. It is better to register your file extensions under HKEY_CURRENT_USER\Software\Classes.' + sLineBreak +
- sLineBreak +
- 'IsAdministrator: ' + BoolToStr(IsAdministrator, True) + sLineBreak +
- 'IsAdministratorAccount: ' + BoolToStr(IsAdministratorAccount, True) + sLineBreak +
- 'IsUACEnabled: ' + BoolToStr(IsUACEnabled, True) + sLineBreak +
- 'IsElevated: ' + BoolToStr(IsElevated, True);
- MessageBox(0, PChar(Msg), 'Hello from RegisterExtension!', MB_OK or MB_ICONINFORMATION);
- end;
- begin
- Result := ERROR_SUCCESS;
- if AParameters = ArgInstallUpdate then
- InstallUpdate
- else
- if AParameters = ArgRegisterExtension then
- RegisterExtension
- else
- Result := ERROR_GEN_FAILURE;
- end;
- procedure TForm1.StartWait;
- begin
- Cursor := crHourglass;
- Screen.Cursor := crHourglass;
- Button1.Enabled := False;
- Button2.Enabled := False;
- Application.ProcessMessages;
- end;
- procedure TForm1.EndWait;
- begin
- Cursor := crDefault;
- Screen.Cursor := crDefault;
- Button1.Enabled := True;
- Button2.Enabled := True;
- Application.ProcessMessages;
- end;
- initialization
- OnElevateProc := DoElevatedTask;
- CheckForElevatedTask;
- end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement