Delphi:需要时提示UAC提升

时间:2021-11-21 23:54:03

We need to change some settings to the HKEY_LOCAL_MACHINE at runtime.

我们需要在运行时将一些设置更改为HKEY_LOCAL_MACHINE。

Is it possible to prompt for uac elevation if needed at runtime, or do I have to launch a second elevated process to do 'the dirty work'?

是否可以在运行时根据需要提示uac提升,或者我是否必须启动第二个提升的流程来执行“脏工作”?

4 个解决方案

#1


i would relaunch yourself as elevated, passing command line parameters indicating what elevated thing you want to do. You can then jump right to the appropriate form, or just save your HKLM stuff.

我会重新启动自己作为提升,传递命令行参数,指示你想要做什么升高的事情。然后,您可以直接跳到相应的表单,或者只保存您的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;

The other Microsoft suggested solution is to create an COM object out of process (using the specially created CoCreateInstanceAsAdmin function). i don't like this idea because you have to write and register a COM object.

另一个Microsoft建议的解决方案是在进程外创建一个COM对象(使用专门创建的CoCreateInstanceAsAdmin函数)。我不喜欢这个想法,因为你必须编写并注册一个COM对象。


Note: There is no "CoCreateInstanceAsAdmin" API call. It's just some code floating around. Here's the Dephi version i stumbled around for. It is apparently based on the trick of prefixing a class guid string with the "Elevation:Administrator!new:" prefix when normally hidden code internally calls CoGetObject:

注意:没有“CoCreateInstanceAsAdmin”API调用。这只是一些浮动的代码。这是我偶然发现的Dephi版本。它显然是基于通常隐藏代码在内部调用CoGetObject时使用“Elevation:Administrator!new:”前缀为类guid字符串添加前缀的技巧:

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;

One other question: How do you handle someone running as standard user in Windows XP?

另一个问题:如何处理在Windows XP中作为标准用户运行的人?

#2


You can't "elevate" an existing process. Elevated processes under UAC have a different token with a different LUID, different mandatory integrity level, and different group membership. This level of change can't be done within a running process - and it would be a security problem if that could happen.

您无法“提升”现有流程。 UAC下的高级进程具有不同的令牌,具有不同的LUID,不同的强制完整性级别和不同的组成员身份。这种更改级别无法在正在运行的进程中完成 - 如果发生这种情况,则会出现安全问题。

You need to launch a second process elevated that would do the work or by creating a COM object that runs in an elevated dllhost.

您需要启动第二个进程升级才能完成工作,或者创建一个在提升的dllhost中运行的COM对象。

http://msdn.microsoft.com/en-us/library/bb756922.aspx gives an example "RunAsAdmin" function and a "CoCreateInstanceAsAdmin" function.

http://msdn.microsoft.com/en-us/library/bb756922.aspx给出了一个示例“RunAsAdmin”函数和一个“CoCreateInstanceAsAdmin”函数。

EDIT: I just saw "Delphi" in your title. Everything I listed is obviously native, but if Delphi provides access to ShellExecute-like functionality you should be able to adapt the code from the link.

编辑:我刚刚在你的标题中看到了“Delphi”。我列出的所有内容显然都是原生的,但如果Delphi提供对类似ShellExecute的功能的访问,您应该能够调整链接中的代码。

#3


A sample of ready-to-use code:

即用型代码示例:

Usage example:

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.

And support unit itself:

并支持单位本身:

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.

#4


Usually, putting the text "Setup" or "Install" somewhere in your EXE name is enough to make Windows run with elevated privileges automatically, and is well worth doing if it is a setup utility you are writing, as it's so easy to do.

通常,将文本“设置”或“安装”放在EXE名称中的某个位置足以使Windows自动以提升的权限运行,如果它是您正在编写的设置实用程序,则非常值得做,因为它很容易实现。

I am now running into problems though on Windows 7, when not logged in as an Administrator, and am having to use the right-click Run As Administrator when running manually (running the program via Wise installation wizard is still fine)

我现在遇到的问题虽然在Windows 7上没有以管理员身份登录,并且在手动运行时必须使用右键单击“以管理员身份运行”(通过Wise安装向导运行程序仍然没问题)

I see though that Delphi 10.1 Berlin has a very easy to use new option under Project Options | Application. Just tick Enable Administrator Privileges, and the manifest is done for you, so easy!

我看到Delphi 10.1 Berlin在Project Options |下有一个非常容易使用的新选项应用。只需勾选启用管理员权限,清单即可为您完成,非常简单!

Delphi:需要时提示UAC提升

NB. make sure you only do these kind of changes via a separate setup program, running your application with elevated privileges all the time can cause problems with other things, for example e-mail, where the default mail profile no longer gets picked up.

NB。确保您只通过单独的安装程序进行这些更改,使用提升的权限一直运行您的应用程序可能会导致其他问题,例如电子邮件,其中不再提取默认邮件配置文件。

Edit: Jan 2018: since writing this answer in August 2017, it seems a lot of Windows updates have come out, that now require the user to right-click and Run As Administrator on just about everything, even on installation exe's built with Wise. Even Outlook is no longer installing properly without running as administrator. There is no more automated elevation at all it seems.

编辑:2018年1月:自2017年8月撰写此答案以来,似乎有很多Windows更新已经出现,现在需要用户右键单击并在几乎所有内容上以管理员身份运行,即使在使用Wise构建的安装exe上也是如此。如果不以管理员身份运行,即使Outlook也不再正常安装。似乎没有更多的自动升高。

#1


i would relaunch yourself as elevated, passing command line parameters indicating what elevated thing you want to do. You can then jump right to the appropriate form, or just save your HKLM stuff.

我会重新启动自己作为提升,传递命令行参数,指示你想要做什么升高的事情。然后,您可以直接跳到相应的表单,或者只保存您的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;

The other Microsoft suggested solution is to create an COM object out of process (using the specially created CoCreateInstanceAsAdmin function). i don't like this idea because you have to write and register a COM object.

另一个Microsoft建议的解决方案是在进程外创建一个COM对象(使用专门创建的CoCreateInstanceAsAdmin函数)。我不喜欢这个想法,因为你必须编写并注册一个COM对象。


Note: There is no "CoCreateInstanceAsAdmin" API call. It's just some code floating around. Here's the Dephi version i stumbled around for. It is apparently based on the trick of prefixing a class guid string with the "Elevation:Administrator!new:" prefix when normally hidden code internally calls CoGetObject:

注意:没有“CoCreateInstanceAsAdmin”API调用。这只是一些浮动的代码。这是我偶然发现的Dephi版本。它显然是基于通常隐藏代码在内部调用CoGetObject时使用“Elevation:Administrator!new:”前缀为类guid字符串添加前缀的技巧:

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;

One other question: How do you handle someone running as standard user in Windows XP?

另一个问题:如何处理在Windows XP中作为标准用户运行的人?

#2


You can't "elevate" an existing process. Elevated processes under UAC have a different token with a different LUID, different mandatory integrity level, and different group membership. This level of change can't be done within a running process - and it would be a security problem if that could happen.

您无法“提升”现有流程。 UAC下的高级进程具有不同的令牌,具有不同的LUID,不同的强制完整性级别和不同的组成员身份。这种更改级别无法在正在运行的进程中完成 - 如果发生这种情况,则会出现安全问题。

You need to launch a second process elevated that would do the work or by creating a COM object that runs in an elevated dllhost.

您需要启动第二个进程升级才能完成工作,或者创建一个在提升的dllhost中运行的COM对象。

http://msdn.microsoft.com/en-us/library/bb756922.aspx gives an example "RunAsAdmin" function and a "CoCreateInstanceAsAdmin" function.

http://msdn.microsoft.com/en-us/library/bb756922.aspx给出了一个示例“RunAsAdmin”函数和一个“CoCreateInstanceAsAdmin”函数。

EDIT: I just saw "Delphi" in your title. Everything I listed is obviously native, but if Delphi provides access to ShellExecute-like functionality you should be able to adapt the code from the link.

编辑:我刚刚在你的标题中看到了“Delphi”。我列出的所有内容显然都是原生的,但如果Delphi提供对类似ShellExecute的功能的访问,您应该能够调整链接中的代码。

#3


A sample of ready-to-use code:

即用型代码示例:

Usage example:

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.

And support unit itself:

并支持单位本身:

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.

#4


Usually, putting the text "Setup" or "Install" somewhere in your EXE name is enough to make Windows run with elevated privileges automatically, and is well worth doing if it is a setup utility you are writing, as it's so easy to do.

通常,将文本“设置”或“安装”放在EXE名称中的某个位置足以使Windows自动以提升的权限运行,如果它是您正在编写的设置实用程序,则非常值得做,因为它很容易实现。

I am now running into problems though on Windows 7, when not logged in as an Administrator, and am having to use the right-click Run As Administrator when running manually (running the program via Wise installation wizard is still fine)

我现在遇到的问题虽然在Windows 7上没有以管理员身份登录,并且在手动运行时必须使用右键单击“以管理员身份运行”(通过Wise安装向导运行程序仍然没问题)

I see though that Delphi 10.1 Berlin has a very easy to use new option under Project Options | Application. Just tick Enable Administrator Privileges, and the manifest is done for you, so easy!

我看到Delphi 10.1 Berlin在Project Options |下有一个非常容易使用的新选项应用。只需勾选启用管理员权限,清单即可为您完成,非常简单!

Delphi:需要时提示UAC提升

NB. make sure you only do these kind of changes via a separate setup program, running your application with elevated privileges all the time can cause problems with other things, for example e-mail, where the default mail profile no longer gets picked up.

NB。确保您只通过单独的安装程序进行这些更改,使用提升的权限一直运行您的应用程序可能会导致其他问题,例如电子邮件,其中不再提取默认邮件配置文件。

Edit: Jan 2018: since writing this answer in August 2017, it seems a lot of Windows updates have come out, that now require the user to right-click and Run As Administrator on just about everything, even on installation exe's built with Wise. Even Outlook is no longer installing properly without running as administrator. There is no more automated elevation at all it seems.

编辑:2018年1月:自2017年8月撰写此答案以来,似乎有很多Windows更新已经出现,现在需要用户右键单击并在几乎所有内容上以管理员身份运行,即使在使用Wise构建的安装exe上也是如此。如果不以管理员身份运行,即使Outlook也不再正常安装。似乎没有更多的自动升高。