Related
I am currently trying to take a screenshot of a 2D Firemonkey (FMX) form from another process.
The following is using a well-known method based of GDI, using a BitBlt() to produce a bitmap, and WIC to save it to a PNG file.
{...}
uses
system.UITypes,
system.SysUtils,
system.Hash,
{$IF Defined(MSWINDOWS)}
winapi.Windows,
Winapi.Direct3D9,
WinApi.D3DX9,
Winapi.Wincodec,
WinApi.ActiveX,
{$ENDIF}
{ some internal units }
path.types,
path.utils,
os.utils;
{...}
Type
TWindowSnapshot = record
window_handle: THandle; // handle to window
process_id: Cardinal; // PID of the process
window_rect: TRect; // position of the window
title: string; // title
file_path: string; // path to the window's image file
end;
TWindowSnapshots = Tarray<TWindowSnapshot>;
procedure HRCHECK(r: HRESULT); inline;
begin
if r <> S_OK then abort;
end;
function pad(s,g:integer): integer; inline;
begin
dec(g);
result := (s + g) and not g;
end;
function WICSavePixelsToPng(r: TRect; stride: cardinal; pixels: PByte; filePath: string): HRESULT;
var
factory: IWICImagingFactory;
encoder: IWICBitmapEncoder;
frame: IWICBitmapFrameEncode;
encoderOptions: IPropertyBag2;
stream: IWICStream;
pf: TGUID;
coInit : HResult;
begin
result := E_INVALIDARG;
if not assigned(pixels) then exit;
if (filepath = '') then exit;
coInit := CoInitialize(nil);
pf := GUID_WICPixelFormat32bppBGRA;
result := CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER, IWICImagingFactory, factory);
if result <> S_OK then exit;
result := factory.CreateStream(&stream);
if result <> S_OK then exit;
result := stream.InitializeFromFilename(PWideChar(filePath), GENERIC_WRITE);
if result <> S_OK then exit;
result := factory.CreateEncoder(GUID_ContainerFormatPng, TGUID.Empty, encoder);
if result <> S_OK then exit;
result := encoder.Initialize(stream, WICBitmapEncoderNoCache);
if result <> S_OK then exit;
result := encoder.CreateNewFrame(frame, encoderOptions);
if result <> S_OK then exit;
result := frame.Initialize(nil);
if result <> S_OK then exit;
result := frame.SetSize(r.width, r.height);
if result <> S_OK then exit;
result := frame.SetPixelFormat(pf);
if result <> S_OK then exit;
if pf <> GUID_WICPixelFormat32bppBGRA then
begin
assert(false,'ToDo');
end;
inc(pixels,(r.Left*4) + r.Top * stride);
result := frame.WritePixels(r.height, stride, stride * r.height, pixels);
if result <> S_OK then exit;
result := frame.Commit();
if result <> S_OK then exit;
result := encoder.Commit();
if (coInit <> 0) then
CoUninitialize();
end;
function take_window_snapshot_GDI(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
Wr: TRect;
HdcSRC: HDC;
hDCDest: HDC;
hBmp: HBITMAP;
hOld: HGDIOBJ;
hFlags: Cardinal;
l: integer;
src_shot,dst_shot,lsrc,ldst: PByte;
sr: PRGBTriple;
dr: PRGBQuad;
buff_size: cardinal;
x,y, src_stride, dst_stride: integer;
bi: tagBITMAPINFO;
begin
result := false;
cs.window_handle := win_handle;
cs.title := '';
cs.window_rect := TRect.Empty;
cs.process_id := 0;
try
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
{ reserve memory for bitmaps }
src_stride := pad((wr.Width * 3),4);
dst_stride := pad((wr.Width * 4),4);
buff_size := src_stride * wr.Height;
getmem(src_shot,buff_size);
if not assigned(src_shot) then exit;
getmem(dst_shot,dst_stride * wr.Height);
if not assigned(src_shot) then
begin
freemem(src_shot);
exit;
end;
try
try
HdcSRC := GetWindowDC(win_handle);
HdcDest := CreateCompatibleDC(HdcSRC);
SetStretchBltMode(HdcDest, COLORONCOLOR);
HBmp := CreateCompatibleBitmap(HdcSRC,Wr.Width,wr.Height);
hOld := SelectObject(hDCDest,hBmp);
BitBlt(hDCDest,0,0,wr.width,wr.Height,HdcSRC,0,0,SRCCOPY);
{ target bitplane is 24 bits RGB }
bi := default(tagBITMAPINFO);
bi.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
bi.bmiHeader.biWidth := wr.Width;
bi.bmiHeader.biHeight := wr.Height;
bi.bmiHeader.biPlanes := 1;
bi.bmiHeader.biBitCount := 24;
bi.bmiHeader.biCompression := BI_RGB;
GetDIBits(hDCDest,HBmp,0,wr.Height,src_shot,bi,DIB_RGB_COLORS);
{ now convert pixels to RGBA, in correct line order.
On Windows, last line is first in bitmap }
ldst := dst_shot;
lsrc := src_shot + (src_stride * wr.Height);
for y := 0 to wr.Height - 1 do
begin
dec(lsrc,src_stride);
sr := pointer(lsrc);
dr := pointer(ldst);
for x := 0 to wr.Width - 1 do
begin
dr.rgbBlue := sr.rgbtBlue;
dr.rgbRed := sr.rgbtRed;
dr.rgbGreen := sr.rgbtGreen;
dr.rgbReserved := 255;
inc(dr);
inc(sr);
end;
inc(ldst,dst_stride);
end;
{ save to PNG with WIC }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
wr.Offset(-wr.Left,-wr.top);
if WICSavePixelsToPng(wr,dst_stride,dst_shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
result := true;
finally
freemem(src_shot);
freemem(dst_shot);
end;
finally
SelectObject(hDCDest,hold);
DeleteDC(hDCDest);
ReleaseDC(win_handle,HdcSRC);
end;
except begin
result := false;
end;
end;
end;
This method is working for Delphi forms using VCL, however with forms using Firemonkey (FMX) 2D, it only produces bitmaps filled with BLACK (0) pixels.
I have tried an alternative using Direct3D9, that is working for Firemonkey form, however with a limitation I'll explain after the code snippet
function Take_window_snapshot_D3D(win_handle: THandle; PID: Cardinal; out cs: TWindowSnapshot; const image_folder: string): boolean;
var
D3D: IDirect3D9;
D3DDevice: IDirect3DDevice9;
mode: D3DDISPLAYMODE;
device: IDirect3DDevice9;
surface: IDirect3DSurface9;
parameters: D3DPRESENT_PARAMETERS;
rc: D3DLOCKED_RECT;
pitch: UINT;
shot: PByte;
shot_size: cardinal;
adapter: cardinal;
wr: TRect;
hCurWnd: THandle;
hCurThreadID: Cardinal;
L: integer;
hFlags: cardinal;
hr: HRESULT;
begin
result := false;
cs := default(TWindowSnapshot);
try
{ get the window type }
hFlags := GetWindowLong(win_handle,GWL_STYLE);
if (hFlags and (WS_DLGFRAME or WS_POPUP)) = 0 then exit;
if (hFlags and WS_VISIBLE) = 0 then exit;
{ size }
GetWindowRect(win_handle,Wr);
if (Wr.Width = 0) or (Wr.Height = 0) then exit;
{ title }
L := GetWindowTextLength(win_handle);
if L > 0 then
begin
setlength(cs.title,L);
GetWindowText(win_handle,pchar(cs.title),L+1);
end;
cs.window_handle := win_handle;
cs.window_rect := wr;
cs.process_id := PID;
{ Direct3D capture }
adapter := D3DADAPTER_DEFAULT;
D3D := Direct3DCreate9(D3D_SDK_VERSION);
HRCHECK(D3D.GetAdapterDisplayMode(adapter,mode));
parameters := default(D3DPRESENT_PARAMETERS);
parameters.Windowed := TRUE;
parameters.BackBufferCount := 1;
parameters.BackBufferHeight := mode.Height;
parameters.BackBufferWidth := mode.Width;
parameters.SwapEffect := D3DSWAPEFFECT_DISCARD;
parameters.hDeviceWindow := win_handle;
{ create device & capture surface }
HRCHECK(d3d.CreateDevice(adapter, D3DDEVTYPE_HAL, win_handle, D3DCREATE_SOFTWARE_VERTEXPROCESSING, #parameters, device));
{ create surface }
HRCHECK(device.CreateOffscreenPlainSurface(mode.Width, mode.Height, D3DFMT_A8R8G8B8, D3DPOOL_SYSTEMMEM, &surface, nil));
{ bring our window to front }
hCurWnd := GetForegroundWindow;
hCurThreadID := GetCurrentThreadId;
AttachThreadInput(PID,hCurThreadID,TRUE);
SetWindowPos(win_handle,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
SetWindowPos(win_handle,HWND_NOTOPMOST,0,0,0,0,SWP_SHOWWINDOW or SWP_NOSIZE or SWP_NOMOVE);
SetForegroundWindow(win_handle);
SetFocus(win_handle);
SetActiveWindow(win_handle);
AttachThreadInput(PID,hCurThreadID,false);
{ Obtain stride value to allocate buffer }
HRCHECK(surface.LockRect(rc,nil,0));
pitch := rc.Pitch;
HRCHECK(surface.UnlockRect());
shot_size := pitch*mode.Height;
getmem(shot,shot_size);
if not assigned(shot) then abort;
try
{ get surface data }
HRCHECK(device.GetFrontBufferData(0, surface));
{ copy surface data }
HRCHECK(surface.LockRect(rc,nil,0));
move(rc.pBits^,shot^,shot_size);
HRCHECK(surface.UnlockRect());
{ save snapshot to file using WIC, using a temporary file name first }
var tmp_name := Tpath.GetTempFileName('png',false,image_folder);
if WICSavePixelsToPng(wr,pitch,shot,tmp_name) = S_OK then
begin
result := true;
{ rename temp file name to new name if it doesn't exist already }
var new_name := Tpath.ExtractDirectory(tmp_name) + THashSHA1.GetHashStringFromFile(tmp_name) + '.png';
if not TPath.FileExists(new_name) then
begin
if Tfile.Rename(tmp_name,new_name) then
begin
cs.file_path := '';
end else begin
cs.file_path := new_name;
end;
end else begin
cs.file_path := new_name;
end;
end;
Tfile.Delete(tmp_name);
finally
FreeMem(shot);
end;
except
result := false;
end;
end;
The limitation that I have with the D3D method is that in reality I don't take a snapshot of a specific window but I take a snapshot of the entire screen that I crop after to take only the window of my interest.
For that, I must bring first the target window to front, but in some case this may not be possible. For instance if the target form is behind a modal form, it might be partially or totally hidden, as one can see below
So, my question : Is it possible to take a snapshot / print a single Firemonkey 2D form from another process, even if the form is not modal / partially covered by another form.
(Sorry for an answer here rather than a comment, which I can't do.)
I know little about working with different processes, but do you realise that FMX has a snapshot ability built in?
TControl.MakeScreenshot returns a bitmap of the control (with child controls). So if you can call that from the other process and return the result, that might solve your problem.
However, this won't meet your needs if you literally need the whole form including the non-client area, as a form doesn't have that method. If the contents of the form are all you need, and you have a control (e.g. a TLayout) filling the form and containing all the child controls, you could use the .MakeScreenshot of that bottom control.
And yes, .MakeScreeshot works even if something else is covering the form.
I am working on a Question/Answer UI application in Pascal / Lazarus. My problem is that upon invoking below code through a button click, the program crashes with a Segmentation Fault error.
// more declarations... (UI Form, Buttons, ...)
type
TQuestion = class(TObject)
title: string;
answers: array of string;
correct: integer;
end;
var
questions: array of TQuestion;
procedure TForm1.BStartClick(Sender: TObject);
var
i: integer;
j: integer;
line: string;
arrayLength: integer;
question: TQuestion;
stringList: TStringList;
begin
stringList := TStringList.create;
stringList.LoadFromFile('questions.txt');
for i := 0 to stringList.Count - 1 do ;
begin
line := stringList[i];
if (length(line) >= 2) then
if (line[2] = ' ') and ((line[1] = '-') or (line[1] = '+')) then
begin
arrayLength := length(question.answers);
SetLength(question.answers, arrayLength + 1);
question.answers[arrayLength] :=
Copy(line, 2, Length(line) - 1);
if zeile[1] = '+' then
question.correct := arrayLength;
end
else
begin
question := TQuestion.Create;
question.title := line;
arrayLength := length(questions);
setLength(questions, arrayLength + 1);
questions[arrayLength] := question;
end;
end;
BStart.Visible := False;
end;
Well, my Pascal knowledge goes to 10 to 15 years ago. However, I can see that you have an extra semicolon at the end of this line:
for i := 0 to stringList.Count - 1 do ;
We need to change some settings to the HKEY_LOCAL_MACHINE at runtime.
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'?
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.
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.
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:
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?
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.
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.
http://msdn.microsoft.com/en-us/library/bb756922.aspx gives an example "RunAsAdmin" function and a "CoCreateInstanceAsAdmin" function.
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.
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.
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.
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)
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!
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.
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.
I want to enumerate all the file in the C:\Windows\Fonts\
First I use FindFirst&FindNext to get all the file
Code:
Path := 'C:\Windows\Fonts';
if FindFirst(Path + '\*', faNormal, FileRec) = 0 then
repeat
Memo1.Lines.Add(FileRec.Name);
until FindNext(FileRec) <> 0;
FindClose(FileRec);
it get some name like this tahoma.ttf which display Tahoma regular in windows font folder .
but how can I get that ?
second I why can't enumerate files in C:\Windows\Fonts\ by shell
Code :
var
psfDeskTop : IShellFolder;
psfFont : IShellFolder;
pidFont : PITEMIDLIST;
pidChild : PITEMIDLIST;
pidAbsolute : PItemIdList;
FileInfo : SHFILEINFOW;
pEnumList : IEnumIDList;
celtFetched : ULONG;
begin
OleCheck(SHGetDesktopFolder(psfDeskTop));
//Font folder path
OleCheck(SHGetSpecialFolderLocation(0, CSIDL_FONTS, pidFont));
OleCheck(psfDeskTop.BindToObject(pidFont, nil, IID_IShellFolder, psfFont));
OleCheck(psfFont.EnumObjects(0, SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN
or SHCONTF_FOLDERS, pEnumList));
while pEnumList.Next(0, pidChild, celtFetched ) = 0 do
begin
//break in here
pidAbsolute := ILCombine(pidFont, pidChild);
SHGetFileInfo(LPCTSTR(pidAbsolute), 0, FileInfo, SizeOf(FileInfo),
SHGFI_PIDL or SHGFI_DISPLAYNAME );
Memo1.Lines.Add(FileInfo.szDisplayName);
end;
end;
and I know use Screen.Fonts can get font list but it display different from C:\Windows\Fonts\;
The GetFontResourceInfo undocumented function can get the name of the font from a font file.
Try this sample
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
SysUtils;
function GetFontResourceInfo(lpszFilename: PChar; var cbBuffer: DWORD; lpBuffer: PChar; dwQueryType: DWORD): DWORD; stdcall; external 'gdi32.dll' name 'GetFontResourceInfoW';
procedure ListFonts;
const
QFR_DESCRIPTION =1;
var
FileRec : TSearchRec;
cbBuffer : DWORD;
lpBuffer: array[0..MAX_PATH-1] of Char;
begin
if FindFirst('C:\Windows\Fonts\*.*', faNormal, FileRec) = 0 then
try
repeat
cbBuffer:=SizeOf(lpBuffer);
GetFontResourceInfo(PWideChar('C:\Windows\Fonts\'+FileRec.Name), cbBuffer, lpBuffer, QFR_DESCRIPTION);
Writeln(Format('%s - %s',[FileRec.Name ,lpBuffer]));
until FindNext(FileRec) <> 0;
finally
FindClose(FileRec);
end;
end;
begin
try
ListFonts;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
About your second question
replace this line
while pEnumList.Next(0, pidChild, b) = 0 do
with
while pEnumList.Next(0, pidChild, celtFetched) = 0 do
I got this from a German Delphi forum. It works on Delphi 7 Enterprise.
function GetFontNameFromFile(FontFile: WideString): string;
type
TGetFontResourceInfoW = function(Name: PWideChar; var BufSize: Cardinal;
Buffer: Pointer; InfoType: Cardinal): LongBool; stdcall;
var
GFRI: TGetFontResourceInfoW;
AddFontRes, I: Integer;
LogFont: array of TLogFontW;
lfsz: Cardinal;
hFnt: HFONT;
begin
GFRI := GetProcAddress(GetModuleHandle('gdi32.dll'), 'GetFontResourceInfoW');
if #GFRI = nil then
raise Exception.Create('GetFontResourceInfoW in gdi32.dll not found.');
if LowerCase(ExtractFileExt(FontFile)) = '.pfm' then
FontFile := FontFile + '|' + ChangeFileExt(FontFile, '.pfb');
AddFontRes := AddFontResourceW(PWideChar(FontFile));
try
if AddFontRes > 0 then
begin
SetLength(LogFont, AddFontRes);
lfsz := AddFontRes * SizeOf(TLogFontW);
if not GFRI(PWideChar(FontFile), lfsz, #LogFont[0], 2) then
raise Exception.Create('GetFontResourceInfoW failed.');
AddFontRes := lfsz div SizeOf(TLogFont);
for I := 0 to AddFontRes - 1 do
begin
hFnt := CreateFontIndirectW(LogFont[I]);
try
Result := LogFont[I].lfFaceName;
finally
DeleteObject(hFnt);
end;
end; // for I := 0 to AddFontRes - 1
end; // if AddFontRes > 0
finally
RemoveFontResourceW(PWideChar(FontFile));
end;
end;
procedure TMainForm.btnFontInfoClick(Sender: TObject);
begin
if OpenDialog1.Execute then
MessageDlg(Format('The font name of %s is'#13#10'%s.', [OpenDialog1.FileName,
GetFontNameFromFile(OpenDialog1.FileName)]), mtInformation, [mbOK], 0);
end;
Here's an adaptation of RRUZ's answer with the benefit that you can enumerate and find the names of fonts in any directory, not necessarily only the installed fonts in C:\Windows. The trick is to call AddFontResource before (and RemoveFontResource after) processing it with GetFontResourceInfoW for each font file:
program font_enum;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
System.SysUtils;
const
QFR_DESCRIPTION = 1;
var
p: String;
F: TSearchRec;
cbBuffer: DWORD;
lpBuffer: array [0 .. MAX_PATH - 1] of Char;
function GetFontResourceInfo(lpszFilename: PChar; var cbBuffer: DWORD; lpBuffer: PChar; dwQueryType: DWORD): DWORD;
stdcall; external 'gdi32.dll' name 'GetFontResourceInfoW';
begin
try
{ TODO -oUser -cConsole Main : Insert code here }
p := ParamStr(1);
if (p = EmptyStr) then
p := ExtractFilePath(ParamStr(0))
else if (not DirectoryExists(p)) then
begin
Writeln('Directory specified is not valid.');
Exit;
end;
p := IncludeTrailingPathDelimiter(p);
if (FindFirst(p + '*.ttf', faAnyFile - faDirectory, F) = 0) then
begin
repeat
AddFontResource(PWideChar(p + F.Name));
cbBuffer := SizeOf(lpBuffer);
GetFontResourceInfo(PWideChar(p + F.Name), cbBuffer, lpBuffer, QFR_DESCRIPTION);
Writeln(Format('%s = %s', [F.Name, lpBuffer]));
RemoveFontResource(PWideChar(p + F.Name));
until (FindNext(F) <> 0);
end;
FindClose(F);
if (FindFirst(p + '*.fon', faAnyFile - faDirectory, F) = 0) then
begin
repeat
AddFontResource(PWideChar(p + F.Name));
cbBuffer := SizeOf(lpBuffer);
GetFontResourceInfo(PWideChar(p + F.Name), cbBuffer, lpBuffer, QFR_DESCRIPTION);
Writeln(Format('%s = %s', [F.Name, lpBuffer]));
RemoveFontResource(PWideChar(p + F.Name));
until (FindNext(F) <> 0);
end;
FindClose(F);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
So I just got an answer to my question about getting the Skype Chatbox handle.
I am now trying to create a simple function, that digs for a handle. Here is how I am hoping to be able to use it:
MyHWND := DigForHandle(['Notepad','Edit'],['Untitled - Notepad','']);
Params:
1) Array of String: Holds the Class Hierachy.
2) Array of String: Holds the Window Caption Hierachy.
As you see, the 2nd entry in the 2nd parameter is empty, since the Edit Class does not have a Window Caption.
Would it be possible to create such function? :)
Try this
uses
Windows, Messages, TlHelp32, SysUtils;
type
PGetWindowParam = ^TGetWindowParam;
TGetWindowParam = record
ProcID: DWORD;
WindowCaption: string;
Result: HWND;
end;
function DigForHandle(const ProcName, Caption: string; const Hierachy: array of string): HWND;
function FindPID(const ExeFileName: string): DWORD;
implementation
function FindPID(const ExeFileName: string): DWORD;
var
ContinueLoop: BOOL;
ProcessEntry32: TProcessEntry32;
SnapshotHandle: THandle;
TempExeFileName: string;
begin
Result := 0;
SnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapshotHandle <> 0 then
begin
FillChar(ProcessEntry32, SizeOf(ProcessEntry32), 0);
ProcessEntry32.dwSize := Sizeof(ProcessEntry32);
ContinueLoop := Process32First(SnapshotHandle, ProcessEntry32);
while ContinueLoop do
begin
TempExeFileName := ExtractFileName(ProcessEntry32.szExeFile);
if SameText(TempExeFileName, ExeFileName) then
begin
Result := ProcessEntry32.th32ProcessID;
Break;
end;
ContinueLoop := Process32Next(SnapshotHandle, ProcessEntry32);
end;
CloseHandle(SnapshotHandle);
end;
end;
function GetWindow(Wnd: HWND; P: LParam): BOOL; stdcall;
var
Param: PGetWindowParam;
ProcID: DWORD;
WindowTitle: array[0..256] of Char;
begin
Result := True; // assume it doesn't match; keep searching
Param := PGetWindowParam(P);
ProcID := 0;
GetWindowThreadProcessID(Wnd, #ProcID);
if ProcID <> Param^.ProcID then
Exit;
FillChar(WindowTitle, SizeOf(WindowTitle), 0);
if SendMessage(Wnd, WM_GETTEXT, SizeOf(WindowTitle) - SizeOf(Char), LPARAM(#WindowTitle[0])) <= 0 then
Exit;
if AnsiSameStr(WindowTitle, Param^.WindowCaption) then
begin
Param^.Result := Wnd;
Result := False;
end;
end;
function DigForHandle(const ProcName, Caption: string; const Hierachy: array of string): HWND;
var
Param: TGetWindowParam;
I: Integer;
ParentWnd: HWND;
begin
Result := 0;
FillChar(Param, SizeOf(Param), 0);
Param.ProcID := FindPID(ProcName);
if Param.ProcID = 0 then
Exit;
Param.Result := 0;
Param.WindowCaption := Caption;
EnumWindows(#GetWindow, LPARAM(#Param));
if Param.Result = 0 then
Exit;
I := 0;
ParentWnd := Param.Result;
while (ParentWnd <> 0) and (I < Length(Hierachy)) do
begin
Param.Result := 0;
Param.WindowCaption := Hierachy[I];
EnumChildWindows(ParentWnd, #GetWindow, LPARAM(#Param));
if Param.Result = 0 then
Break;
ParentWnd := Param.Result;
Inc(I);
end;
if I >= Length(Hierachy) then
Result := Param.Result;
end;
When I thought about it, I realized that it was actually rather simple - the code I had though, was "confusing" for me, which was why I asked a question here. After trying it out, I found that doing it this way, its a lot easier to read, and not as complicated (IMO).
Function DigForHandle(ClassHierachy, TextHierachy : Array of String):HWND;
Var
Handle : HWND;
I : Integer;
PClass,PText : PChar;
Begin
Result := 0;
I := 0;
while (I <= Length(ClassHierachy)-1) do
begin
PClass := PChar(ClassHierachy[I]);
PText := PChar(TextHierachy[I]);
if PClass = '' then PClass := Nil;
if PText = '' then PText := Nil;
Result := FindWindowEx(Result,0,PClass,PText);
Inc(I);
end;
End;