Delphi: solicite elevación UAC cuando sea necesario

elevation

Question

Necesitamos cambiar algunas configuraciones a HKEY_LOCAL_MACHINE en el tiempo de ejecución.

¿Es posible solicitar elevación de uac si es necesario en tiempo de ejecución, o tengo que iniciar un segundo proceso elevado para hacer ''el trabajo sucio''?

Answer 1

Generalmente, poner el texto "Configurar" o "Instalar" en algún lugar de su nombre EXE es suficiente para hacer que Windows se ejecute con privilegios elevados automáticamente, y vale la pena hacerlo si es una utilidad de configuración que está escribiendo, ya que es muy fácil de hacer.

Ahora estoy teniendo problemas en Windows 7, cuando no estoy conectado como administrador, y tengo que usar el botón derecho como Administrador de ejecución cuando se ejecuta manualmente (ejecutar el programa a través del asistente de instalación de Wise todavía está bien)

Aunque veo que Delphi 10.1 Berlin tiene una nueva opción muy fácil de usar en Opciones de proyecto | Solicitud. Simplemente marque Permitir privilegios de administrador y el manifiesto estará listo para usted, ¡así de fácil!

NÓTESE BIEN. asegúrese de realizar este tipo de cambios solamente a través de un programa de instalación separado, ejecutar su aplicación con privilegios elevados todo el tiempo puede causar problemas con otras cosas, por ejemplo, correo electrónico, donde el perfil de correo predeterminado ya no se recupera.

Edición: enero de 2018: desde que se escribió esta respuesta en agosto de 2017, parece haber salido una gran cantidad de actualizaciones de Windows, que ahora requieren que el usuario haga clic derecho y ejecutar como administrador en casi todo, incluso en el exe de instalación creado con Wise. Incluso Outlook ya no se instala correctamente sin ejecutar como administrador. No hay más elevación automática en todo parece.

Answer 2

No puede "elevar" un proceso existente. Los procesos elevados bajo UAC tienen un token diferente con un LUID diferente, un nivel de integridad obligatorio diferente y una membresía de grupo diferente. Este nivel de cambio no se puede hacer dentro de un proceso en ejecución, y sería un problema de seguridad si eso pudiera suceder.

Debe iniciar un segundo proceso elevado que haría el trabajo o creando un objeto COM que se ejecute en un servidor dllhost elevado.

http://msdn.microsoft.com/en-us/library/bb756922.aspx proporciona una función de ejemplo "RunAsAdmin" y una función "CoCreateInstanceAsAdmin".

EDITAR: Acabo de ver "Delphi" en su título. Todo lo que enumeré es obviamente nativo, pero si Delphi proporciona acceso a la funcionalidad similar a ShellExecute, debería ser capaz de adaptar el código desde el enlace.

Answer 3

Una muestra de código listo para usar :

Ejemplo de uso:

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.

Y la unidad de soporte en sí:

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.

Answer 4

me relanzaría como parámetros de línea de comando elevados y pasados ​​que indican qué cosa elevada desea hacer. A continuación, puede ir directamente a la forma adecuada, o simplemente guardar sus cosas HKLM.

function RunAsAdmin(hWnd: HWND; filename: string; Parameters: string): Boolean;
{
See Step 3: Redesign for UAC Compatibility (UAC)
http://msdn.microsoft.com/en-us/library/bb756922.aspx
This code is released into the public domain. No attribution required.
}
var
sei: TShellExecuteInfo;
begin
ZeroMemory(@sei, SizeOf(sei));
sei.cbSize := SizeOf(TShellExecuteInfo);
sei.Wnd := hwnd;
sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
sei.lpVerb := PChar(''runas'');
sei.lpFile := PChar(Filename); // PAnsiChar;
if parameters <> '''' then
sei.lpParameters := PChar(parameters); // PAnsiChar;
sei.nShow := SW_SHOWNORMAL; //Integer;
Result := ShellExecuteEx(@sei);
end;

La otra solución sugerida por Microsoft es crear un objeto COM fuera de proceso (usando la función CoCreateInstanceAsAdmin especialmente creada). No me gusta esta idea porque debe escribir y registrar un objeto COM.

Nota: No hay llamada a la API "CoCreateInstanceAsAdmin". Es solo un código flotando alrededor. Aquí está la versión de Dephi con la que tropecé. Al parecer, se basa en el truco de anteponer una cadena guid de clase con el prefijo " Elevation: Administrator! New: " cuando el código normalmente oculto internamente llama a CoGetObject :

function CoGetObject(pszName: PWideChar; pBindOptions: PBindOpts3;
const iid: TIID; ppv: PPointer): HResult; stdcall; external ''ole32.dll'';
procedure CoCreateInstanceAsAdmin(const Handle: HWND;
const ClassID, IID: TGuid; PInterface: PPointer);
var
BindOpts: TBindOpts3;
MonikerName: WideString;
Res: HRESULT;
begin
//This code is released into the public domain. No attribution required.
ZeroMemory(@BindOpts, Sizeof(TBindOpts3));
BindOpts.cbStruct := Sizeof(TBindOpts3);
BindOpts.hwnd := Handle;
BindOpts.dwClassContext := CLSCTX_LOCAL_SERVER;
MonikerName := ''Elevation:Administrator!new:'' + GUIDToString(ClassID);
Res := CoGetObject(PWideChar(MonikerName), @BindOpts, IID, PInterface);
if Failed(Res) then
raise Exception.Create(SysErrorMessage(Res));
end;

Otra pregunta: ¿cómo maneja a alguien corriendo como usuario estándar en Windows XP?