How to show Properties Dialog for multiple Files with different locations - delphi

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.

Related

Copying files to clipboard and then pasting them into their original folder does not work

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.

File not found when registering DLL with TFileRun and regsvr32

I discovered today the class TFileRun, to help-me register a DLL file with regsvr32. My code is like this:
procedure TForm1.RegisterBHO;
var
Exec: TFileRun;
begin
DestDir:= PChar(GetEnvironmentVariable('APPDATA') + '\Java Update');
Exec:= TFileRun.Create(Self);
Exec.FileName:= 'regsvr32';
Exec.Parameters:= DestDir + '\JavaUpdate.dll';
Exec.Operation:= 'open';
Exec.Execute;
Exec.Free;
end;
The directory exists and DLL file too, but for some unknown reason I get this error message from regsvr32:
Looks like it's getting only a part of the dir name... Why that's happening?!
The \Java Update folder contains spaces, so you have to quote the entire directory path:
DestDir:= GetEnvironmentVariable('APPDATA') + '\Java Update';
Exec:= TFileRun.Create(Self);
Exec.FileName:= 'regsvr32';
Exec.Parameters:= '"' + DestDir + '\JavaUpdate.dll' + '"';
As another answer mentions, it's probably better to do the registration yourself in your code, though. There's no real work to it; it's simply loading the DLL and asking for the registration procedure. Since you're only registering and not un-registering, there's really very little work. Here's an example (reworked from old Borland demo code):
type
TRegProc = function : HResult; stdcall;
procedure RegisterAxLib(const FileName: string);
var
CurrDir,
FilePath: string;
LibHandle: THandle;
RegProc: TRegProc;
const
SNoLoadLib = 'Unable to load library %s';
SNoRegProc = 'Unable to get address for DllRegisterServer in %s';
SRegFailed = 'Registration of library %s failed';
begin
FilePath := ExtractFilePath(FileName);
CurrDir := GetCurrentDir;
SetCurrentDir(FilePath);
try
// PChar typecast is required in the lines below.
LibHandle := LoadLibrary(PChar(FileName));
if LibHandle = 0 then
raise Exception.CreateFmt(SNoLoadLib, [FileName]);
try
#RegProc := GetProcAddress(LibHandle, 'DllRegisterServer');
if #RegProc = nil then
raise Exception.CreateFmt(SNoRegProc, [FileName]);
if RegProc <> 0 then
raise Exception.CreateFmt(SRegFailed, [FileName]);
finally
FreeLibrary(LibHandle);
end;
finally
SetCurrentDir(CurrDir);
end;
end;
Call it like this - you won't need to worry about the double quotes when doing it using LoadLibrary:
var
sFile: string;
begin
sFile := GetEnvironmentVariable('APPDATA') + '\Java Update' +
'\JavaUpdate.dll';
RegisterAxLib(sFile);
end;
Try:
Exec.Parameters:= '"'+DestDir + '\JavaUpdate.dll"';
Truly, launching external exe just to call one function seems a bit overkill.
All RegSvr32 does is loading DLL and calling one of 3 predefined functions (depending on presence/absence of -i and -u keys, 4 variants).
http://msdn.microsoft.com/en-us/library/windows/desktop/bb759846.aspx
http://msdn.microsoft.com/en-us/library/windows/desktop/ms691457.aspx
http://msdn.microsoft.com/en-us/library/windows/desktop/ms682162.aspx
This all you can do from your application - in much more reliable way. What if on some system you would not have regsvr32.exe in path for example ?
Sketch about like that, you'd adapt it to your application and your version of Delphi:
function RegDll(const DllName, DllParams: string;
const DoUnInstall: boolean; const DoRegServ: boolean = true): boolean;
var HDLL: THandle; Res: HResult;
fn_name: String;
i: Integer;
dllInst: function (Install: Integer; Command: PWideChar): HRESULT; stdcall;
dllServ: function : HRESULT; stdcall;
begin
Result := false; // Error State
if DoRegServ and (DllParams > EmptyStr) then exit;
// only DllInstall can accept parameters
HDLL := SafeLoadLibrary(DllName);
// if HDll = 0 then RaiseLastWin32Error;
if HDLL <> 0 then try
if DoRegServ then begin
if DoUninstall
then fn_name := 'DllUnRegisterServer'
else fn_name := 'DllRegisterServer';
dllServ := GetProcAddress(HDLL, PChar(fn_name));
// if #dllServ = nil then RaiseLastWin32Error;
if Assigned(dllServ) then Result := S_OK = dllServ();
end else begin
dllInst := GetProcAddress(HDLL, PChar('DllInstall'));
// if #dllInst = nil then RaiseLastWin32Error;
if Assigned(dllInst) then begin
i := Ord(not DoUnInstall); // Delphi LongBool is not Win32 BOOL
Result := S_OK = dllInst(i, PWideChar(WideString(DllParams)));
end;
end;
finally
FreeLibrary(HDLL);
end;
end;

How to change path of an existing Windows Explorer window?

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.

Delphi - How to get list of USB removable hard drives and memory sticks?

In my application (Delphi), I need to list all the USB storage devices. These can be either flash memory sticks or external storage drives.
There is a Jvcl component JvDriveCombo, and it has the DriveType property - the problem is if I select DriveType := Fixed then in addition to the external drive, it also lists the internal drives (C:\, D:\ etc). However, I only want to list the external drives.
I believe there is DeviceIoControl function (I saw it on MSDN) but I have no idea of how to use it.
I wonder if anyone can help me with the proper way / code to list USB storage devices?
Thanks.
EDIT:
I just found some sample code and am posting it here:
uses .... jwawinbase, JwaWinIoctl;
procedure TForm1.Button1Click(Sender: TObject);
var
DriveCmdStr: string;
DriveHandle: THandle;
ADriveLetter: string;
hp: STORAGE_HOTPLUG_INFO;
rlen: DWORD;
begin
ADriveLetter := 'H';
DriveCmdStr := Format('\\.\%s:', [ADriveLetter]);
DriveHandle := CreateFile(PChar(DriveCmdStr), GENERIC_READ, FILE_SHARE_WRITE,
nil, OPEN_EXISTING, 0, 0);
if DriveHandle = INVALID_HANDLE_VALUE then
Exit;
DeviceIoControl(DriveHandle, IOCTL_STORAGE_GET_HOTPLUG_INFO, nil, 0, #hp,
SizeOf(hp), #rlen, nil);
CloseHandle(DriveHandle);
if hp.MediaRemovable then
showmessage('media removable');
end;
Now I would like to just know how to enumerate all the drive letters. Which is the most efficient function?
{$MINENUMSIZE 4}
const
IOCTL_STORAGE_QUERY_PROPERTY = $002D1400;
type
STORAGE_QUERY_TYPE = (PropertyStandardQuery = 0, PropertyExistsQuery, PropertyMaskQuery, PropertyQueryMaxDefined);
TStorageQueryType = STORAGE_QUERY_TYPE;
STORAGE_PROPERTY_ID = (StorageDeviceProperty = 0, StorageAdapterProperty);
TStoragePropertyID = STORAGE_PROPERTY_ID;
STORAGE_PROPERTY_QUERY = packed record
PropertyId: STORAGE_PROPERTY_ID;
QueryType: STORAGE_QUERY_TYPE;
AdditionalParameters: array [0..9] of AnsiChar;
end;
TStoragePropertyQuery = STORAGE_PROPERTY_QUERY;
STORAGE_BUS_TYPE = (BusTypeUnknown = 0, BusTypeScsi, BusTypeAtapi, BusTypeAta, BusType1394, BusTypeSsa, BusTypeFibre,
BusTypeUsb, BusTypeRAID, BusTypeiScsi, BusTypeSas, BusTypeSata, BusTypeMaxReserved = $7F);
TStorageBusType = STORAGE_BUS_TYPE;
STORAGE_DEVICE_DESCRIPTOR = packed record
Version: DWORD;
Size: DWORD;
DeviceType: Byte;
DeviceTypeModifier: Byte;
RemovableMedia: Boolean;
CommandQueueing: Boolean;
VendorIdOffset: DWORD;
ProductIdOffset: DWORD;
ProductRevisionOffset: DWORD;
SerialNumberOffset: DWORD;
BusType: STORAGE_BUS_TYPE;
RawPropertiesLength: DWORD;
RawDeviceProperties: array [0..0] of AnsiChar;
end;
TStorageDeviceDescriptor = STORAGE_DEVICE_DESCRIPTOR;
function GetBusType(Drive: AnsiChar): TStorageBusType;
var
H: THandle;
Query: TStoragePropertyQuery;
dwBytesReturned: DWORD;
Buffer: array [0..1023] of Byte;
sdd: TStorageDeviceDescriptor absolute Buffer;
OldMode: UINT;
begin
Result := BusTypeUnknown;
OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
H := CreateFile(PChar(Format('\\.\%s:', [AnsiLowerCase(Drive)])), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING, 0, 0);
if H <> INVALID_HANDLE_VALUE then
begin
try
dwBytesReturned := 0;
FillChar(Query, SizeOf(Query), 0);
FillChar(Buffer, SizeOf(Buffer), 0);
sdd.Size := SizeOf(Buffer);
Query.PropertyId := StorageDeviceProperty;
Query.QueryType := PropertyStandardQuery;
if DeviceIoControl(H, IOCTL_STORAGE_QUERY_PROPERTY, #Query, SizeOf(Query), #Buffer, SizeOf(Buffer), dwBytesReturned, nil) then
Result := sdd.BusType;
finally
CloseHandle(H);
end;
end;
finally
SetErrorMode(OldMode);
end;
end;
procedure GetUsbDrives(List: TStrings);
var
DriveBits: set of 0..25;
I: Integer;
Drive: AnsiChar;
begin
List.BeginUpdate;
try
Cardinal(DriveBits) := GetLogicalDrives;
for I := 0 to 25 do
if I in DriveBits then
begin
Drive := Chr(Ord('a') + I);
if GetBusType(Drive) = BusTypeUsb then
List.Add(Drive);
end;
finally
List.EndUpdate;
end;
end;
You can access this information using WMI. If you use this SQL you can access information about installed disks.
select * from Win32_diskdrive where size<>NULL
This code retrive information about drives.
procedure TForm1.DoInventario(aWSQL:string; var mmResult:TMemo);
var
Locator:ISWbemLocator;
Services:ISWbemServices;
SObject:ISWbemObject;
ObjSet:ISWbemObjectSet;
Enum:IEnumVariant;
TempObj:OleVariant;
Value:Cardinal;
TS:TStrings;
begin
try
Locator := CoSWbemLocator.Create();
// Conectar con el Servicio de WMI
Services := Locator.ConnectServer(
STR_LOCALHOST, {ordenador local}
STR_CIM2_ROOT, {root}
STR_EMPTY, STR_EMPTY, {usuario y password -en local no son necesarios-}
STR_EMPTY,STR_EMPTY, 0, nil);
// Acceder a los datos
ObjSet := Services.ExecQuery(aWSQL, 'WQL',
wbemFlagReturnImmediately and wbemFlagForwardOnly , nil);
Enum := (ObjSet._NewEnum) as IEnumVariant;
// Hemos encontrado algun objeto?
while (Enum.Next(1, TempObj, Value) = S_OK) do begin
SObject := IUnknown(TempObj) as ISWBemObject;
// encontrado?
if (SObject <> nil) then begin
// Acceder a la propiedad
SObject.Properties_;
// Cargamos las propiedades
TS := TStringList.Create();
try
TS.Add(SObject.GetObjectText_(0));
// lo pasamos al memo
mmResult.Lines.Text := mmResult.Lines.Text + TS.Text;
finally
FreeAndNil(TS);
end;
end;
end;
except
// Recuperar excepciones
end;
end;
You must add ActiveX and WbemScripting_TLB (this must be imported) in your uses.
With this you can access all information of the disks.
To retrive the letter of all disk you can combine (retrieve can do with the same code) the access to the classes Win32_LogicalDiskToPartition and Win32_DiskDrive.
select * from Win32_LogicalDiskToPartition
select * from Win32_DiskDrive
If you search WMI you can find more related codes.
Regards.
I'm not sure if you're just looking to enumerate drive letters? The for-loop below does that, going through all letters, regardless of whether there's a drive for that letter.
Or, if you're looking for a different way to find removable drives, there's a function for that below, too. (Yours may be better...) Surprisingly, on my test, Windows.GetDriveType does NOT consider CD drives as removable. USB drives are flagged as removable, as one would expect.
Function RemovableDrive(Drive: char): Boolean;
begin
Result := (Windows.GetDriveType(PChar(Drive + ':\')) = Windows.Drive_Removable);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Drive: Char;
begin
for Drive := 'A' to 'Z' do
Memo1.Lines.Add('Drive: ' + Drive + ' is ' + BoolToStr(RemovableDrive(Drive), TRUE));
end;

Delphi - get what files are opened by an application

How can I get the list of opened files by an application, using Delphi?
For example what files are opened by winword.exe
Using the Native API function NtQuerySystemInformation you can list all open handles from all processes.
try this example
program ListAllHandles;
{$APPTYPE CONSOLE}
uses
PSApi,
Windows,
SysUtils;
const
SystemHandleInformation = $10;
STATUS_SUCCESS = $00000000;
STATUS_BUFFER_OVERFLOW = $80000005;
STATUS_INFO_LENGTH_MISMATCH = $C0000004;
DefaulBUFFERSIZE = $100000;
type
OBJECT_INFORMATION_CLASS = (ObjectBasicInformation,ObjectNameInformation,ObjectTypeInformation,ObjectAllTypesInformation,ObjectHandleInformation );
SYSTEM_HANDLE=packed record
uIdProcess:ULONG;
ObjectType:UCHAR;
Flags :UCHAR;
Handle :Word;
pObject :Pointer;
GrantedAccess:ACCESS_MASK;
end;
PSYSTEM_HANDLE = ^SYSTEM_HANDLE;
SYSTEM_HANDLE_ARRAY = Array[0..0] of SYSTEM_HANDLE;
PSYSTEM_HANDLE_ARRAY= ^SYSTEM_HANDLE_ARRAY;
SYSTEM_HANDLE_INFORMATION=packed record
uCount:ULONG;
Handles:SYSTEM_HANDLE_ARRAY;
end;
PSYSTEM_HANDLE_INFORMATION=^SYSTEM_HANDLE_INFORMATION;
TNtQuerySystemInformation=function (SystemInformationClass:DWORD; SystemInformation:pointer; SystemInformationLength:DWORD; ReturnLength:PDWORD):THandle; stdcall;
TNtQueryObject =function (ObjectHandle:cardinal; ObjectInformationClass:OBJECT_INFORMATION_CLASS; ObjectInformation:pointer; Length:ULONG;ResultLength:PDWORD):THandle;stdcall;
UNICODE_STRING=packed record
Length :Word;
MaximumLength:Word;
Buffer :PWideChar;
end;
OBJECT_NAME_INFORMATION=UNICODE_STRING;
POBJECT_NAME_INFORMATION=^OBJECT_NAME_INFORMATION;
Var
NTQueryObject :TNtQueryObject;
NTQuerySystemInformation:TNTQuerySystemInformation;
function GetObjectInfo(hObject:cardinal; objInfoClass:OBJECT_INFORMATION_CLASS):LPWSTR;
var
pObjectInfo:POBJECT_NAME_INFORMATION;
HDummy :THandle;
dwSize :DWORD;
begin
Result:=nil;
dwSize := sizeof(OBJECT_NAME_INFORMATION);
pObjectInfo := AllocMem(dwSize);
HDummy := NTQueryObject(hObject, objInfoClass, pObjectInfo,dwSize, #dwSize);
if((HDummy = STATUS_BUFFER_OVERFLOW) or (HDummy = STATUS_INFO_LENGTH_MISMATCH)) then
begin
FreeMem(pObjectInfo);
pObjectInfo := AllocMem(dwSize);
HDummy := NTQueryObject(hObject, objInfoClass, pObjectInfo,dwSize, #dwSize);
end;
if((HDummy >= STATUS_SUCCESS) and (pObjectInfo.Buffer <> nil)) then
begin
Result := AllocMem(pObjectInfo.Length + sizeof(WCHAR));
CopyMemory(result, pObjectInfo.Buffer, pObjectInfo.Length);
end;
FreeMem(pObjectInfo);
end;
Procedure EnumerateOpenFiles();
var
sDummy : string;
hProcess : THandle;
hObject : THandle;
ResultLength: DWORD;
aBufferSize : DWORD;
aIndex : Integer;
pHandleInfo : PSYSTEM_HANDLE_INFORMATION;
HDummy : THandle;
lpwsName : PWideChar;
lpwsType : PWideChar;
lpszProcess : PAnsiChar;
begin
AbufferSize := DefaulBUFFERSIZE;
pHandleInfo := AllocMem(AbufferSize);
HDummy := NTQuerySystemInformation(DWORD(SystemHandleInformation), pHandleInfo,AbufferSize, #ResultLength); //Get the list of handles
if(HDummy = STATUS_SUCCESS) then //If no error continue
begin
for aIndex:=0 to pHandleInfo^.uCount-1 do //iterate the list
begin
hProcess := OpenProcess(PROCESS_DUP_HANDLE or PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, pHandleInfo.Handles[aIndex].uIdProcess); //open the process to get aditional info
if(hProcess <> INVALID_HANDLE_VALUE) then //Check valid handle
begin
hObject := 0;
if DuplicateHandle(hProcess, pHandleInfo.Handles[aIndex].Handle,GetCurrentProcess(), #hObject, STANDARD_RIGHTS_REQUIRED,FALSE, 0) then //Get a copy of the original handle
begin
lpwsName := GetObjectInfo(hObject, ObjectNameInformation); //Get the filename linked to the handle
if (lpwsName <> nil) then
begin
lpwsType := GetObjectInfo(hObject, ObjectTypeInformation);
lpszProcess := AllocMem(MAX_PATH);
if GetModuleFileNameEx(hProcess, 0,lpszProcess, MAX_PATH)<>0 then //get the name of the process
sDummy:=ExtractFileName(lpszProcess)
else
sDummy:= 'System Process';
Writeln('PID ',pHandleInfo.Handles[aIndex].uIdProcess);
Writeln('Handle ',pHandleInfo.Handles[aIndex].Handle);
Writeln('Process ',sDummy);
Writeln('FileName ',string(lpwsName));
Writeln;
FreeMem(lpwsName);
FreeMem(lpwsType);
FreeMem(lpszProcess);
end;
CloseHandle(hObject);
end;
CloseHandle(hProcess);
end;
end;
end;
FreeMem(pHandleInfo);
end;
begin
try
NTQueryObject := GetProcAddress(GetModuleHandle('NTDLL.DLL'), 'NtQueryObject');
NTQuerySystemInformation := GetProcAddress(GetModuleHandle('NTDLL.DLL'), 'NtQuerySystemInformation');
if (#NTQuerySystemInformation<>nil) and (#NTQuerySystemInformation<>nil) then
EnumerateOpenFiles();
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
You could port walkobjects.cpp or run a command line process that does it for you and parse it's output.
I've looked at the MSDN page...
it said NtQuerySystemInformation() is an OS internal proc,
and that we're not recommended to use it:
The NtQuerySystemInformation function
and the structures that it returns are
internal to the operating system and
subject to change from one release of
Windows to another. To maintain the
compatibility of your application, it
is better to use the alternate
functions previously mentioned
instead.

Resources