I have the handle of an opened Windows Explorer window.
How can I send a command to it in order to change the path from
example: m:\programs to d:\programs.
Till now I was using ShellExecute() but it opens a new window. This is not good (user experience).
The following BrowseToFolder function navigates the existing instance of a Windows Explorer of the given AHandle handle (if exists) to a AFolderPath folder (if exists). If you won't specify the second parameter, the topmost window should be taken to navigate (or at least the documentation claims that; reality seems to take the oldest existing window). The function returns True, if the navigation has been successful, False otherwise:
uses
ActiveX, ShlObj, ShellAPI, SHDocVw;
const
IID_IServiceProvider: TGUID = '{6D5140C1-7436-11CE-8034-00AA006009FA}';
SID_STopLevelBrowser: TGUID = '{4C96BE40-915C-11CF-99D3-00AA004AE837}';
function GetItemIDListFromPath(const AFolderPath: WideString): PItemIDList;
var
Count: ULONG;
Attributes: ULONG;
ShellFolder: IShellFolder;
begin
Result := nil;
if Succeeded(SHGetDesktopFolder(ShellFolder)) then
begin
Count := 0;
if Failed(ShellFolder.ParseDisplayName(0, nil, PWideChar(AFolderPath),
Count, Result, Attributes))
then
Result := nil;
end;
end;
function BrowseToFolder(const AFolderPath: WideString;
AHandle: HWND = HWND_TOPMOST): Boolean;
var
I: Integer;
WndIface: IDispatch;
ItemIDList: PItemIDList;
ShellBrowser: IShellBrowser;
ShellWindows: IShellWindows;
WebBrowserApp: IWebBrowserApp;
ServiceProvider: IServiceProvider;
begin
Result := False;
if Succeeded(CoCreateInstance(CLASS_ShellWindows, nil, CLSCTX_LOCAL_SERVER,
IID_IShellWindows, ShellWindows)) then
begin
for I := 0 to ShellWindows.Count - 1 do
begin
if (AHandle <> HWND_TOPMOST) then
WndIface := ShellWindows.Item(VarAsType(I, VT_I4))
else
WndIface := ShellWindows.Item(VarAsType(SWC_EXPLORER, VT_UI4));
if Succeeded(WndIface.QueryInterface(IID_IWebBrowserApp,
WebBrowserApp)) then
begin
if (AHandle = HWND_TOPMOST) or (WebBrowserApp.HWnd = AHandle) then
begin
if Succeeded(WebBrowserApp.QueryInterface(IID_IServiceProvider,
ServiceProvider)) then
begin
if Succeeded(ServiceProvider.QueryService(SID_STopLevelBrowser,
IID_IShellBrowser, ShellBrowser)) then
begin
ItemIDList := GetItemIDListFromPath(AFolderPath);
Result := Succeeded(ShellBrowser.BrowseObject(ItemIDList,
SBSP_SAMEBROWSER or SBSP_ABSOLUTE));
end;
end;
Break;
end;
end;
end;
end;
end;
Here is the example usage:
procedure TForm1.Button1Click(Sender: TObject);
var
ExplorerHandle: HWND;
begin
ExplorerHandle := 123456;
if not BrowseToFolder('c:\Windows\System32\', ExplorerHandle) then
ShowMessage('Navigation to a folder failed!')
else
ShowMessage('Navigation to a folder succeeded!');
end;
Here is a complete testing project and the blog post from which I've taken the inspiration.
Related
Following _isEdit function detects whether input could be applied to the currently focused control:
class function TSpeedInput._getFocusedControlClassName(): WideString;
var
lpClassName: array[0..1000] of WideChar;
begin
FillChar(lpClassName, SizeOf(lpClassName), 0);
Windows.GetClassNameW(GetFocus(), PWideChar(#lpClassName), 999);
Result := lpClassName;
end;
class function TSpeedInput._isEdit(): Boolean;
const
CNAMES: array[0..3] of string = ('TEdit', 'TMemo', 'TTntMemo.UnicodeClass',
'TTntEdit.UnicodeClass');
var
cn: WideString;
i: Integer;
begin
Result := False;
cn := _getFocusedControlClassName();
for i := Low(CNAMES) to High(CNAMES) do
if cn = CNAMES[i] then begin
Result := True;
Exit;
end;
//MessageBoxW(0, PWideChar(cn), nil, 0);
end;
What I don't like about it is the hard coding of the class name list. Could it be detected that a currently focused window belongs to the editors family or, better to say, that it has an active caret? (in order that _isEdit returns False for a WhateverItIsControl that is in read-only mode).
If the Handle of the control is allocated, you can use this hack:
function IsEdit(AControl: TWinControl): boolean;
begin
if AControl.HandleAllocated then
begin
Result := SendMessage(AControl.Handle, EM_SETREADONLY,
WPARAM(Ord(AControl.Enabled)), 0) <> 0;
end
else
begin
Result := AControl is TCustomEdit;
end;
end;
If the controls you are interested in are on a specific form and are owned by that form (and are standard Delphi controls) you could use the following:
function TFormML2.FocusIsEdit: boolean;
var
i : integer;
begin
Result := FALSE;
for i := 0 to ComponentCount - 1 do
begin
if Components[ i ] is TCustomEdit then
begin
if (Components[ i ] as TCustomEdit).Focused and not (Components[ i ] as TCustomEdit).ReadOnly then
begin
Result := TRUE;
break;
end;
end;
end;
end;
If you know the form and can pass it as a parameter, you could do something similar.
TCustomEdit is the ancestor of all edit boxes, memos, etc.
I've got a puzzling situation. I am using the following code in Delphi to copy a list of files to the clipboard;
procedure TfMain.CopyFilesToClipboard(FileList: string);
const
C_UNABLE_TO_ALLOCATE_MEMORY = 'Unable to allocate memory.';
C_UNABLE_TO_ACCESS_MEMORY = 'Unable to access allocated memory.';
var
DropFiles: PDropFiles;
hGlobal: THandle;
iLen: Integer;
begin
iLen := Length(FileList);
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or
GMEM_ZEROINIT, SizeOf(TDropFiles) + ((iLen + 2) * SizeOf(Char)));
if (hGlobal = 0) then
raise Exception.Create(C_UNABLE_TO_ALLOCATE_MEMORY);
try DropFiles := GlobalLock(hGlobal);
if (DropFiles = nil) then raise Exception.Create(C_UNABLE_TO_ACCESS_MEMORY);
try
DropFiles^.pFiles := SizeOf(TDropFiles);
DropFiles^.fWide := True;
if FileList <> '' then
Move(FileList[1], (PByte(DropFiles) + SizeOf(TDropFiles))^,
iLen * SizeOf(Char));
finally
GlobalUnlock(hGlobal);
end;
Clipboard.SetAsHandle(CF_HDROP, hGlobal);
except
GlobalFree(hGlobal);
end;
end;
(This seems to be a popular piece of code on the internet)
Using my application, once the files are copied to the clipboard, I can use Windows Explorer to paste them into every other folder, EXCEPT the folder where the file originally came from! I was expecting it to behave just like a normal Windows copy (i.e. on paste it should create a file with postfix of '-Copy') but this doesn't seem to work. Any clues?
I am not able to get Windows Explorer to paste into the source folder when the only clipboard format available is CF_HDROP. However, if the filenames are provided in an IDataObject instead, it works fine.
If all of the files are from the same source folder, you can retrieve the IShellFolder of the source folder and query it for child PIDLs for the individual files, then use IShellFolder.GetUIObjectOf() to get an IDataObject that represents the files. Then use OleSetClipboard() to put that object on the clipboard. For example:
uses
System.Classes, Winapi.Windows, Winapi.ActiveX, Winapi.Shlobj, Winapi.ShellAPI, System.Win.ComObj;
procedure CopyFilesToClipboard(const Folder: string; FileNames: TStrings);
var
SF: IShellFolder;
PidlFolder: PItemIDList;
PidlChildren: array of PItemIDList;
Eaten: UINT;
Attrs: DWORD;
Obj: IDataObject;
I: Integer;
begin
if (Folder = '') or (FileNames = nil) or (FileNames.Count = 0) then Exit;
OleCheck(SHParseDisplayName(PChar(Folder), nil, PidlFolder, 0, Attrs));
try
OleCheck(SHBindToObject(nil, PidlFolder, nil, IShellFolder, Pointer(SF)));
finally
CoTaskMemFree(PidlFolder);
end;
SetLength(PidlChildren, FileNames.Count);
for I := Low(PidlChildren) to High(PidlChildren) do
PidlChildren[i] := nil;
try
for I := 0 to FileNames.Count-1 do
OleCheck(SF.ParseDisplayName(0, nil, PChar(FileNames[i]), Eaten, PidlChildren[i], Attrs));
OleCheck(SF.GetUIObjectOf(0, FileNames.Count, PIdlChildren[0], IDataObject, nil, obj));
finally
for I := Low(PidlChildren) to High(PidlChildren) do
begin
if PidlChildren[i] <> nil then
CoTaskMemFree(PidlChildren[i]);
end;
end;
OleCheck(OleSetClipboard(obj));
OleCheck(OleFlushClipboard);
end;
Update: If the files are in different source folders, you can use the CFSTR_SHELLIDLIST format:
uses
System.Classes, System.SysUtils, Winapi.Windows, Winapi.ActiveX, Winapi.Shlobj, Winapi.ShellAPI, System.Win.ComObj, Vcl.Clipbrd;
{$POINTERMATH ON}
function HIDA_GetPIDLFolder(pida: PIDA): LPITEMIDLIST;
begin
Result := LPITEMIDLIST(LPBYTE(pida) + pida.aoffset[0]);
end;
function HIDA_GetPIDLItem(pida: PIDA; idx: Integer): LPITEMIDLIST;
begin
Result := LPITEMIDLIST(LPBYTE(pida) + (PUINT(#pida.aoffset[0])+(1+idx))^);
end;
var
CF_SHELLIDLIST: UINT = 0;
type
CidaPidlInfo = record
Pidl: PItemIDList;
PidlOffset: UINT;
PidlSize: UINT;
end;
procedure CopyFilesToClipboard(FileNames: TStrings);
var
PidlInfo: array of CidaPidlInfo;
Attrs, AllocSize: DWORD;
gmem: THandle;
ida: PIDA;
I: Integer;
begin
if (FileNames = nil) or (FileNames.Count = 0) or (CF_SHELLIDLIST = 0) then Exit;
SetLength(PidlInfo, FileNames.Count);
for I := Low(PidlInfo) to High(PidlInfo) do
PidlInfo[I].Pidl := nil;
try
AllocSize := SizeOf(CIDA)+(SizeOf(UINT)*FileNames.Count)+SizeOf(Word);
for I := 0 to FileNames.Count-1 do
begin
OleCheck(SHParseDisplayName(PChar(FileNames[I]), nil, PidlInfo[I].Pidl, 0, Attrs));
PidlInfo[I].PidlOffset := AllocSize;
PidlInfo[I].PidlSize := ILGetSize(PidlInfo[I].Pidl);
Inc(AllocSize, PidlInfo[I].PidlSize);
end;
gmem := GlobalAlloc(GMEM_MOVEABLE, AllocSize);
if gmem = 0 then RaiseLastOSError;
try
ida := PIDA(GlobalLock(gmem));
if ida = nil then RaiseLastOSError;
try
ida.cidl := FileNames.Count;
ida.aoffset[0] := SizeOf(CIDA)+(SizeOf(UINT)*FileNames.Count);
HIDA_GetPIDLFolder(ida).mkid.cb := 0;
for I := 0 to FileNames.Count-1 do
begin
ida.aoffset[1+I] := PidlInfo[I].PidlOffset;
Move(PidlInfo[I].Pidl^, HIDA_GetPIDLItem(ida, I)^, PidlInfo[I].PidlSize);
end;
finally
GlobalUnlock(gmem);
end;
Clipboard.SetAsHandle(CF_SHELLIDLIST, gmem);
except
GlobalFree(gmem);
raise;
end;
finally
for I := Low(PidlInfo) to High(PidlInfo) do
CoTaskMemFree(PidlInfo[I].Pidl);
end;
end;
initialization
CF_SHELLIDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
Alternatively:
procedure CopyFilesToClipboard(FileNames: TStrings);
var
Pidls: array of PItemIdList;
Attrs: DWORD;
I: Integer;
obj: IDataObject;
begin
if (FileNames = nil) or (FileNames.Count = 0) then Exit;
SetLength(Pidls, FileNames.Count);
for I := Low(Pidls) to High(Pidls) do
Pidls[I] := nil;
try
for I := 0 to FileNames.Count-1 do
OleCheck(SHParseDisplayName(PChar(FileNames[I]), nil, Pidls[I], 0, Attrs));
OleCheck(CIDLData_CreateFromIDArray(nil, FileNames.Count, PItemIDList(Pidls), obj));
finally
for I := Low(Pidls) to High(Pidls) do
CoTaskMemFree(Pidls[I]);
end;
OleCheck(OleSetClipboard(obj));
OleCheck(OleFlushClipboard);
end;
However, I found that Windows Explorer will sometimes but not always allow CFSTR_SHELLIDLIST to be pasted into the source folder of a referenced file. I don't know what criteria is preventing Windows Explorer from pasting. Maybe some kind of permissions issue?
You should take Microsoft's advice:
Handling Shell Data Transfer Scenarios
Include as many formats as you can support. You generally do not know where the data object will be dropped. This practice improves the odds that the data object will contain a format that the drop target can accept.
I'm looking for the best* method to find the primary email address for the currently logged in Active Directory user (using GetUserName to get the logged in username)
I have seen How do integrate Delphi with Active Directory? but I couldn't get this to work with Delphi 2010.
(*best method: the eventual application will be run by users who do not have administrative access to the machine)
Edit 1:
Reading up on this, it appears that the email or mail field is probably not the best way to go as it seems it might not be populated, therefore I'd need to use the multivalue field of proxyaddresses
The code below works for me. It is an extract of a class I use in production code. It didn't get the proxyAddresses but I added that and it seems to work, although I get only one alternative e-mail address, looking like smtp: g.trol#mydomain.com. I can't find an example with more that one address, so you may need to test what happens then.
Also, I tested this in Delphi 2007, using a type library I found somewhere, because I had trouble importing it. In the code you see __MIDL_0010, which is a __MIDL___MIDL_itf_ads_0000_0017 record property of the field value. I noticed this was named otherwise in a different version of the type library, so you may need to make some tweaks to this code to suit your exact type library import, an maybe fix some ansi/unicode differences.
uses ActiveX, ComObj, ActiveDs_TLB;
const
NETAPI32DLL = 'netapi32.dll';
const
ACTIVEDSDLL = 'activeds.dll';
ADS_SECURE_AUTHENTICATION = $00000001;
const
// ADSI success codes
S_ADS_ERRORSOCCURRED = $00005011;
S_ADS_NOMORE_ROWS = $00005012;
S_ADS_NOMORE_COLUMNS = $00005013;
// ADSI error codes
E_ADS_BAD_PATHNAME = $80005000;
E_ADS_INVALID_DOMAIN_OBJECT = $80005001;
E_ADS_INVALID_USER_OBJECT = $80005002;
E_ADS_INVALID_COMPUTER_OBJECT = $80005003;
E_ADS_UNKNOWN_OBJECT = $80005004;
E_ADS_PROPERTY_NOT_SET = $80005005;
E_ADS_PROPERTY_NOT_SUPPORTED = $80005006;
E_ADS_PROPERTY_INVALID = $80005007;
E_ADS_BAD_PARAMETER = $80005008;
E_ADS_OBJECT_UNBOUND = $80005009;
E_ADS_PROPERTY_NOT_MODIFIED = $8000500A;
E_ADS_PROPERTY_MODIFIED = $8000500B;
E_ADS_CANT_CONVERT_DATATYPE = $8000500C;
E_ADS_PROPERTY_NOT_FOUND = $8000500D;
E_ADS_OBJECT_EXISTS = $8000500E;
E_ADS_SCHEMA_VIOLATION = $8000500F;
E_ADS_COLUMN_NOT_SET = $80005010;
E_ADS_INVALID_FILTER = $80005014;
type
TNetWkstaGetInfo = function(ServerName: PWideChar; Level: Cardinal;
out BufPtr: Pointer): Cardinal; stdcall;
TADsOpenObject = function (lpszPathName: PWideChar; lpszUserName: PWideChar;
lpszPassword: PWideChar; dwReserved: DWORD; const riid: TGUID;
out pObject): HRESULT; stdcall;
TADsGetObject = function(PathName: PWideChar; const IID: TGUID; out Void):
HRESULT; stdcall;
var
NetLibHandle: THandle;
NetWkstaGetInfo : TNetWkstaGetInfo;
AdsLibHandle: THandle;
_ADsOpenObject : TADsOpenObject;
_ADsGetObject :TADsGetObject;
// VB-like GetObject function
function GetObject(const Name: String): IDispatch;
var
Moniker: IMoniker;
Eaten: integer;
BindContext: IBindCtx;
Dispatch: IDispatch;
begin
OleCheck(CreateBindCtx(0, BindContext));
OleCheck(MkParseDisplayName(BindContext,
PWideChar(WideString(Name)),
Eaten,
Moniker));
OleCheck(Moniker.BindToObject(BindContext, nil, IDispatch, Dispatch));
Result := Dispatch;
end;
// Some network info
type
PWkstaInfo100 = ^TWkstaInfo100;
_WKSTA_INFO_100 = record
wki100_platform_id: DWORD;
wki100_computername: LPWSTR;
wki100_langroup: LPWSTR;
wki100_ver_major: DWORD;
wki100_ver_minor: DWORD;
end;
TWkstaInfo100 = _WKSTA_INFO_100;
WKSTA_INFO_100 = _WKSTA_INFO_100;
function GetCurrentDomain: String;
var
pWI: PWkstaInfo100;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if NetWkstaGetInfo(nil, 100, Pointer(pWI)) = 0 then
Result := String(pWI.wki100_langroup);
end;
end;
// ADs...Object function wrappers
function ADsGetObject(PathName: PWideChar; const IID: TGUID;
out Void): HRESULT;
begin
if Assigned(_ADsGetObject) then
Result := _ADsGetObject(PathName, IID, Void)
else
Result := ERROR_CALL_NOT_IMPLEMENTED;
end;
function ADsOpenObject(lpszPathName, lpszUserName,
lpszPassword: PWideChar; dwReserved: DWORD; const riid: TGUID;
out pObject): HRESULT;
begin
if Assigned(_ADsOpenObject) then
Result := _ADsOpenObject(lpszPathName, lpszUserName, lpszPassword, dwReserved, riid, pObject)
else
Result := ERROR_CALL_NOT_IMPLEMENTED;
end;
// The main function
function GetUserInfo(UserAccountName: string): Boolean;
var
// Domain info: Max password age
RootDSE: Variant;
Domain: Variant;
MaxPwdNanoAge: Variant;
MaxPasswordAge: Int64;
DNSDomain: String;
// User info: User directorysearch to find the user by username
DirectorySearch: IDirectorySearch;
SearchPreferences: array[0..1] of ADS_SEARCHPREF_INFO;
Columns: array[0..6] of PWideChar;
SearchResult: Cardinal;
hr: HRESULT;
ColumnResult: ads_search_column;
// Number of user records found
RecordCount: Integer;
LastSetDateTime: TDateTime;
ExpireDateTime: TDateTime;
i: Integer;
begin
Result := False;
// If no account name is set, reading is impossible. Return false.
if (UserAccountName = '') then
Exit;
try
// Read the maximum password age from the domain.
// To do: Check if this can be done with ADsGetObject instead of the VB-like GetObject
// Get the Root DSE.
RootDSE := GetObject('LDAP://RootDSE');
DNSDomain := RootDSE.Get('DefaultNamingContext');
Domain := GetObject('LDAP://' + DNSDomain);
// Build an array of user properties to receive.
Columns[0] := StringToOleStr('AdsPath');
Columns[1] := StringToOleStr('pwdLastSet');
Columns[2] := StringToOleStr('displayName');
Columns[3] := StringToOleStr('mail');
Columns[4] := StringToOleStr('sAMAccountName');
Columns[5] := StringToOleStr('userPrincipalName');
Columns[6] := StringToOleStr('proxyAddresses');
// Bind to the directorysearch object. For some unspecified reason, the regular
// domain name (yourdomain) needs to be used instead of the AdsPath (office.yourdomain.us)
AdsGetObject(PWideChar(WideString('LDAP://' + GetCurrentDomain)), IDirectorySearch, DirectorySearch);
try
// Set search preferences.
SearchPreferences[0].dwSearchPref := ADS_SEARCHPREF_SEARCH_SCOPE;
SearchPreferences[0].vValue.dwType := ADSTYPE_INTEGER;
SearchPreferences[0].vValue.__MIDL_0010.Integer := ADS_SCOPE_SUBTREE;
DirectorySearch.SetSearchPreference(#SearchPreferences[0], 1);
// Execute search
// Search for SAM account name (g.trol) and User Principal name
// (g.trol#yourdomain.com). This allows the user to enter their username
// in both ways. Add CN=* to filter out irrelevant objects that might
// match the principal name.
DirectorySearch.ExecuteSearch(
PWideChar(WideString(
Format('(&(CN=*)(|(sAMAccountName=%0:s)(userPrincipalName=%0:s)))',
[UserAccountName]))),
nil,
$FFFFFFFF,
SearchResult);
// Get records
RecordCount := 0;
hr := DirectorySearch.GetNextRow(SearchResult);
if (hr <> S_ADS_NOMORE_ROWS) then
begin
// 1 row found
Inc(RecordCount);
// Get the column values for this row.
// To do: This code could use a more general and neater approach!
for i := Low(Columns) to High(Columns) do
begin
hr := DirectorySearch.GetColumn(SearchResult, Columns[i], ColumnResult);
if Succeeded(hr) then
begin
// Get the values for the columns.
{if SameText(ColumnResult.pszAttrName, 'AdsPath') then
Result.UserAdsPath :=
ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'pwdLastSet') then
begin
LastSetDateTime := LDapTimeStampToDateTime(
ColumnResult.pAdsvalues^.__MIDL_0010.LargeInteger) +
GetTimeZoneCorrection;
ExpireDateTime := IncMilliSecond(LastSetDateTime,
LDapIntervalToMSecs(MaxPasswordAge));
Result.UserPasswordExpireDateTime := ExpireDateTime;
end
else if SameText(ColumnResult.pszAttrName, 'displayName') then
Result.UserFullName := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'mail') then
Result.UserEmail := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'sAMAccountName') then
Result.UserShortAccountName := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else if SameText(ColumnResult.pszAttrName, 'userPrincipalName') then
Result.UserFullAccountName := ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString
else ..}
if SameText(ColumnResult.pszAttrName, 'proxyAddresses') then
ShowMessage(ColumnResult.pADsValues.__MIDL_0010.CaseIgnoreString);
// Free the column result
DirectorySearch.FreeColumn(ColumnResult);
end;
end;
// Small check if this account indeed is the only one found.
// No need to check the exact number. <> 1 = error
Hr := DirectorySearch.GetNextRow(SearchResult);
if (hr <> S_ADS_NOMORE_ROWS) then
Inc(RecordCount);
end;
// Close the search
DirectorySearch.CloseSearchHandle(SearchResult);
// Exactly 1 record found?
if RecordCount = 1 then
Result := True
else
ShowMessageFmt('More than one account found when searching for %s in ' +
'Active Directory.', [UserAccountName]);
finally
DirectorySearch := nil;
end;
except
Result := False;
end;
end;
initialization
NetLibHandle := LoadLibrary(NETAPI32DLL);
if NetLibHandle <> 0 then
#NetWkstaGetInfo := GetProcAddress(NetLibHandle, 'NetWkstaGetInfo');
ADsLibHandle := LoadLibrary(ACTIVEDSDLL);
if ADsLibHandle <> 0 then
begin
#_ADsOpenObject := GetProcAddress(ADsLibHandle, 'ADsOpenObject');
#_ADsGetObject := GetProcAddress(ADsLibHandle, 'ADsGetObject');
end;
finalization
FreeLibrary(ADsLibHandle);
FreeLibrary(NetLibHandle);
end.
Call like this:
GetUserInfo('g.trol' {or g.trol#yourdomain.com});
Download from My dropbox
HI. Could you help me please. How to show standard windows "File Properties" dialog for a list of files, but the files have different location?
For ex:
D:\
D:\Pictures
E:\Text.txt
I've found an example and it works fine:
function SHMultiFileProperties(pDataObj: IDataObject; Flag: DWORD): HRESULT;
stdcall; external 'shell32.dll';
function GetFileListDataObject(Files: TStrings): IDataObject;
type
PArrayOfPItemIDList = ^TArrayOfPItemIDList;
TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
Malloc: IMalloc;
Root: IShellFolder;
p: PArrayOfPItemIDList;
chEaten, dwAttributes: ULONG;
i, FileCount: Integer;
begin
Result := nil;
FileCount := Files.Count;
if FileCount = 0 then Exit;
OleCheck(SHGetMalloc(Malloc));
OleCheck(SHGetDesktopFolder(Root));
p := AllocMem(SizeOf(PItemIDList) * FileCount);
try
for i := 0 to FileCount - 1 do
try
if not (DirectoryExists(Files[i]) or FileExists(Files[i])) then Continue;
OleCheck(Root.ParseDisplayName(GetActiveWindow,
nil,
PWideChar(WideString(Files[i])),
chEaten,
p^[i],
dwAttributes));
except
end;
OleCheck(Root.GetUIObjectOf(GetActiveWindow,
FileCount,
p^[0],
IDataObject,
nil,
Pointer(Result)));
finally
for i := 0 to FileCount - 1 do
begin
if p^[i] <> nil then Malloc.Free(p^[i]);
end;
FreeMem(p);
end;
end;
procedure ShowFileProperties(Files: TStrings; aWnd: HWND);
type
PArrayOfPItemIDList = ^TArrayOfPItemIDList;
TArrayOfPItemIDList = array[0..0] of PItemIDList;
var
Data: IDataObject;
begin
if Files.Count = 0 then Exit;
Data := GetFileListDataObject(Files);
SHMultiFileProperties(Data, 0);
end;
But when I pass a Drive letter, it shows an empty "File Properties" dialog:
///
SL.Add('D:\');
ShowFileProperties(SL, Handle);
I have another example:
Procedure ShowFileProperties(Const filename: String);
Var
sei: TShellExecuteinfo;
Begin
FillChar(sei,sizeof(sei),0);
sei.cbSize := sizeof(sei);
sei.lpFile := Pchar(filename);
sei.lpVerb := 'Properties';
sei.fMask := SEE_MASK_INVOKEIDLIST;
ShellExecuteEx(#sei);
End;
It also shows "File Properties" Dialog , but unfortunately for one file only. How to pass multiple files with different locations in this example???
I also found another source which has the procedures I need but they require files to be located in the same folder. Here is a link: link text
I would take a look at the code example found here. I think you should be able to use that idea to pass in multiple file paths.
How do I get a list of the running processes (with details of PID, Owner etc) on my machine using Delphi?
EDIT: None of the solutions proposed gives me the user that owns the process, only info such as PID, ExeName etc...
One way is using the Tool Help library (see TlHelp32 unit), or EnumProcesses on Windows NT (see PsAPI unit). Have a look at JclSysInfo.RunningProcessesList in the JCL for an example.
Here's a quick example of how to get the user name of a process:
type
PTokenUser = ^TTokenUser;
TTokenUser = packed record
User: SID_AND_ATTRIBUTES;
end;
function GetProcessUserName(ProcessID: Cardinal; out DomainName, UserName: string): Boolean;
var
ProcessHandle, ProcessToken: THandle;
InfoSize, UserNameSize, DomainNameSize: Cardinal;
User: PTokenUser;
Use: SID_NAME_USE;
_DomainName, _UserName: array[0..255] of Char;
begin
Result := False;
DomainName := '';
UserName := '';
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle = 0 then
Exit;
try
if not OpenProcessToken(ProcessHandle, TOKEN_QUERY, ProcessToken) then
Exit;
try
GetTokenInformation(ProcessToken, TokenUser, nil, 0, InfoSize);
User := AllocMem(InfoSize * 2);
try
if GetTokenInformation(ProcessToken, TokenUser, User, InfoSize * 2, InfoSize) then
begin
DomainNameSize := SizeOf(_DomainName);
UserNameSize := SizeOf(_UserName);
Result := LookupAccountSid(nil, User^.User.Sid, _UserName, UserNameSize, _DomainName, DomainNameSize, Use);
if Result then
begin
SetString(DomainName, _DomainName, StrLen(_DomainName));
SetString(UserName, _UserName, StrLen(_UserName));
end;
end;
finally
FreeMem(User);
end;
finally
CloseHandle(ProcessToken);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
This is the function we use to check if a process exists, the FProcessEntry32 holds all the info on the process, so you should be able to extend it to what every you need.
it was taken from here
uses TlHelp32
function processExists(exeFileName: string): Boolean;
{description checks if the process is running
URL: http://www.swissdelphicenter.ch/torry/showcode.php?id=2554}
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
begin
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The TProcessEntry32 record looks like so:
tagPROCESSENTRY32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;
You have to use:
CreateToolhelp32Snapshot Function
Process32First Function
Process32Next Function
PROCESSENTRY32 Structure will contain all the informations that you may need.
The documentation is from MDSN, for C++, but it's the same in Delphi.
This class will give you a list of all open windows (listed below) with PID, caption, dimensions, etc. It's not exactly running processes information, but I've used it to find apps via it.
// Window List Component 1.5 by Jerry Ryle
//
// Aaugh! I accidentally uploaded the wrong source
// which had a nasty bug in the refresh procedure!
// Thanks to Serge, who found my mistake and suggested
// a few other improvements!
//
// This component will enumerate windows and return
// information about them in the Windows property.
// The component currently returns a handle, caption text,
// associated ProcessID, visibility, and dimensions.
// For documentation, please read the accompanying
// WindowList.txt
//
// This component is completely free of course. If you find
// it useful, and are compelled to send me cash, beer, or
// dead things in envelopes, please feel free to do so.
//
// email me if you make it better: gryle#calpoly.edu
unit WindowList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TWindowObject = record
WinHandle : HWnd; // Window Handle
WinCaption : String; // Window Caption Text (If any)
ProcessID : Integer; // Process the window belongs to
IsVisible : Boolean; // Is the window visible?
IsEnabled : Boolean; // Is the window enabled for mouse/keyboard input?
IsIconic : Boolean; // Is the window minimized?
WindowRect : TRect; // Window Dimensions
// Add more properties here if you like,
// then fill them in at the WindowCallback
// function.
end;
PTWindowObject = ^TWindowObject;
TWindowList = class(TComponent)
private
WindowLst : TList;
FCount : Integer;
protected
Function GetAWindow(Index : Integer) : TWindowObject;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure Refresh;
Property Windows[Index : Integer]: TWindowObject read GetAWindow;
Property Count : Integer read FCount;
published
// Published declarations
end;
procedure Register;
implementation
// Note that this function is not a member of WindowList.
// Therefore, the list to be filled needs to be passed
// as a pointer. Note that this is passed as a VAR. if you
// don't do this, bad things happen in memory.
Function WindowCallback(WHandle : HWnd; Var Parm : Pointer) : Boolean; stdcall;
// This function is called once for each window
Var MyString : PChar;
MyInt : Integer;
MyWindowPtr : ^TWindowObject;
begin
New(MyWindowPtr);
// Window Handle (Passed by the enumeration)
MyWindowPtr.WinHandle := WHandle;
// Window text
MyString := Allocmem(255);
GetWindowText(WHandle,MyString,255);
MyWindowPtr.WinCaption := String(MyString);
FreeMem(MyString,255);
// Process ID
MyInt := 0;
MyWindowPtr.ProcessID := GetWindowThreadProcessId(WHandle,#MyInt);
// Visiblity
MyWindowPtr.IsVisible := IsWindowVisible(WHandle);
// Enabled
MyWindowPtr.IsEnabled := IsWindowEnabled(WHandle);
// Iconic
MyWindowPtr.IsIconic := IsIconic(WHandle);
// Window Dimensions
MyWindowPtr.WindowRect := Rect(0,0,0,0);
GetWindowRect(WHandle,MyWindowPtr.WindowRect);
// Add the structure to the list. Do not dereference Parm...
// once again, bad things happen.
TList(Parm).Add(MyWindowPtr);
Result := True; // Everything's okay. Continue to enumerate windows
end;
constructor TWindowList.Create(AOwner: TComponent);
var MyWindowPtr : PTWindowObject;
begin
inherited;
WindowLst := TList.Create;
// Thanks Serge, I should've done this from the start :)
// Sloppy me.
If Not ( csDesigning in ComponentState ) Then
Begin
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
End
Else
FCount := 0;
end;
destructor TWindowList.Destroy;
var I : Integer;
begin
If WindowLst.Count > 0 Then
Begin
For I := 0 To (WindowLst.Count - 1) Do
Dispose(PTWindowObject(WindowLst[I]));
End;
WindowLst.Free;
inherited;
end;
procedure TWindowList.Refresh;
begin
WindowLst.Clear; {Clear the list!}
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
end;
function TWindowList.GetAWindow(Index : Integer) : TWindowObject;
begin
Result := PTWindowObject(WindowLst[Index])^;
end;
procedure Register;
begin
RegisterComponents('System', [TWindowList]);
end;
end.
You could look at using the WMISet components ($69 single licence, $199 for site licence, trial version available). The TWmiProcessControl component seems to encapsulate calls to Win32_Process. They also have an example of getting a process owner.
I think Madshi madKernel could be interesting to check out.