I need to get the desktop resolution from a Delphi program.
However, if the program is not DPI aware Windows will lie about the real screen resolution so all kind of problems will rise from here.
Since it is too much work to make the program fully DPI aware (and I try to AVOID the WMI solution) I am thinking using a quick dirty trick: I will create a microscopic DPI-aware console program that will read the real resolution.
The main program will use start this little program (hidden) every time it needs the resolution. Seems simple enough to do. Right?
Question 1: Do I have another (better) option?
Question 2: I tried to create that little program. Although is has something like 10 lines of code its EXE size is 2.1MB and its memory footprint is 5.4MB!
Can I make it smaller? If the program is small enough (under 1MB RAM) I could leave it run all the time without pissing off the users.
Question 1: Do I have another (better) option?
You can use WMI as per your earlier question: How to obtain the real screen resolution in a High DPI system?
Question 2: I tried to create that little program. Although is has something like 10 lines of code its EXE size is 2.1MB and its memory footprint is 5.4MB! Can I make it smaller?
The trick is to avoid using any VCL units, and minimising the number of RTL units that you use. Your goal should be to use the Windows unit only. Or even avoid it and create your own Windows API imports for just the functions that you need.
Another option would be to create this program with a different programming language, one that was better able to remove dead code. I'd probably do this with a short C program.
This is 30KB with a plain icon, 15KB if you UPX it, compiled with Delphi 10 Seattle, and takes roughly 150-200ms in my system.
program ScreenSupport;
{$APPTYPE CONSOLE}
{$WEAKLINKRTTI ON}
{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
uses
Windows,
Messages;
{$R *.res}
{$SetPEFlags $0200} // IMAGE_FILE_DEBUG_STRIPPED} // $0200
{$SetPEFlags $0004} // IMAGE_FILE_LINE_NUMS_STRIPPED} // $0004
{$SetPEFlags $0008} // IMAGE_FILE_LOCAL_SYMS_STRIPPED} // $0008
{$SetPEFlags $0001} // IMAGE_FILE_RELOCS_STRIPPED} // $0001
Const WM_APP = $8000;
msgSendScreenres = WM_APP+1;
SM_CXVIRTUALSCREEN = 78;
SM_CYVIRTUALSCREEN = 79;
function GetDesktopHeight: Integer;
begin
Result := GetSystemMetrics(SM_CYVIRTUALSCREEN);
end;
function GetDesktopWidth: Integer;
begin
Result := GetSystemMetrics(SM_CXVIRTUALSCREEN);
end;
procedure SendScreenRes(t: THandle);
begin
if t = 0 then Exit;
PostMessage(t,msgSendScreenres,GetDesktopWidth,GetDesktopHeight);
end;
function IsAnyParam(s: string): Boolean;
Var a: Integer;
begin
Result := False;
if ParamCount = 0 then Exit;
for a := 1 to ParamCount do
if ParamStr(a) = s then Exit(True);
end;
function StrToInt(const S: string): Integer;
Var E: Integer;
begin
Val(S, Result, E);
end;
begin
// screen res requested
if IsAnyParam('-screenres') then begin
try
SendScreenRes(StrToInt(ParamStr(2)));
except
Exit;
end;
end;
end.
To use it, call it from your main app:
Const msgSendScreenres = WM_APP+1;
ShellExecute(0,'open','ScreenSupport.exe',PChar('-screenres '+IntToStr(Form1.Handle)),'',SW_HIDE);
then add this on private declarations on the main unit
procedure WMScreenRes(var Msg: TMessage); message msgSendScreenres;
then catch it
procedure TForm1.WMScreenRes(var Msg: TMessage);
begin
ScreenWidth := Msg.WParam;
ScreenHeight := Msg.LParam;
end;
Related
I'm using the following routine to patch functions in the RTL.
procedure PatchCode(const AddrProc: Pointer; const CodeSize: NativeUInt;
const Code: Pointer);
var
OldProtect: Cardinal;
begin
VirtualProtect(AddrProc, CodeSize, PAGE_EXECUTE_READWRITE, OldProtect);
Move(Code^, AddrProc^, CodeSize);
VirtualProtect(AddrProc, CodeSize, OldProtect, OldProtect);
end;
However when I tweak my patch-methods their size changes causing code like this to break:
//PatchRedirect calls PatchCode internally
PatchRedirect(AddrGetMem,{codesize = }17, #RedirectGetMem, JUMPS_GETMEM);
Is there a way to determine the size of a method at compile-time or runtime? (either one is fine).
I'm hoping for a general solution, but
if it only works for asm routines that's fine for my purposes.
Use case
One use case for this is a faster version of FillChar.
99% of the time FillChar is used as a ZeroMem.
So I patch System.ZeroMem with:
xor r8,r8
jmp FastFillChar;
and I patch System.FillChar with
movzx R8,R8b
mov r9,$0101010101010101
imul r8,r9
jmp FastFillChar
That way I can make the FillChar a tiny bit faster for those 99% of cases.
Or it would if anyone bothered to actually use zeromem
Update
Thanks to Rudy I think I have a solution applicable to a limited subset.
Is there a way to get size of a procedure?
If you have access to the source code, yes.
Delphi puts the generated code of routines in the same order as it is declared in the implementation section.
As long as the destination code you are trying to patch and the source code you're getting your patches from are compiled with the same parameters of {$CODEALIGN n} there is no problem.
For Win32, the default value is 4 and the Win32 RTL is compiled with alignment 4.
The code alignment for the Win64 RTL is {$CodeAlign 16}.
As long as the code alignment in your code and the patch recipient matches it the following code will work fine:
ProcSize:= NativeInt(#Routine2) - NativeInt(#Routine1);
PatchCode(#Routine1, ProcSize, #System.Something);
Any alignment nops will only increase the size up to the next multiple of $CodeAlign and the destination code is aligned the same way so you should be fine.
Obviously Routine1 had better be really short, otherwise you'll run into trouble, perhaps it's a good idea to assert that #dest is not a naked jmp to some other routine before patching if ProcSize > $CodeAlign.
I once wrote a piece of patching code myself, which doesn't overwrite the entire function at all, but just a jump to it at the start of the procedure. The size of the old procedure is of little importance because of that. Additionally, the class remembers the original content, so you can also 'unhook' the procedure by restoring that code.
It's written a long time ago, and I didn't have to use it in a long time, so I hope it still works in a more modern environment.
unit BigProcHook;
interface
uses
Windows, sysUtils;
type
PHack = ^THook;
THook = packed record
OpCodeCall : Byte;
OFFTo : Integer;
OpCodeRet : Byte;
end;
TBackup = THook;
TBigProcHook = class
private
FOldProc, FNewProc: Pointer;
FBackupped: Boolean;
FHooked: Boolean;
FOriginal: TBackup;
procedure SetHooked(const Value: Boolean);
protected
procedure InstallHook(Hook: THook);
procedure OverwriteProc;
public
constructor Create(AOldProc, ANewProc: Pointer; Install: Boolean = True);
property Hooked: Boolean read FHooked write SetHooked;
end;
implementation
{ TBigProcHook }
constructor TBigProcHook.Create(AOldProc, ANewProc: Pointer;
Install: Boolean);
begin
inherited Create;
FOldProc := AOldProc;
FNewProc := ANewProc;
if Install then
SetHooked(True);
end;
procedure TBigProcHook.InstallHook(Hook: THook);
var
OldProtect: Cardinal;
begin
// Change protection of oldproc memory
if VirtualProtect(FOldProc, SizeOf(THook), PAGE_EXECUTE_READWRITE, OldProtect) then
try
if not FBackupped then
begin
Move(FOldProc^, FOriginal, SizeOf(THook));
FBackupped := True;
end;
// Overwrite the old procedure
Move(Hook, FOldProc^, SizeOf(THook));
finally
VirtualProtect(FOldProc, SizeOf(THook), OldProtect, OldProtect);
end
else
begin
RaiseLastOSError;
end;
end;
procedure TBigProcHook.OverwriteProc;
// Overwrites the first few calls of OldProc with a call to NewProc and a Ret.
var
Hook: THook;
begin
// Create a tiny little redirection
with Hook do begin
OpCodeCall := $E8; // = CALL}
OFFTo := PAnsiChar(FNewProc) - PAnsiChar(FOldProc) - 5;
OpCodeRet := $C3; // = RET
end;
InstallHook(Hook);
end;
procedure TBigProcHook.SetHooked(const Value: Boolean);
begin
// Toggle hook.
if FHooked <> Value then
if Value then
OverwriteProc
else
InstallHook(FOriginal);
FHooked := Value;
end;
initialization
end.
Which you can call like this: (in the example it's called in the initialization and finalization of a unit)
var
FHook: TBigProcHook;
initialization
FHook := TBigProcHook.Create(#ProcedureToReplace, #ReplacementProcedure);
finalization
FHook.Hooked := False;
FHook.Free;
Originally posted on the Dutch forum NLDelphi.com.
I currently use both Delphi XE6 and Delphi Seattle:
I am busy putting together a little app on Firemonkey that needs to play sound files (mp3, wav etc.). Adjusting the master volume is straight forward, but it seems that adjusting the left-to-right balance of a sound file playing is not.
This is the code that I have for achieving this feat, except, it will not be supported in FMX, as it calls mostly Windows API functions. Can anyone help with the API functions to call on the FMX platform instead? At this point I am hoping to support at least Android devices. If there is additional/alternative code (or compiler directive settings with alternative code) to cover for iOS devices as well, that would be greatly appreciated.
Thank you very much in advance!
Here is what I have so far...
function GetWaveVolume(var LVol: DWORD; var RVol: DWORD): Boolean;
var
WaveOutCaps: TWAVEOUTCAPS;
Volume: DWORD;
begin
Result := False;
if WaveOutGetDevCaps(WAVE_MAPPER, #WaveOutCaps, SizeOf(WaveOutCaps)) = MMSYSERR_NOERROR then
if WaveOutCaps.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
Result := WaveOutGetVolume(WAVE_MAPPER, #Volume) = MMSYSERR_NOERROR;
LVol := LoWord(Volume);
RVol := HiWord(Volume);
end;
end;
function SetWaveVolume(const AVolume: DWORD): Boolean;
var
WaveOutCaps: TWAVEOUTCAPS;
begin
Result := False;
if WaveOutGetDevCaps(WAVE_MAPPER, #WaveOutCaps, SizeOf(WaveOutCaps)) = MMSYSERR_NOERROR then
if WaveOutCaps.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
Result := WaveOutSetVolume(WAVE_MAPPER, AVolume) = MMSYSERR_NOERROR;
end;
I am trying to create a DLL in Delphi XE2 which will popup a form with a TWebBrowser component in it. When the WebBrowser.Navigate2 method is called the finalization section of the unit (or any unit) is not called when the application ends. If Navigate2 is not called, the finalization section happens just fine.
The dll is being called from C++ (VS 2010 MFC console at the moment) and linked via in import library.
There are other ways of doing this, but I would like to reuse the code we already have written.
Does anyone have any idea what is going on?
Thanks.
Here is a simple recreation of the problem:
library DisplayPatientAlertsIntf;
exports DisplayPatientAlertsA name 'DisplayPatientAlertsA#4';
begin
end.
unit uAlertWindow;
interface
uses
Winapi.ActiveX,
Forms,
SHDocVw,
Graphics, Controls;
function DisplayPatientAlertsA(PatientID : PAnsiChar): Integer; export; stdcall;
implementation
var ts : TStringList;
function DisplayPatientAlertsA(PatientID : PAnsiChar): Integer; export; stdcall;
var Form1 : TForm;
WebBrowser1 : TWebBrowser;
DidCoInit : Boolean;
begin
DidCoInit := Succeeded(CoInitialize(nil));
try
Form1 := TForm.Create(nil);
try
WebBrowser1 := TWebBrowser.Create(nil);
try
WebBrowser1.ParentWindow := Form1.Handle;
WebBrowser1.Align := alClient;
WebBrowser1.Navigate2('file://c:\temp.html');
Form1.ShowModal;
finally
WebBrowser1.Free;
end;
finally
Form1.Free;
end;
finally
if DidCoInit then
CoUninitialize;
end;
Result := 0;
end;
initialization
ts := TStringList.Create;
finalization
ts.Free;
end.
Update 2013.03.19
While solving another problem (dbExpress drivers in a dll), I changed it from a statically linked dll with an import library to a dynamically loaded dll and everything started working.
Do not call CoInitialize() or CoUninitialize() during the DLL's initialization/finalization. That is a very bad place to do that, and besides, it is not the DLL's responsibility to call them anyway. It is the responsibility of the thread that is calling the DLL functions. If you must call them, then at least do so inside of your exported function instead.
As for the exported function itself, use WebBrowser1.Parent instead of WebBrowser1.ParentWindow, use Form1.Free instead of Form1.Release, and get rid of Application.ProcessMessages altogether.
And lastly, do not export the function using a manually decorated name. That is not the DLL's responsibility to do, either. Let the compiler handle the decorating. If there is a naming mismatch when importing the function, that needs to be addressed in the calling app, not the DLL itself.
Your misuse of both COM and the VCL (especially since the problem only occurs once the exported DLL function is called) are likely leading to deadlocks, preventing the DLL from unloading from memory correctly, and thus none of its finalization sections would be called because its DLL entry point is not able to be called. COM is very sensitive when it comes to its initialization/cleanup, so you have to make sure you do it correctly, and in the correct context.
Try this:
library DisplayPatientAlertsIntf;
uses
uAlertWindow;
exports
DisplayPatientAlertsA;
begin
end.
.
unit uAlertWindow;
interface
uses
Winapi.ActiveX,
Forms,
SHDocVw,
Graphics, Controls;
function DisplayPatientAlertsA(PatientID : PAnsiChar): Integer; stdcall;
implementation
function DisplayPatientAlertsA(PatientID : PAnsiChar): Integer; stdcall;
var
Form1 : TForm;
WebBrowser1 : TWebBrowser;
DidCoInit: Boolean;
begin
Result := 0;
try
DidCoInit = Succeeded(CoInitialize(nil));
try
Form1 := TForm.Create(nil);
try
WebBrowser1 := TWebBrowser.Create(Form1);
WebBrowser1.Parent := Form1;
WebBrowser1.Align := alClient;
WebBrowser1.Navigate2('file://c:\temp.html'); //This contains 'ASDF'
Form1.ShowModal;
finally
Form1.Free;
end;
finally
if DidCoInit then
CoUninitialize;
end;
except
Result := -1;
end;
end;
end.
Delphi does not make heavy use of plain DLLs and its support is basic and scarcely documented
While Delphi makes good work for EXE files, intercepting WinMain and bringing its semantics to Turbo Pascal style context, for DLL you have to do it manually.
Start with reading DLL-Main Microsoft documentation and tutorials.
Then you can add into your DLL.dpr something like
begin
DLLProc := #DLLMain;
DLLMain(DLL_PROCESS_ATTACH);
end.
And then in some unit of DLL you can implement it like this:
procedure DLLMain(dwReason: DWORD);
begin
case dwReason of
DLL_PROCESS_ATTACH:
begin
Application.HelpFile := HelpFileName;
dmSelVars := TdmSelVars.Create(nil);
end {= DLL_PROCESS_ATTACH =};
DLL_PROCESS_DETACH:
begin
Application.Handle := 0;
FreeAndNil(dmSelVars);
g_pSvRec := nil;
end {= DLL_PROCESS_DETACH =};
end {= case =};
end {= DLLMain =};
PS. Why using DLL, when you can use Delphi-native (since 1997) BPL instead ?
It solves many problems and it provides much better finalization support:
for manually-loaded packages (via LoadPackage(...) call) finalization called for all units by granted
for manually-loaded packages (via Project Options / Packages / Link with Runtime packages list ) finalization is called for all units, referenced in "uses" sections of your host EXE.
PPS. Starting MSIE for merely displaying one page - doesn't it look overkill ?
Perhaps native HTML support would suffice, even if limited somewhat ? And it is capable of loading page from TStream or from String w/o tinkering with intermediate temporary files. (Well, MSIE is capable as well, though, after some scaffolding).
You might find that an exception is being raised when one of the units is being finalized, preventing other units from being finalized.
I'm not sure about XE2, but older versions of Delphi tended to be very fussy about the ComObj unit being "high up" in the uses/initialization so it would be one of the last to finalize.
The problem was that if ComObj was finalized too soon, it would CoUninitialize too soon - effectively ripping the rug from under other code that still expected COM to be initialized.
If the XE2 version of SHDocVw still uses ComObj in its implementation section, then ComObj will be initialized relatively 'late'. So that could very well be your problem. In which case simply adding it explicitly and high up in your source should do the trick.
DLL registration with regsvr32.exe freezes when unit HtmlHelpViewer is used in DLL sources in Delphi XE or Delphi XE2 Update 3. Just add the unit to interface uses list. The main project (that uses DLL) freezes on exit too.
How to fix the issue?
Thanks for the help!
STEPS TO REPRODUCE THE ISSUE AND ISSUE IN SUGGESTED FIX:
1). Please create the following DLL:
library Test;
uses
ComServ,
HtmlHelpFixer,
HtmlHelpViewer;
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
begin
end.
2). Also create the following BPL linked to this DLL (by -LUTestBpl dcc32 parameter for example):
package TestBpl;
requires
Vcl;
end.
3). Then just execute: regsvr32.exe /s Test.dll. OS Windows 7 32-bit.
Update
According to the latest comments on the QC report submitted by Altaveron, this problem will be resolved in the next Delphi update, update 4. And indeed, Altaveron now confirms that update 4 does resolve the issue.
This is a known problem with the MS HTML help control, hhctrl.ocx. The best description of it that I am aware of is at the HelpWare FAR HTML FAQ. There are many QC reports describing the issue: 48983, 67463, 78998, 89616.
According to the latest QC report, this is fixed in XE2 but you report otherwise and I'd be inclined to believe you. Especially as a comparison of the source for the HtmlHelpViewer unit from XE and XE2 reveals no changes that appear related to this issue.
It's quite hard to work around the issue since the code that needs to be modified is buried deep inside the HtmlHelpViewer unit. I've had to resort to patching the HtmlHelp API call. Like this:
unit HtmlHelpFixer;
interface
implementation
uses
Windows;
function HtmlHelp(hWndCaller: HWND; pszFile: PWideChar; uCommand: UINT; dwData: DWORD): HWND;
begin
if uCommand=HH_CLOSE_ALL then begin
//don't call HtmlHelpW because it can result in a hang due to a bug in hhctrl.ocx
Result := 0;
end else begin
Result := HtmlHelpW(hWndCaller, pszFile, uCommand, dwData);
end;
end;
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
procedure RedirectHtmlHelp;
var
HtmlHelp: function(hWndCaller: HWND; pszFile: PWideChar; uCommand: UINT; dwData: DWORD_PTR): HWND;
begin
HtmlHelp := Windows.HtmlHelp;
RedirectProcedure(#HtmlHelp, #HtmlHelpFixer.HtmlHelp);
end;
initialization
RedirectHtmlHelp;
end.
Include this unit early in your .dpr uses list, before any unit that does anything with HTML help.
The version of the code that I use does a little more and takes steps to ensure that any open help windows are closed when the DLL unloads. This no longer happens because we have stopped sending HH_CLOSE_ALL.
You will want to make sure that any help windows are shut down then keep track of the window handles returned by HtmlHelp calls, which you can now intercept. Then at shutdown send a WM_CLOSE message to those windows which replaces the missing HH_CLOSE_ALL call to HtmlHelp.
However, I believe that the code above should get you over your immediate hurdle with regsvr32 which won't be showing help windows.
Feel free to do some experimentation! At the very least, the code above gives you entry points with which you can modify the behaviour of the HtmlHelpViewer unit.
Embarcadero have fixed this issue on Delphi XE2 Update 4. But now context help doesn't work on IDE while you're using BPL with HtmlHelpViewer unit on uses clause.
I'm using this code to inject my function, but it causes the target process to crash. Does anyone know why?
program Sky;
{$IMAGEBASE $13140000}
uses
Unit2 in 'Unit2.pas',
chstrDec in 'chstrDec.pas',Psapi,
unitinject in 'unitinject.pas', ShellAPI,dialogs,registry, Windows, Messages, tlhelp32, SysUtils, Variants, Classes, Graphics, Controls, Forms;
{$R *.res}
function GetProcessID(ProcessName:string):Integer;
var
Handle:tHandle;
Process:tProcessEntry32;
GotProcess:Boolean;
begin
Handle:=CreateToolHelp32SnapShot(TH32CS_SNAPALL,0) ;
Process.dwSize:=SizeOf(Process);
GotProcess := Process32First(Handle,Process);
{$B-}
if GotProcess and (Process.szExeFile<>ProcessName) then
repeat
GotProcess := Process32Next(Handle,Process);
until (not GotProcess) or (Process.szExeFile=ProcessName);
{$B+}
if GotProcess then Result := Process.th32ProcessID
else Result := 0;
CloseHandle(Handle);
end;
{$IMAGEBASE $13140000}
function Main(dwEntryPoint: Pointer): longword; stdcall;
var
s : String;
begin
ShowMessage('hi');
Result := 0;
Sleep(2000);
Main(dwEntryPoint);
end;
var
x:pointer;
Handle:tHandle;
PID:Cardinal;
begin
Pid:=getProcessID('calc.exe');
Handle := OpenProcess(PROCESS_ALL_ACCESS, False, PID);
Inject(Handle,#Main);
CloseHandle(Handle);
end.
//inject
procedure Inject(ProcessHandle: longword; EntryPoint: pointer);
var
Module, NewModule: Pointer;
Size, BytesWritten, TID: longword;
begin
Module := Pointer(GetModuleHandle(nil));
Size := PImageOptionalHeader(Pointer(integer(Module) + PImageDosHeader(Module)._lfanew + SizeOf(dword) + SizeOf(TImageFileHeader))).SizeOfImage;
VirtualFreeEx(ProcessHandle, Module, 0, MEM_RELEASE);
NewModule := VirtualAllocEx(ProcessHandle, Module, Size, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
WriteProcessMemory(ProcessHandle, NewModule, Module, Size, BytesWritten);
CreateRemoteThread(ProcessHandle, nil, 0, EntryPoint, Module, 0, TID);
end;
Err, GetModuleHandle(nil) is going to be value for your process, not the target process. Even if the values happen to be the same (or even if they are not) VirtualFreeEx ing that memory out from under the process is a bad idea, it might be you know, in the middle of executing some code there. That's the first place I see that can cause a potential crash. But let's assume that works somehow. So you allocate some new memory to scribble your code in, which you do. But you haven't relocated if you've needed to, and you also directly use EntryPoint, again not relocated. Why don't you use one of the "easy" code injection methods like a window hook?
Here are some examples:
http://www.codeproject.com/KB/threads/winspy.aspx
They are in C++, but you seem capable of "Delphi-ifying" them.
A simplification of what you are doing currently can be achieved by writing a DLL containing the code you want to inject, and using LoadLibrary to load it (by way of CreateRemoteThread). You use VirtualAllocEx to allocate space for the DLL name, WriteProcessMemory to write it over, and GetModuleHandle("kernel32.dll") for the handle to use with CreateRemoteThread and GetProcAddress("LoadLibraryW") (or LoadLibraryA) to pass to CreateRemoteThread. You should definitely never release memory you haven't allocated like you're currently doing. Every process is guaranteed to have kernel32 loaded in the same place (even with ASLR), so by bootstrapping with LoadLibrary you avoid a lot of the issues you'd have to deal with to get something like your current code working reliably.