I am trying to play with the LoadIconWithScaleDown API.
I am using Delphi 2007, I wrote a simple sample program where upon a button click I call COMMCTRL.LoadIconWithScaleDown. I tried various combinations, with instance zero, with instance set to hInstance, for the second parameter, I tried to pass the current module name, MAKEINTRESOURCE( IDI_APPLICATION), ... Always no luck, I always get a return value of -2147467263. Any idea what I am doing wrong?
Edited upon David's suggestion to show how I tried to call the API.
procedure TForm31.Button1Click(Sender: TObject);
var moduleName : string;
var moduleNameW : widestring;
var retVal : HRESULT;
var iconHandle : HICON;
begin
iconHandle := 0;
SetLength( moduleName, 1024);
WINDOWS.GetModuleFileName(
hInstance,
PCHAR(moduleName),
LENGTH(moduleName));
moduleNameW := moduleName;
retVal := COMMCTRL.LoadIconWithScaleDown(
HINSTANCE,
PWidechar(moduleNameW),
image1.width,
image1.height,
iconHandle);
end;
This an excellent demonstration of why you should NOT use WinAPI functions without reading and understanding the documentation.
The documentation for LoadIconWithScaleDown clearly explains what the parameters are and how to use them. There is zero reason to use GetModuleFileName, and the parameter where you're passing it in is wrong anyway, which the documentation clearly states.
Here are examples for using the function both ways, first to load an icon from an external disk file and then to load from an icon resource in your application. It was compiled and tested under Delphi 10 Seattle and works, provided the file or resource exist where you're using it.
uses
CommCtrl;
var
hIco: HICON;
Ico: TIcon;
NewWidth, NewHeight: Integer;
begin
NewWidth := 16;
NewHeight := 16;
if Succeeded(LoadIconWithScaleDown(0,
'C:\Images\SomeFile.ico',
NewWidth, NewHeight, hIco)) then
begin
Ico := TIcon.Create;
Ico.Handle := hIco;
// Do whatever with the icon. Clean up is left to you
end;
if Succeeded(LoadIconWithScaleDown(hInstance,
'MYRESOURCENAME',
NewWidth, NewHeight, hIco)) then
begin
// See code above
end;
end;
(And no, the issue was not that you needed to call InitCommonControlsEx first. Including CommCtrl does the necessary initialization for you.)
Related
I have this code:
procedure TForm1.Button1Click(Sender: TObject);
var
MyHandle: THandle;
begin
MyHandle:=FindWindow(nil, 'Delphi');
SendMessage(MyHandle, WM_CLOSE, 0, 0);
// Here will be a message like ' title found and it's test.exe that has 'Delphi' Title
end;
For example, it is test.exe that is the process that has the 'Delphi' title, and I want to get the EXE file name of that process by using the window handle. Is that possible? If so, may I have some reference for doing it?
Given any valid HWND, you can do the following:
use GetWindowThreadProcessId() to get the process ID that created it.
then use OpenProcess() to open a HANDLE to that process.
then use either GetModuleFileNameEx(), GetProcessImageFileName(), or QueryFullProcessImageName() (depending on OS version) to get the file path of the EXE that created that process.
Here is a procedure which I use, which you are likely to find in other places on the internet. I don't recall the exact source, it may have been https://www.swissdelphicenter.ch.
uses
Windows, TlHelp32, ...
function WindowHandleToEXEName(handle : THandle) : string;
var
snap : THandle;
pe : tagPROCESSENTRY32;
pid : THandle;
found : boolean;
begin
Windows.SetLastError(ERROR_SUCCESS);
result := '';
if (handle = 0) then exit;
snap := TLHelp32.CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (snap = Cardinal(-1)) then exit;
Windows.GetWindowThreadProcessId(handle, #pid);
pe.dwSize := Sizeof(pe);
found := TLHelp32.Process32First(snap, pe);
while found do
begin
if (pe.th32ProcessID = pid) then
begin
result := String(pe.szExeFile);
break;
end;
found := TLHelp32.Process32Next(snap, pe);
end;
CloseHandle(snap);
end;
I am trying to build an avionic attitude indicator with Delphi XE2.
I am using tRotateimage for the horizon
http://www.delphiarea.com/products/delphi-components/rotateimage/
This is behind a regular image which has transparent section in the middle.
Being able to rotate the image for roll and move the tRotateimage.top for pitch works well but I am getting a lot of flickering event with double buffered turned on my form. It flickers when I rotate the image or when I move it up via .top
Is there something else I can do to eliminate this flickering?
if tryStrToFloat(GetHashtag('#ROLL',',',Memo1.Lines.Text),MyDouble) then
Begin
rtAttitudeNeedle.Angle := 0- MyDouble;
rtAttitude.Angle :=0- MyDouble;
end;
if tryStrToFloat(GetHashtag('#PITCH',',',Memo1.Lines.Text),MyDouble) then
Begin
rtAttitude.Top := Round(iAttitudeTop + MyDouble);
end;
Double buffering a form is not always the magic trick to solve all your flicker problems.
you need to understand why you are having that flicker in the first place.
if you use the canvas object directly a lot in the paint routine, then you are doing nothing.
Most the time to solve this problem and reduce the flicker, you need to draw on a memory bitmap then at last CopyRect that to your canvas object.
Something like this for your component (Replace the Paint procedure with this code)
procedure TRotateImage.Paint;
var
SavedDC: Integer;
PaintBmp: TBitmap;
begin
PaintBmp := TBitmap.Create;
try
PaintBmp.SetSize(Width, Height);
if not RotatedBitmap.Empty then
begin
if RotatedBitmap.Transparent then
begin
PaintBmp.Canvas.StretchDraw(ImageRect, RotatedBitmap);
end
else
begin
SavedDC := SaveDC(PaintBmp.Canvas.Handle);
try
SelectClipRgn(PaintBmp.Canvas.Handle, ImageRgn);
IntersectClipRect(PaintBmp.Canvas.Handle, 0, 0, Width, Height);
PaintBmp.Canvas.StretchDraw(ImageRect, RotatedBitmap);
finally
RestoreDC(PaintBmp.Canvas.Handle, SavedDC);
end;
end;
end;
if csDesigning in ComponentState then
begin
PaintBmp.Canvas.Pen.Style := psDash;
PaintBmp.Canvas.Brush.Style := bsClear;
PaintBmp.Canvas.Rectangle(0, 0, Width, Height);
end;
Canvas.CopyRect(ClientRect, PaintBmp.Canvas, PaintBmp.Canvas.ClipRect);
finally
PaintBmp.Free;
end;
end;
if this does not solve the problem entirely then you could take a look at this flicker free set of components and try to adapt the rotating code you have on one of his components or inherit from it (I'm not the author and he is the one claiming flicker free functionality).
the FreeEsVclComponents GitHub repository
Edit: after debugging I found a lot of problems with that control, so I decided to go with my recommendation to you.
I created the following control for you
All what I did is that inheriting from TEsImage and doing some changes to the way it work. From the old control I used the routine below to do the rotation transformation.
function CreateRotatedBitmap(Bitmap: TBitmap; const Angle: Extended; bgColor: TColor): TBitmap;
As you can see in the gif above the rotation routine is not perfect. I suggest you look for an alternative.
I also forked the repository of FreeEsVclComponents and added the TAttitudeControl to the Es.Images unit, so you have all what you need to install the control in your system. Click here
At last I tested this on Tokyo and from the readme of the repository it should work on XE2 without problems.
Edit2: I changed the CreateRotatedBitmap with a better one (based on the GDI+), this is the result:
I already pushed the changes to Github so you can git the code from there.
I'm adding the code here as well in case Github goes down (highly unlikely :))
uses
WinApi.Windows, WinApi.GDIPApi, WinApi.GDIPObj, Vcl.Graphics, System.Types;
function RotateImage(Source: TBitmap; Angle: Extended; AllowClip: Boolean): TBitmap;
var
OutHeight, OutWidth: Integer;
Graphics: TGPGraphics;
GdiPBitmap: TGPBitmap;
begin
if AllowClip then
begin
OutHeight := Source.Height;
OutWidth := Source.Width;
end
else
begin
if (Source.Height > Source.Width) then
begin
OutHeight := Source.Height + 5;
OutWidth := Source.Height + 5;
end
else
begin
OutHeight := Source.Width + 5;
OutWidth := Source.Width + 5;
end;
end;
Result := TBitmap.Create;
Result.SetSize(OutWidth, OutHeight);
GdiPBitmap := nil;
Graphics := TGPGraphics.Create(Result.Canvas.Handle);
try
Graphics.SetSmoothingMode(SmoothingModeDefault);
Graphics.SetPixelOffsetMode(PixelOffsetModeHalf);
Graphics.SetInterpolationMode(InterpolationModeLowQuality);
Graphics.TranslateTransform(OutWidth / 2, OutHeight / 2);
Graphics.RotateTransform(Angle);
Graphics.TranslateTransform(-OutWidth / 2, -OutHeight / 2);
GdiPBitmap := TGPBitmap.Create(Source.Handle, Source.Palette);
try
Graphics.DrawImage(GdiPBitmap, 0, 0);
finally
GdiPBitmap.Free;
end;
finally
Graphics.Free;
end;
end;
I use this method to process the image, but if it contains high-resolution images, more than 1000 x 1000 pixels, the image processing takes a very long time and cause the application not responding for a while, how to overcome it.
when processing high resolution images always appear Not Responding messages as in the picture.
type
TRGBArray = array[0..0] of TRGBTriple;
pRGBArray = ^TRGBArray;
var
ARL, ALL, AOL : pRGBarray;
TOGfx, TRGfx, TLGfx : TBitmap;
procedure TFZN.GfXColorProcessor;
var
X, Y : integer;
begin
TOGfx.Assign(TRGfx);
for Y := 0 to TRGfx.Height - 1 do
begin
ARL := TOGfx.Scanline[Y];
AOL := TLGfx.Scanline[Y];
//-------------------------
for x := 0 to TRGfx.Width - 1 do
begin
ARL[x].RGBtRed := AOL[X].RGBtRed;
IBG.Picture.bitmap.Assign(TOGfx);
end;
end;
end;
You should go with ScanLine(), as TLama suggested, and if it still takes long period to process the image, you can make the code threaded and continue the normal flow of application, or show a progress bar and force the user to wait. Keep in mind that playing with VCL controls outside of main thread isn't thread safe, so it's probably best to show some kind of notification to user that he should wait for processing to be finished.
Here is sample code of simple thread that does processing:
unit uImageProcessingThread;
interface
uses
Winapi.Windows, System.Classes, Vcl.Graphics;
type
TImageProcessingThread = class(TThread)
private
FBitmap: TBitmap;
protected
procedure Execute; override;
public
constructor Create(const ABitmap: TBitmap);
end;
implementation
constructor TImageProcessingThread.Create(const ABitmap: TBitmap);
begin
inherited Create(TRUE);
FBitmap := ABitmap;
end;
procedure TImageProcessingThread.Execute;
var
GC : LongInt;
H, W: Integer;
begin
for H := 0 to FBitmap.Height do
begin
for W := 0 to FBitmap.Width do
begin
GC := ColorToRGB(FBitmap.Canvas.Pixels[W, H]);
FBitmap.Canvas.Pixels[W, H] := RGB(GC, GC, GC);
end;
end;
end;
end.
There are couple flaws in your GfxColorProcessor() procedure:
1) It is bad practice to declare variables as global if it's not needed. ARL and AOL should be declared inside procedure. Do you use ALL variable? If not, there is no need for it to be declared. I'm not sure about TOGfx and TLGfx variables, but if you use them only inside GfxColorProcessor() procedure, then you should declare them inside that procedure as well.
2) You're risking access violation if TLGfx bitmap has smaller height or width than TRGfx one, since you would try to ScanLine[] the line number that doesn't exist or write out of range in ARL buffer.
3) Main bottleneck in your procedure is IBG.Picture.bitmap.Assign(TOGfx); line. You should execute it after processing, not during processing. By doing this, you would call IBG.Assign() only once, instead over 1.000.000 times (X*Y).
So, your procedure should look like this. I'm assuming you want to assign TLGfx pixels red value to TRGfx ones, and then assign the new image to IBG bitmap, while leaving TRGfx and TLGfx untouched:
type
TRGBArray = array[0..0] of TRGBTriple;
PRGBArray = ^TRGBArray;
var
TRGfx, TLGfx: TBitmap;
procedure TFZN.GfXColorProcessor;
var
X, Y : Integer;
ARL, AOL: PRGBArray;
tmp : TBitmap;
begin
Assert((TRGfx.Width = TLGfx.Width) and (TRGfx.Height = TLGfx.Height),
'Image sizes are not equal!');
tmp := TBitmap.Create;
try
tmp.Assign(TRGfx);
for Y := 0 to tmp.Height - 1 do
begin
ARL := tmp.ScanLine[Y];
AOL := TLGfx.ScanLine[Y];
for X := 0 to tmp.Width - 1 do
ARL[X].rgbtRed := AOL[X].rgbtRed;
end;
IBG.Picture.Bitmap.Assign(tmp);
finally
tmp.Free;
end;
end;
A very simple approach to fix this problem is to call Application.ProcessMessages inside your loops. This method will let windows to process all the messages still pending and then return to your code.
During the message processing, events will be fired, for isntance, clicks will happen. One of those clicks may happen on a button used to set a variable that indicates that the process should be aborted.
I hope this helps.
We want a program of ours in D7 to know if it was run via a ShellExecute command from one of our apps, or directly started by the user.
Is there a reliable way for a Delphi 7 program to determine the name of the program that ran it?
We of course could have our parent program use a command line argument or other flag, but we'd prefer the above approach.
TIA
There's no way to do what you want, I'm afraid. The application isn't told whether it's being run pro grammatically via ShellExecute (or CreateProcess), via a command line, a shortcut, or a double-click in Explorer.
Raymond Chen did an article a while back on this very topic, if I remember correctly; I'll see if I can find it and update my answer here.
Based on another answer and some code on Torry.net, I came to this function to get the parent process id. It seems to return a relevant number on Windows 7, and the windows functions it uses should be available at least since Win 2000.
uses Tlhelp32;
function GetProcessInfo(ProcessId: Cardinal; out ParentProcessId: Cardinal; out ExeFileName: string): Boolean;
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
try
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
repeat
if ProcInfo.th32ProcessID = ProcessId then
begin
ExeFileName := string(ProcInfo.szExeFile);
ParentProcessId := ProcInfo.th32ParentProcessID;
Result := True;
Exit;
end;
until not Process32Next(hSnapShot, ProcInfo);
finally
CloseHandle(hSnapShot);
end;
Result := False;
end;
procedure Test;
var
ProcessId, ParentProcessId, Dummy: Cardinal;
FileName: string;
begin
ProcessId := GetCurrentProcessId();
// Get info for current process
if GetProcessInfo(ProcessId, ParentProcessId, FileName) then
// Get info for parent process
if GetProcessInfo(ParentProcessId, Dummy, FileName) then
// Show it.
ShowMessage(IntToStr(ParentProcessId) + FileName);
end;
A word of caution! The parent process may no longer exist. Even worse, it's ID may have been recycled, causing this function to give you a different process than you asked for.
The simple answer is "No".
A more complex answer is "Not as easily as simply passing a command line param would be".
:)
What you need to do is identify the parent process of your process. Obtaining this is possible but not straightforward. Details of how to go about it can be obtained in this CodeProject article.
The biggest problem is that there is not strict hierarchical relationship between processes in Windows and PID (Process ID's) may be re-used. The PID you identify as your "parent" may not be your parent at all. If the parent process has subsequently terminated then it's PID may be re-used which could lead to some seemingly perplexing results ("My process was started by calc.exe? How is that possible?").
Trying to find bullet, water and idiot proof mechanisms to protect against the possible ways such a process might fail will be significantly more effort than simply devising and implementing a command line based convention between your launcher applications and the launchee by which the latter may identify the former.
A command line parameter is one such option but could be "spoofed" (if someone figures out what you are passing on the command line and for some reason could derive some value or benefit from mimicking this themselves).
Depending on how reliable and tamper proof you need the mechanism to be, this could still be enough however.
I've found getpids which does it using NtQueryInformationProcess to not only to obtain the parent process ID but also compare the process creation times - if the reported parent process was created after the child it means the reported parent ID has already been recycled.
Here is my Delphi unit I wrote to test it:
unit ProcInfo;
interface
uses
Windows, SysUtils;
function GetParentProcessId(ProcessID: DWORD; out ProcessImageFileName: string): DWORD; overload;
implementation
uses
PsApi;
var
hNtDll: THandle;
NtQueryInformationProcess: function(ProcessHandle: THandle; ProcessInformationClass: DWORD;
ProcessInformation: Pointer; ProcessInformationLength: ULONG; ReturnLength: PULONG): DWORD; stdcall;
const
UnicodeStringBufferLength = 1025;
type
PPEB = Pointer; // PEB from winternl.h not needed here
PPROCESS_BASIC_INFORMATION = ^PROCESS_BASIC_INFORMATION;
PROCESS_BASIC_INFORMATION = record
Reserved1: Pointer; // exit status
PebBaseAddress: PPEB;
Reserved2: array[0..1] of Pointer; // affinity mask, base priority
UniqueProcessId: ULONG_PTR;
Reserved3: Pointer; // parent process ID
end;
PProcessBasicInformation = ^TProcessBasicInformation;
TProcessBasicInformation = PROCESS_BASIC_INFORMATION;
PKernelUserTimes = ^TKernelUserTimes;
TKernelUserTimes = record
CreateTime: LONGLONG;
ExitTime: LONGLONG;
KernelTime: LONGLONG;
UserTime: LONGLONG;
end;
PUNICODE_STRING = ^UNICODE_STRING;
UNICODE_STRING = record
Length: USHORT;
MaximumLength: USHORT;
PBuffer: PChar;
Buffer: array[0..UnicodeStringBufferLength - 1] of Char;
end;
PUnicodeString = ^TUnicodeString;
TUnicodeString = UNICODE_STRING;
function GetProcessCreateTime(hProcess: THandle): LONGLONG;
var
ProcessTimes: TKernelUserTimes;
begin
Result := 0;
FillChar(ProcessTimes, SizeOf(ProcessTimes), 0);
if NtQueryInformationProcess(hProcess, 4, #ProcessTimes, SizeOf(ProcessTimes), nil) <> 0 then
Exit;
Result := ProcessTimes.CreateTime;
end;
function GetProcessParentId(hProcess: THandle): DWORD;
var
ProcessInfo: TProcessBasicInformation;
begin
Result := 0;
FillChar(ProcessInfo, SizeOf(ProcessInfo), 0);
if NtQueryInformationProcess(hProcess, 0, #ProcessInfo, SizeOf(ProcessInfo), nil) <> 0 then
Exit;
Result := DWORD(ProcessInfo.Reserved3);
end;
function GetProcessImageFileName(hProcess: THandle): string;
var
ImageFileName: TUnicodeString;
begin
Result := '';
FillChar(ImageFileName, SizeOf(ImageFileName), 0);
ImageFileName.Length := 0;
ImageFileName.MaximumLength := UnicodeStringBufferLength * SizeOf(Char);
ImageFileName.PBuffer := #ImageFileName.Buffer[0];
if NtQueryInformationProcess(hProcess, 27, #ImageFileName, SizeOf(ImageFileName), nil) <> 0 then
Exit;
SetString(Result, ImageFileName.PBuffer, ImageFileName.Length);
end;
function GetParentProcessId(ProcessId: DWORD; out ProcessImageFileName: string): DWORD;
var
hProcess, hParentProcess: THandle;
ProcessCreated, ParentCreated: LONGLONG;
begin
Result := 0;
ProcessImageFileName := '';
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId);
if hProcess = 0 then
RaiseLastOSError;
try
Result := GetProcessParentId(hProcess);
if Result = 0 then
Exit;
ProcessCreated := GetProcessCreateTime(hProcess);
finally
CloseHandle(hProcess);
end;
hParentProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False, Result);
if hParentProcess = 0 then
RaiseLastOSError;
try
ParentCreated := GetProcessCreateTime(hParentProcess);
if ParentCreated > ProcessCreated then
begin
Result := 0;
Exit;
end;
ProcessImageFileName := GetProcessImageFileName(hParentProcess);
finally
CloseHandle(hParentProcess);
end;
end;
initialization
hNtDll := GetModuleHandle('ntdll.dll');
if hNtDll <> 0 then
NTQueryInformationProcess := GetProcAddress(hNtDll, 'NtQueryInformationProcess');
end.
When I run the code from the IDE, I get the following results:
parent ID: 5140, parent image file name:
"\Device\HarddiskVolume1\Program Files\Embarcadero\RAD
Studio\8.0\bin\bds.exe"
so you may need to find a way to translate that into a "normal" path, e.g. "C:\Program Files\Embarcadero\RAD Studio\8.0\bin\bds.exe".
Good afternoon :-), in my application I use OleContainer to view presentation from Microsoft Powerpoint.
This code I use to load and run presentation file:
with oleContainer do begin
Parent := mediaPanel; Left := 0; Top := 0;
Width := mediaPanel.Width; Height := mediaPanel.Height;
CreateObjectFromFile('C:\Users\Nanik\Desktop\Present.ppt', false);
Iconic := false; Visible := true; Run;
end;
The presentation was created as autoplay slideshow (in Microsoft PowerPoint working), but in my application presentation was still on first slide. Run command isn't right?
You do not need a OleContainer to run the presentation inside a container in your application. Put a panel container to run the presentation in your form and try this routine:
procedure TForm2.Button3Click(Sender: TObject);
const
ppShowTypeSpeaker = 1;
ppShowTypeInWindow = 1000;
SHOW_FILE = 'C:\Users\jcastillo\Documents\test.pps';
var
oPPTApp: OleVariant;
oPPTPres: OleVariant;
screenClasshWnd: HWND;
pWidth, pHeight: Integer;
function PixelsToPoints(Val: Integer; Vert: Boolean): Integer;
begin
if Vert then
Result := Trunc(Val * 0.75)
else
Result := Trunc(Val * 0.75);
end;
begin
oPPTApp := CreateOleObject('PowerPoint.Application');
oPPTPres := oPPTApp.Presentations.Open(SHOW_FILE, True, True, False);
pWidth := PixelsToPoints(Panel1.Width, False);
pHeight := PixelsToPoints(Panel1.Height, True);
oPPTPres.SlideShowSettings.ShowType := ppShowTypeSpeaker;
oPPTPres.SlideShowSettings.Run.Width := pWidth;
oPPTPres.SlideShowSettings.Run.Height := pHeight;
screenClasshWnd := FindWindow('screenClass', nil);
Windows.SetParent(screenClasshWnd, Panel1.Handle);
end;
I do not have documentation at hand, but my thought is Run.Width and Run.Height must be provided in points, not in pixels. My poor man solution to convert pixels to points is here, and it works for me in my tests here... to find the correct way to convert in your environment is up to you.
Is supposed you can get the Handle of the presentation window from the oPPTPres.SlideShowSettings.Run.HWND property, but that does not work here for me, hence the FindWindow call.
Run is a method of TOleContainer, it is not a method specific to any kind of OLE object, say, a power point presentation or a bitmap image.. Documentation states "Call Run to ensure that the server application is running..".
You need to call object specific methods to operate on them, see PowerPoint Object Model Reference. Sample code:
procedure TForm1.Button1Click(Sender: TObject);
const
ppAdvanceOnTime = $00000002;
var
P: OleVariant;
S: OleVariant;
i: Integer;
begin
P := OleContainer1.OleObject.Application.Presentations.Item(1);
// below block would not be necessary for a slide show (i.e. a *.pps)
for i := 1 to P.Slides.Count do begin
P.Slides.Item(i).SlideShowTransition.AdvanceOnTime := True;
P.Slides.Item(i).SlideShowTransition.AdvanceTime := 1;
end;
S := P.SlideShowSettings;
S.AdvanceMode := ppAdvanceOnTime;
S.Run;
end;
Though the above will run the presentation as a slide show, it is probably not what you'd want because it runs in full screen. I have no idea how to run it in the container window..