Implementing Core Audio API events - delphi

Trying to implement events for Windows Core Audio API (Win7 64-bit Delphi XE5). My objective is to track the applications in the Volume Mixer to mute audio sessions that are not in my list and to adjust the volume for my target applications. I successfully enumerate the audio devices and the sessions, mute the audio and adjust the volume on a per-session basis but I am struggling with events. What I need is to get notified when new sessions are added and when sessions close so that I can enumerate again. I could use a timer to enumerate the session but I would prefer to avoid that.
The specific events that are not working are IAudioSessionNotification and IMMNotificationClient.
My questions are follows:
Is my approach to deriving classes for events too simplistic? I
found an example that is much more involved here:
Catch audio sessions events
, but it does not seem to work either (not tested personally)
Although IAudioEndpointVolumeCallback is "working" I think the code
smells because I am referencing UI elements in the OnNotify function
so I'd like some feedback/pointers. Is that a valid implementation?
I have two units: uAudioUI which contains the main form and MMDevApi unit that contains Core Audio interface.
The relevant parts of my code current looks like this (its a test app):
MMDevApi.pas
...
IAudioEndpointVolumeCallback = interface(IUnknown)
['{657804FA-D6AD-4496-8A60-352752AF4F89}']
function OnNotify(pNotify:PAUDIO_VOLUME_NOTIFICATION_DATA):HRESULT; stdcall;
end;
PIMMNotificationClient = ^IMMNotificationClient;
IMMNotificationClient = interface(IUnknown)
['{7991EEC9-7E89-4D85-8390-6C703CEC60C0}']
function OnDefaultDeviceChanged(const flow: EDataFlow; const role: ERole; const pwstrDefaultDevice: LPCWSTR):HRESULT; stdcall;
function OnDeviceAdded(const pwstrDeviceId: LPCWSTR):HRESULT; stdcall;
function OnDeviceRemoved(const pwstrDeviceId: LPCWSTR):HRESULT; stdcall;
function OnDeviceStateChanged(const pwstrDeviceID:LPCWSTR; const dwNewState: DWORD):HRESULT; stdcall;
function OnPropertyValueChanged(const pwstrDeviceID:LPCWSTR; const key: PROPERTYKEY):HRESULT; stdcall;
end;
IAudioSessionNotification = interface(IUnknown)
['{641DD20B-4D41-49CC-ABA3-174B9477BB08}']
function OnSessionCreated(const NewSession: IAudioSessionControl): HResult; stdcall;
end;
In the main form unit I derive classes for the required interfaces:
uAudioUI.pas
...
type
TEndpointVolumeCallback = class(TInterfacedObject, IAudioEndpointVolumeCallback)
public
function OnNotify(pNotify: PAUDIO_VOLUME_NOTIFICATION_DATA): HRESULT; stdcall;
end;
TMMNotificationClient = class(TInterfacedObject, IMMNotificationClient)
function OnDefaultDeviceChanged(const flow: EDataFlow; const role: ERole; const pwstrDefaultDevice: LPCWSTR):HRESULT; stdcall;
function OnDeviceAdded(const pwstrDeviceId: LPCWSTR):HRESULT; stdcall;
function OnDeviceRemoved(const pwstrDeviceId: LPCWSTR):HRESULT; stdcall;
function OnDeviceStateChanged(const pwstrDeviceID:LPCWSTR; const dwNewState: DWORD):HRESULT; stdcall;
function OnPropertyValueChanged(const pwstrDeviceID:LPCWSTR; const key: PROPERTYKEY):HRESULT; stdcall;
end;
TAudioMixerSessionCallback = class(TInterfacedObject, IAudioSessionEvents)
function OnDisplayNameChanged(NewDisplayName:LPCWSTR; EventContext:pGuid):HResult; stdcall;
function OnIconPathChanged(NewIconPath:LPCWSTR; EventContext:pGuid):HResult; stdcall;
function OnSimpleVolumeChanged(NewVolume:Single; NewMute:LongBool; EventContext:pGuid):HResult; stdcall;
function OnChannelVolumeChanged(ChannelCount:uint; NewChannelArray:PSingle; ChangedChannel:uint;
EventContext:pGuid):HResult; stdcall;
function OnGroupingParamChanged(NewGroupingParam, EventContext:pGuid):HResult; stdcall;
function OnStateChanged(NewState:uint):HResult; stdcall; // AudioSessionState
function OnSessionDisconnected(DisconnectReason:uint):HResult; stdcall; // AudioSessionDisconnectReason
end;
TAudioSessionCallback = class(TInterfacedObject, IAudioSessionNotification)
function OnSessionCreated(const NewSession: IAudioSessionControl): HResult; stdcall;
end;
For simplicity I use globals
private
{ Private declarations }
FDefaultDevice : IMMDevice;
FAudioEndpointVolume : IAudioEndpointVolume;
FDeviceEnumerator : IMMDeviceEnumerator;
FAudioClient : IAudioClient;
FAudioSessionManager : IAudioSessionManager2;
FAudioSessionControl : IAudioSessionControl2;
FEndpointVolumeCallback : IAudioEndpointVolumeCallback;
FAudioSessionEvents : IAudioSessionEvents;
FMMNotificationCallback : IMMNotificationClient;
FPMMNotificationCallback : PIMMNotificationClient;
FAudioSessionCallback : TAudioSessionCallback;
...
procedure TForm1.FormCreate(Sender: TObject);
var
...
begin
hr := CoCreateInstance(CLASS_IMMDeviceEnumerator, nil, CLSCTX_INPROC_SERVER, IID_IMMDeviceEnumerator, FDeviceEnumerator);
if hr = ERROR_SUCCESS then
begin
hr := FDeviceEnumerator.GetDefaultAudioEndpoint(eRender, eConsole, FDefaultDevice);
if hr <> ERROR_SUCCESS then Exit;
//get the master audio endpoint
hr := FDefaultDevice.Activate(IID_IAudioEndpointVolume, CLSCTX_INPROC_SERVER, nil, IUnknown(FAudioEndpointVolume));
if hr <> ERROR_SUCCESS then Exit;
hr := FDefaultDevice.Activate(IID_IAudioClient, CLSCTX_ALL, nil, IUnknown(FAudioClient));
if hr <> ERROR_SUCCESS then Exit;
//volume handler
FEndpointVolumeCallback := TEndpointVolumeCallback.Create;
if FAudioEndpointVolume.RegisterControlChangeNotify(FEndPointVolumeCallback) = ERROR_SUCCESS then
FEndpointVolumeCallback._AddRef;
//device change / ex: cable unplug handler
FMMNotificationCallback := TMMNotificationClient.Create;
FPMMNotificationCallback := #FMMNotificationCallback;
if FDeviceEnumerator.RegisterEndpointNotificationCallback(FPCableUnpluggedCallback) = ERROR_SUCCESS then
FMMNotificationCallback._AddRef;
... and then finally, the class functions
{ TEndpointVolumeCallback }
function TEndpointVolumeCallback.OnNotify(pNotify: PAUDIO_VOLUME_NOTIFICATION_DATA): HRESULT;
var
audioLevel : integer;
begin
//NOTE: this works..
audioLevel := Round(pNotify.fMasterVolume * 100);
Form1.trackVolumeLevel.Position := audioLevel;
if pNotify.bMuted then
begin
form1.trackVolumeLevel.Enabled := False;
form1.spdMute.Caption := 'X';
end
else
begin
form1.trackVolumeLevel.Enabled := True;
form1.spdMute.Caption := 'O';
end;
Result := S_OK;
end;
{ TMMNotificaionClient }
function TMMNotificationClient.OnDefaultDeviceChanged(const flow: EDataFlow; const role: ERole; const pwstrDefaultDevice: LPCWSTR): HRESULT;
begin
//NOTE: this crashes - referencing a pointer to add 000000000
Form1.Label2.Caption := 'Audio device changed';
Result := S_OK;
end;
{ AudioMixerSessionCallback }
function TAudioMixerSessionCallback.OnSimpleVolumeChanged(NewVolume: Single; NewMute: LongBool; EventContext: PGUID): HRESULT;
begin
//NOTE: This works...
Form1.trackSessionVolumeLevel.Position := Round(NewVolume * 100);
Form1.Label2.Caption := EventContext.ToString;
Result := S_OK;
end;
{ AudioSessionCallback }
function TAudioSessionCallback.OnSessionCreated(const NewSession: IAudioSessionControl): HRESULT;
begin
//NOTE: This never gets called...
Form1.Label2.Caption := 'New audio session created';
Result := S_OK;
end;

I think the code is a translation from C/C++ ?
When using the TInterfacedObject, you don't need the _AddRef etc. methods, because the TInterfacedObject will handle those.
Another suggestion: I'm missing the threading implementation. Normally this is declared in the constructor or initialization section.
Example:
initialization
CoInitializeEx(Nil,
COINIT_APARTMENTTHREADED);
or
//Create method
inherited Create();
CoInitializeEx(Nil,
COINIT_APARTMENTTHREADED);
This is important when using an UI implementation. Otherwise you will not receive any events.
Non UI implementations (like drivers) should use the COINIT_MULTITHREADED model.
Some notes:
Instead of using pointers, like PGUID, use TGUID. When a field is declared in C++, it could be starting with ie pSingle. In Delphi this should be Single. When C++ is using pointer to pointers (like ppSingle) then - in most cases - in Delphi this would be a PSingle.
Also you declared function OnChannelVolumeChanged wrong.
It should be:
function OnChannelVolumeChanged(ChannelCount: UINT;
NewChannelArray: Array of Single;
ChangedChannel: UINT;
EventContext: TGUID): HResult; stdcall;

Related

Creating and connecting DirectShow filter: how to implement CreateInstance()?

I want to write my own DirectShow filter to pull out packets of information for my own purposes. To do this, I used the guide to creating filters.
I did steps 1 to 5, and am stuck at step 6: failed to implement CreateInstance(). Can't instantiate the class because the MSDN example doesn't pass parameters, but code in Pascal requires (ObjectName: string; unk: IUnKnown; const clsid: TGUID). I used regsvr32, unfortunately I don’t know how to connect my DLL and I can’t think of it. The DSFMgr program also does not see my filter.
I read how filters are connected, tried to implement various searches, it's useless. Tried to connect manually via CLSID. Everything is useless. I know the answer is somewhere on the surface, but I don't see it. I can't figure out how DirectShow should see my library if it didn't exist in the first place. It's not logical. I've been trying to implement this for a very long time, but it doesn't work, I'm stuck.
Please don't recommend FFmpeg and the like. I don't want to use third party libraries. In DirectX, as far as I know it's built-in.
Step 6 example:
CUnknown * WINAPI CRleFilter::CreateInstance(LPUNKNOWN pUnk, HRESULT *pHr)
{
CRleFilter *pFilter = new CRleFilter();
if (pFilter== NULL)
{
*pHr = E_OUTOFMEMORY;
}
return pFilter;
}
I Implemented/converted it like this, but it doesn't work. Errors:
no variables sent
function TCRleFilter.CreateInstance(pUnk: PPUnknown; pHr: HRESULT): PUnknown;
var
pFilter: TCRleFilter;
begin
pFilter:= TCRleFilter.Create();
if pFilter = nil then pHr:= E_OUTOFMEMORY;
Result:= pFilter;
end;
I think at least a logical explanation should suffice.
The whole class:
unit Unit1;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, ActiveX, Classes, ComObj, DirectShow9, BaseClass, Dialogs;
type
TCRleFilter = class(TBCTransformFilter)
public
function CheckInputType(mtIn: PAMMediaType): HRESULT;
function GetMediaType (IPosition: Integer; pMediaType: PAMMediaType): HRESULT;
function CheckTransform(mtln: PAMMediaType; mt0ut: PAMMediaType): HRESULT;
function DecideBufferSize(pAlloc: IMemAllocator; pProp: PAllocatorProperties): HRESULT;
function Transform(pSource, pDest: IMediaSample): HRESULT;
function CreateInstance(pUnk: PPUnknown; pHr: HRESULT): PUnknown;
end;
const
CLSID_CRleFilter: TGUID = '{FBA9B97F-505B-49C7-A6C2-D1EFC34B2C0D}';
implementation
uses ComServ;
{ TCRleFilter }
function TCRleFilter.CheckInputType(mtIn: PAMMediaType): HRESULT;
begin
Result := S_OK;
ShowMessage('CheckInputType: âåðíóë "S_OK"');
end;
function TCRleFilter.CheckTransform(mtln, mt0ut: PAMMediaType): HRESULT;
begin
Result := S_OK;
ShowMessage('CheckTransform: âåðíóë "S_OK"');
end;
function TCRleFilter.CreateInstance(pUnk: PPUnknown;
pHr: HRESULT): PUnknown;
var
pFilter: TCRleFilter;
begin
try
pFilter:= TCRleFilter.Create('');
Result := pFilter;
except
pHr:= E_OUTOFMEMORY;
Result:= nil;
end;
end;
function TCRleFilter.DecideBufferSize(pAlloc: IMemAllocator; pProp: PAllocatorProperties): HRESULT;
begin
Result := S_OK;
ShowMessage('DecideBufferSize: âåðíóë "S_OK"');
end;
function TCRleFilter.GetMediaType(IPosition: Integer; pMediaType: PAMMediaType): HRESULT;
begin
Result := S_OK;
ShowMessage('GetMediaType: âåðíóë "S_OK"');
end;
function TCRleFilter.Transform(pSource, pDest: IMediaSample): HRESULT;
begin
Result := S_OK;
ShowMessage('Transform: âåðíóë "S_OK"');
end;
initialization
{.Create(ComServer, TCRleFilter, Class_CRleFilter, 'CRleFilter', 'CRle_Filter', ciMultiInstance, tmApartment); }
TBCClassFactory.CreateFilter(TCRleFilter,'CRle_Filter', CLSID_CRleFilter, CLSID_LegacyAmFilterCategory, MERIT_DO_NOT_USE, 0, nil );
end.
Your class inherites from TBCTransformFilter and the needed parameters are defined as:
constructor TBCTransformFilter.Create(ObjectName: string; unk: IUnKnown; const clsid: TGUID);
Untested, but it should be much more correct than your attempt:
function TCRleFilter.CreateInstance
( pUnk: IUnknown // LPUNKNOWN
; var pHr: HRESULT // Pointer to variable = VAR
): PUnknown; // Pointer
var
oFilter: TCRleFilter; // Object, not pointer
begin
try // Failing constructors throw exceptions
oFilter:= TCRleFilter.Create( 'my RLE encoder', pUnk, CLSID_CRleFilter );
result:= oFilter; // In doubt cast via "PUnknown(oFilter)"
except // Constructor failed, oFilter is undefined
pHr:= E_OUTOFMEMORY;
result:= nil;
end;
end;
The var parameter ensures that assigned values inside the function also live on outside the function - otherwise you'd only have a local variable. Which is also the point (haha) of pointers in C++ parameters.

Is possible hook EnumWindowsProc callback function?

I want know if is possible hook a callback function for example like EnumWindowsProc() using inline hook approach? and if yes, could provide a code snippet (example) please?
Thank you.
EDITION:
EnumWindowsProc is a callback implemented in other app. I not call it inside my app.
And i want hook EnumWindowsProc in this other app, by dll injection.
You have to handle EnumWindows at first, then you have to replace pointer to original EnumWindowsProc to yourself.
My example is valid fow win32
unit Patch;
interface
procedure PatchEnumWindows(Patch: Boolean);
implementation
uses SysUtils, SyncObjs, Windows;
const
INSTR_SIZE = 6;
var
OldEnumWindows: array [0..INSTR_SIZE-1] of Byte;
EnumWindowsPatched: Boolean = False;
function PatchedEnumWindows(EnumWindowsProc: Pointer; Param: Pointer); stdcall;
begin
// You have to replace original EnumWindowsProc to yourself
end;
procedure ApiRedirect(OrigFunction, NewFunction: Pointer; var Old);
const
TEMP_JMP: array[0..INSTR_SIZE-1] of Byte = ($E9,$90,$90,$90,$90,$C3);
var
JmpSize: DWORD;
JMP: array [0..INSTR_SIZE-1] of Byte;
OldProtect: DWORD;
begin
Move(TEMP_JMP, JMP, INSTR_SIZE);
JmpSize := DWORD(NewFunction) - DWORD(OrigFunction) - 5;
if not VirtualProtect(LPVOID(OrigFunction), INSTR_SIZE, PAGE_EXECUTE_READWRITE, OldProtect) then
raise Exception.CreateFmt('%s', [SysErrorMessage(GetLastError)]);
Move(OrigFunction^, Old, INSTR_SIZE);
Move(JmpSize, JMP[1], 4);
Move(JMP, OrigFunction^, INSTR_SIZE);
VirtualProtect(LPVOID(OrigFunction), INSTR_SIZE, OldProtect, nil);
end;
procedure PatchEnumWindows(Patch: Boolean);
var
OrigEnumWindows: Pointer;
begin
if Patch <> EnumWindowsProcPatched then begin
OrigEnumWindows := GetProcAddress(GetModuleHandle('user32.dll'), 'EnumWindows');
if Patch then begin
ApiRedirect(OrigEnumWindows, #PatchedEnumWindows, OldEnumWindows);
end
else begin
Move(OldEnumWindows, OrigEnumWindows, INSTR_SIZE);
end;
EnumWindowsPatched := Patch;
end;
end;
end.

Check if windows explorer already opened on given path

How can I see if windows explorer is already opened with certain path ? I don't want my application opens many duplicated windows. I was unable to do it with this way :
var
H: hwnd;
begin
if FileExists(edt8.Text) then
begin
H := FindWindow(0, PChar(ExtractFilePath(edt8.Text)));
if H <> 0 then
ShowMessage('explorer already opened')//explorer bring to front
else
ShellExecute(Application.Handle, nil, 'explorer.exe',
PChar(ExtractFilePath(edt8.Text)), nil, SW_NORMAL);
end;
end;
IShellWindows::FindWindowSW method
There is a nice method FindWindowSW that should find an existing Shell window, which includes Windows Explorer windows as well, I'd say. So, in a hope I'll find an existing window easily I wrote this code:
uses
ActiveX, ShlObj, SHDocVw, ComObj;
function IDListFromPath(const Path: WideString): PItemIDList;
var
Count: ULONG;
Attributes: ULONG;
ShellFolder: IShellFolder;
begin
OleCheck(SHGetDesktopFolder(ShellFolder));
OleCheck(ShellFolder.ParseDisplayName(0, nil, PWideChar(Path), Count, Result, Attributes));
end;
function GetExplorerHandle(const Path: WideString): HWND;
var
IDList: PItemIDList;
Unused: OleVariant;
Location: OleVariant;
ShellWindows: IShellWindows;
begin
OleCheck(CoCreateInstance(CLASS_ShellWindows, nil, CLSCTX_LOCAL_SERVER, IID_IShellWindows, ShellWindows));
Unused := Unassigned;
IDList := IDListFromPath(Path);
PVariantArg(#Location).vt := VT_VARIANT or VT_BYREF;
PVariantArg(#Location).pvarVal := PVariant(IDList);
ShellWindows.FindWindowSW(Location, Unused, SWC_EXPLORER, Integer(Result), SWFO_INCLUDEPENDING);
end;
But it never finds the Windows Explorer window with the given folder path (it always returns 0). I've used SWC_EXPLORER class to search only for Windows Explorer windows, build the absolute ID list, used a proper VT_VARIANT | VT_BYREF variant for location (at least I hope so, if not, please let me know). And I also tried to return IDispatch by including the SWFO_NEEDDISPATCH option (method always returned nil reference). So I gave up on this method (haven't found any example).
IShellWindows enumeration
The following code was inspired by this article and this example. Here is a scheme:
1. IShellWindows.Item(n)
2. ⤷ IDispatch.QueryInterface(IWebBrowserApp)
3. ⤷ IWebBrowserApp.QueryInterface(IServiceProvider)
4. ⤷ IServiceProvider.QueryService(STopLevelBrowser, IShellBrowser)
5. ⤷ IShellBrowser.QueryActiveShellView
6. ⤷ IShellView.QueryInterface(IFolderView)
7. ⤷ IFolderView.GetFolder(IPersistFolder2)
8. ⤷ IPersistFolder2.GetCurFolder
9. ⤷ ITEMIDLIST
And some description:
As first you obtain the IShellWindows interface reference and iterate its items.
For each item, the IShellWindows interface returns window's IDispatch interface which you then query for an IWebBrowserApp interface reference.
The obtained IWebBrowserApp interface (for documentation refer to IWebBrowser2, as it's their implementation) provides except others also the information about the host window, like handle which can be later used for bringing the window to foreground. We need to go deeper though. So let's query this interface reference for the IServiceProvider interface (which is an accessor for getting interfaces for the given service).
Now from the top-most browser implementation service query its IShellBrowser interface. A reference of this interface is still not interesting for our aim.
The obtained IShellBrowser query for the displayed Shell view object.
Now we can finally say, if the iterated Shell window is not an Internet Explorer window. So far they were having common interfaces implemented. Now if we query the obtained IShellView for the IFolderView interface and it succeeds, it is not Internet Explorer and we can continue.
Query the obtained IFolderView reference for the IPersistFolder2 interface for the currently displayed folder object.
If we succeeded even there and we got IPersistFolder2 reference, let's get the ITEMIDLIST for the current folder object.
And if we succeeded even with this last step, we have ITEMIDLIST of the currently displayed folder of a Windows Explorer instance (or the same interface implementor) and we can finally check if the obtained ITEMIDLIST equals to the one we parsed for the input path. If so, bring that window to foreground, if not, continue to the next iteration.
And here is a Delphi code. I don't know how much do you need for your Delphi version; this was a bare minimum I've needed for D2009 (manually translated from Windows SDK 10.0.15063.0). It's not a best example; in real code you may prefer wrapping this into a class and have more flexible interface, but that's upon your design preference. And finally, if you have Delphi newer than 2009, you may not need the imported prototypes, if older, you might be missing some:
uses
ActiveX, ShlObj, SHDocVw, ComObj;
{ because of Win32Check }
{$WARN SYMBOL_PLATFORM OFF}
const
IID_IFolderView: TGUID = '{CDE725B0-CCC9-4519-917E-325D72FAB4CE}';
IID_IPersistFolder2: TGUID = '{1AC3D9F0-175C-11D1-95BE-00609797EA4F}';
IID_IServiceProvider: TGUID = '{6D5140C1-7436-11CE-8034-00AA006009FA}';
SID_STopLevelBrowser: TGUID = '{4C96BE40-915C-11CF-99D3-00AA004AE837}';
type
IFolderView = interface(IUnknown)
['{CDE725B0-CCC9-4519-917E-325D72FAB4CE}']
function GetCurrentViewMode(out pViewMode: UINT): HRESULT; stdcall;
function SetCurrentViewMode(ViewMode: UINT): HRESULT; stdcall;
function GetFolder(const riid: TIID; out ppv): HRESULT; stdcall;
function Item(iItemIndex: Integer; out ppidl: PItemIDList): HRESULT; stdcall;
function ItemCount(uFlags: UINT; out pcItems: Integer): HRESULT; stdcall;
function Items(uFlags: UINT; const riid: TIID; out ppv): HRESULT; stdcall;
function GetSelectionMarkedItem(out piItem: Integer): HRESULT; stdcall;
function GetFocusedItem(out piItem: Integer): HRESULT; stdcall;
function GetItemPosition(pidl: PItemIDList; out ppt: TPoint): HRESULT; stdcall;
function GetSpacing(var ppt: TPoint): HRESULT; stdcall;
function GetDefaultSpacing(out ppt: TPoint): HRESULT; stdcall;
function GetAutoArrange: HRESULT; stdcall;
function SelectItem(iItem: Integer; dwFlags: DWORD): HRESULT; stdcall;
function SelectAndPositionItems(cidl: UINT; var apidl: PItemIDList; var apt: TPoint; dwFlags: DWORD): HRESULT; stdcall;
end;
EShObjectNotFolder = class(Exception);
function ILGetSize(pidl: PItemIDList): UINT; stdcall;
external 'shell32.dll' name 'ILGetSize';
function ILIsEqual(pidl1: PItemIDList; pidl2: PItemIDList): BOOL; stdcall;
external 'shell32.dll' name 'ILIsEqual';
function InitVariantFromBuffer(pv: Pointer; cb: UINT; out pvar: OleVariant): HRESULT; stdcall;
external 'propsys.dll' name 'InitVariantFromBuffer';
function CoAllowSetForegroundWindow(pUnk: IUnknown; lpvReserved: Pointer): HRESULT; stdcall;
external 'ole32.dll' name 'CoAllowSetForegroundWindow';
resourcestring
rsObjectNotFolder = 'Object "%s" is not a folder.';
{ this parses the input folder path and creates ITEMIDLIST structure if the given
folder path is a valid absolute path to an existing folder }
function GetFolderIDList(const Folder: string): PItemIDList;
const
SFGAO_STREAM = $00400000;
var
Count: ULONG;
Attributes: ULONG;
ShellFolder: IShellFolder;
begin
OleCheck(SHGetDesktopFolder(ShellFolder));
Attributes := SFGAO_FOLDER or SFGAO_STREAM;
OleCheck(ShellFolder.ParseDisplayName(0, nil, PWideChar(WideString(Folder)), Count, Result, Attributes));
if not ((Attributes and SFGAO_FOLDER = SFGAO_FOLDER) and (Attributes and SFGAO_STREAM <> SFGAO_STREAM)) then
begin
CoTaskMemFree(Result);
raise EShObjectNotFolder.CreateFmt(rsObjectNotFolder, [Folder]);
end;
end;
{ translated from the link mentioned in this comment; D2009 does not allow me to
create an OleVariant of type VT_ARRAY|VT_UI1 which is needed for the Navigate2
method so I've imported and used the InitVariantFromBuffer function here
https://msdn.microsoft.com/en-us/library/windows/desktop/gg314982(v=vs.85).aspx }
procedure OpenNewExplorer(IDList: PItemIDList);
var
Location: OleVariant;
WebBrowser: IWebBrowser2;
begin
OleCheck(CoCreateInstance(CLASS_ShellBrowserWindow, nil, CLSCTX_LOCAL_SERVER, IID_IWebBrowser2, WebBrowser));
OleCheck(CoAllowSetForegroundWindow(WebBrowser, nil));
OleCheck(InitVariantFromBuffer(IDList, ILGetSize(IDList), Location));
try
WebBrowser.Navigate2(Location, Unassigned, Unassigned, Unassigned, Unassigned);
finally
VariantClear(Location);
end;
WebBrowser.Visible := True;
end;
{ translated from the link mentioned in this comment
https://blogs.msdn.microsoft.com/oldnewthing/20040720-00/?p=38393 }
procedure BrowseInExplorer(const Folder: string);
var
I: Integer;
WndIface: IDispatch;
ShellView: IShellView;
FolderView: IFolderView;
SrcFolderID: PItemIDList;
CurFolderID: PItemIDList;
ShellBrowser: IShellBrowser;
ShellWindows: IShellWindows;
WebBrowserApp: IWebBrowserApp;
PersistFolder: IPersistFolder2;
ServiceProvider: IServiceProvider;
begin
SrcFolderID := GetFolderIDList(Folder);
try
OleCheck(CoCreateInstance(CLASS_ShellWindows, nil, CLSCTX_LOCAL_SERVER, IID_IShellWindows, ShellWindows));
{ iterate all Shell windows }
for I := 0 to ShellWindows.Count - 1 do
begin
WndIface := ShellWindows.Item(VarAsType(I, VT_I4));
{ do not use OleCheck here; windows like Internet Explorer do not implement
all the interfaces; it is the way to distinguish Windows Explorer windows
actually; so let's get all the references and if we succeed, check if the
obtained folder equals to the passed one; if so, bring that window to top
and exit this procedure }
if Assigned(WndIface) and
Succeeded(WndIface.QueryInterface(IID_IWebBrowserApp, WebBrowserApp)) and
Succeeded(WebBrowserApp.QueryInterface(IID_IServiceProvider, ServiceProvider)) and
Succeeded(ServiceProvider.QueryService(SID_STopLevelBrowser, IID_IShellBrowser, ShellBrowser)) and
Succeeded(ShellBrowser.QueryActiveShellView(ShellView)) and
Succeeded(ShellView.QueryInterface(IID_IFolderView, FolderView)) and
Succeeded(FolderView.GetFolder(IID_IPersistFolder2, PersistFolder)) and
Succeeded(PersistFolder.GetCurFolder(CurFolderID)) and
ILIsEqual(SrcFolderID, CurFolderID) then
begin
{ restore the window if minimized, try to bring it to front and exit this
procedure }
if IsIconic(WebBrowserApp.HWnd) then
Win32Check(ShowWindow(WebBrowserApp.HWnd, SW_RESTORE));
{$IFNDEF IBelieveThatIWebBrowserAppVisiblePropertyBringsWindowToFront}
Win32Check(SetForegroundWindow(WebBrowserApp.HWnd));
{$ELSE}
OleCheck(CoAllowSetForegroundWindow(WebBrowserApp, nil));
WebBrowserApp.Visible := True;
{$ENDIF}
Exit;
end;
end;
{ the procedure was not exited, hence an existing window was not found, so go
and open the new one }
OpenNewExplorer(SrcFolderID);
finally
CoTaskMemFree(SrcFolderID);
end;
end;
{$WARN SYMBOL_PLATFORM ON}
Possible usage:
BrowseInExplorer('C:\MyFolder');

Effect Glass in Delphi not work

I'm testing this code Windows 7 32 and 64 bit, but still, it does not work the glass effect in any case, not return any errors, just does not work me.
program test;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,System.SysUtils,DH_Form_Effects;
type
DWM_BLURBEHIND = record
dwFlags : DWORD;
fEnable : BOOL;
hRgnBlur : HRGN;
fTransitionOnMaximized : BOOL;
end;
function DwmEnableBlurBehindWindow(hWnd : HWND; const pBlurBehind : DWM_BLURBEHIND) : HRESULT; stdcall; external 'dwmapi.dll' name 'DwmEnableBlurBehindWindow';//function to enable the glass effect
function GetConsoleWindow: HWND; stdcall; external kernel32 name 'GetConsoleWindow'; //get the handle of the console window
function DWM_EnableBlurBehind(hwnd : HWND; AEnable: Boolean; hRgnBlur : HRGN = 0; ATransitionOnMaximized: Boolean = False; AFlags: Cardinal = 1): HRESULT;
var
pBlurBehind : DWM_BLURBEHIND;
begin
pBlurBehind.dwFlags:=AFlags;
pBlurBehind.fEnable:=AEnable;
pBlurBehind.hRgnBlur:=hRgnBlur;
pBlurBehind.fTransitionOnMaximized:=ATransitionOnMaximized;
Result:=DwmEnableBlurBehindWindow(hwnd, pBlurBehind);
end;
begin
try
DWM_EnableBlurBehind(GetConsoleWindow(), True);
Writeln('See my glass effect');
Writeln('Go Delphi Go');
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
Does this have any requirement to run? What is the problem ?
It works for me (on Windows 10):
I would suggest checking for any errors, rather than ignoring them:
hr: HRESULT;
hr := DWM_EnableBlurBehind(GetConsoleWindow(), True);
OleCheck(hr);
Equivalently, you can avoid the need to check return values by using safecall calling convention (where the compiler will insert code to check the HRESULT and throw an exception if the function failed):
procedure DwmEnableBlurBehindWindow(hWnd: HWND; const pBlurBehind: DWM_BLURBEHIND); safecall; external 'dwmapi.dll' name 'DwmEnableBlurBehindWindow';//function to enable the glass effect
procedure DWM_EnableBlurBehind(hwnd : HWND; AEnable: Boolean; hRgnBlur : HRGN = 0; ATransitionOnMaximized: Boolean = False; AFlags: Cardinal = 1);
var
pBlurBehind : DWM_BLURBEHIND;
begin
pBlurBehind.dwFlags:=AFlags;
pBlurBehind.fEnable:=AEnable;
pBlurBehind.hRgnBlur:=hRgnBlur;
pBlurBehind.fTransitionOnMaximized:=ATransitionOnMaximized;
DwmEnableBlurBehindWindow(hwnd, pBlurBehind);
end;
Now, since you weren't checking errors anyway - you will now know the problem. On Windows 7 with desktop composition disabled, DwmEnableBlurBehindWindow returns:
0x80263001
{Desktop composition is disabled}
The operation could not be completed because desktop composition is disabled

How can I find the process id from the service name/handle in Delphi?

I have the service name for a windows service in delphi, and I know how to get the handle from that as well. What I need to do is stop a service, and if the stop fails for some reason I need to kill the process associated with the service. The problem is that I have multiple services running from the same executable, so I can't use the executable name to kill the process. This means I need the process id to kill the proper associated process. How can I get this id or some way to kill the proper process from the service name or handle?
QueryServiceStatusEx?
Please note I have only accepted this solution so that a full delphi code solution is accepted, all due thanks to Jk though for pointing me on the correct path.
--
Ok, I've been able to figure out how to use the answer by Jk and have come up with this solution in delphi.
For reference, this is the link provided by Jk:
QueryServiceStatusEx
My Solution:
unit Demo;
interface
uses
Windows, Forms, SysUtils,
StdCtrls, WinSvc, Controls, Classes;
type
//Form for basic demo usage
TForm6 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
end;
//Record defined for use as return buffer
_SERVICE_STATUS_PROCESS = record
dwServiceType: DWORD;
dwCurrentState: DWORD;
dwControlsAccepted: DWORD;
dwWin32ExitCode: DWORD;
dwServiceSpecificExitCode: DWORD;
dwCheckPoint: DWORD;
dwWaitHint: DWORD;
dwProcessId: DWORD;
dwServiceFlags: DWORD;
end;
//Function Prototype
function QueryServiceStatusEx(
SC_HANDLE: SC_Handle;
SC_STATUS_TYPE: Cardinal;
out lpBuffer: _SERVICE_STATUS_PROCESS;
cbBufSize: DWORD;
out pcbBytesNeeded: LPDWORD
): BOOL; stdcall;
//internal setup function
function GetPid(sService: String; sMachine: String = '') : Cardinal;
var
Form6: TForm6;
implementation
{$R *.dfm}
const
// windows api library
advapi32 = 'advapi32.dll';
//define the api call
function QueryServiceStatusEx; external advapi32 name 'QueryServiceStatusEx';
//for demo usage
procedure TForm6.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add(IntToStr(Integer(GetPid('Service'))))
end;
function GetPid(sService: String; sMachine: String = '') : Cardinal;
var
schm,
schs: SC_Handle;
SC_STATUS_TYPE: Cardinal;
lpBuffer: _SERVICE_STATUS_PROCESS;
cbBufSize: DWORD;
pcbBytesNeeded: LPDWORD;
begin
//open the service manager (defined in WinSvc)
schm := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_CONNECT);
//set the status type to SC_STATUS_PROCESS_INFO
//this is currently the only value supported
SC_STATUS_TYPE := $00000000;
//set the buffer size to the size of the record
cbBufSize := sizeof(_SERVICE_STATUS_PROCESS);
if (schm>0) then
begin
//grab the service handle
schs := OpenService(schm, PChar(sService), SERVICE_QUERY_STATUS);
if (schs>0) then
begin
//call the function
QueryServiceStatusEx(
schs,
SC_STATUS_TYPE,
lpBuffer,
cbBufSize,
pcbBytesNeeded);
CloseServiceHandle(schs);
end;
CloseServiceHandle(schm);
end;
Result := lpBuffer.dwProcessId;
end;
end.
Please note that not all external naming and other necessities are included.
Or use DSiWin32 for many useful functions, including DSiGetProcessID. This code was written by StackOverflow user (and programmer) Gabr.
Here's the function, for your own reference. It will give you what you are looking for:
//Retrieves ID of the specified process. Requires Toolhelp API.
// #returns False if ID cannot be retrieved. Check GetLastError - if it is 0, process
// doesn't exist; otherwise it contains the Win32 error code.
// #author gabr
// #since 2004-02-12
//
function DSiGetProcessID(const processName: string; var processID: DWORD): boolean;
var
hSnapshot: THandle;
procEntry: TProcessEntry32;
begin
Result := false;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot = 0 then
Exit;
try
procEntry.dwSize := Sizeof(procEntry);
if not Process32First(hSnapshot, procEntry) then
Exit;
repeat
if AnsiSameText(procEntry.szExeFile, processName) then begin
processID := procEntry.th32ProcessID;
Result := true;
break; // repeat
end;
until not Process32Next(hSnapshot, procEntry);
finally DSiCloseHandleAndNull(hSnapshot); end;
end; { DSiGetProcessID }

Resources