File not found when registering DLL with TFileRun and regsvr32 - delphi

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;

Related

How to determine the size of a buffer for a DLL call when the result comes from the DLL

Using both Delphi 10.2 Tokyo and Delphi XE2.
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
The call to the DLL comes from a Delphi XE2 EXE, but I don't believe that is relevant, but I am noting it nonetheless.
The call to post data to a site will often return text data. Sometimes very large amounts of text data. Greater than 150K characters.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
My DLL code where I get the error:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
vcl.Dialogs,
IdSSLOpenSSL, IdHTTP, IdIOHandlerStack, IdURI,
IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall
var HTTPReq : TIdHTTP;
var Response: TStringStream;
var SendStream : TStringStream;
var IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
var Uri : TIdURI;
var s : string;
begin
Result := -1;
try
HTTPReq := TIdHTTP.Create(nil);
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1_2, sslvTLSv1_1];
if Assigned(HTTPReq) then begin
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.Request.ContentType := 'text/xml;charset=UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
HTTPReq.HTTPOptions := [];
end;
SendStream := TStringStream.Create(Body);
Response := TStringStream.Create(EmptyStr);
try
HTTPReq.Request.ContentLength := Length(Body);
Uri := TiDUri.Create(url);
try
HTTPReq.Request.Host := Uri.Host;
finally
Uri.Free;
end;
HTTPReq.Post(url + 'admin.asmx', SendStream,Response);
if Response.Size > 0 then begin
if assigned(OutData) then begin
s := Response.DataString;// Redundant? Probably can just use Response.DataString?
StrPLCopy(OutData, s, OutLen);// <- ACCESS VIOLATION HERE
//StrPLCopy(OutData, s, Response.Size);// <- ACCESS VIOLATION HERE
Result := 0;
end;
end
else begin
Result := -2;
end;
finally
Response.Free;
SendStream.Free;
IdSSLIOHandler.Free;
HTTPReq.Free;
end;
except
on E:Exception do begin
ShowMessage(E.Message);
Result := 1;
end;
end;
end;
exports
PostAdminDataViaDll;
begin
end.
My Calling method code:
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall;
var Handle : THandle;
var MyPost : TMyPost;
var dataString : string;
var returnData : string;
begin
if not (FileExists(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL')) then begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
Exit;
end;
dataString := EmptyStr;
returnData := '';
Handle := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if Handle <> 0 then begin
try
try
MyPost := GetProcAddress(Handle, 'PostAdminDataViaDll');
if #MyPost <> nil then begin
// NOTE 32767 is not big enough for the returned data! Help!
if MyPost(PChar(body), PChar(method), PChar(url), PChar(returnData), 32767) = 0 then begin
dataString := returnData;
end;
end;
except
end;
finally
FreeLibrary(Handle);
end;
end
else begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
end;
if not sametext(dataString, EmptyStr) then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
Why not simply update Indy in XE2 to a newer version that supports TLS 1.2? Then you don't need the DLL at all.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
It is not a "big no-no", especially if the response data is dynamic in nature. Returning a pointer to dynamically allocated data is perfectly fine. You would simply have to export an extra function to free the data when the caller is done using it, that's all. The "big no-no" is that this does introduce a potential memory leak, if the caller forgets to call the 2nd function. But that is what try..finally is good for.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
That is not a lot of memory. Any failure you were getting with it was likely due to you simply misusing the memory.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
That is because you are not filling in the memory correctly.
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
You can't, when using POST. You would have to cache the response data somewhere off to the side, and then expose ways to let the caller query that cache for its size and data afterwards.
My DLL code where I get the error:
My Calling method code:
I see a number of logic mistakes in that code.
But, the most important reason for the Access Violation error is that your EXE is simply not allocating any memory for its returnData variable.
Casting a string to a PChar never produces a nil pointer. If the input string is not empty, a pointer to the string's first Char is returned. Otherwise, a pointer to a static #0 Char is returned instead. This ensures that a string casted to PChar always results in a non-nil, null-terminated, C style character string.
Your EXE is telling the DLL that returnData can hold up to 32767 chars, but in reality it can't hold any chars at all! In the DLL, OutData is not nil, and OutLen is wrong.
Also, StrPLCopy() always null-terminates the output, but the MaxLen parameter does not include the null-terminator, so the caller must allocate room for MaxLen+1 characters. This is stated in the StrPLCopy() documentation.
With all of this said, try something more like this:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
Vcl.Dialogs,
IdIOHandlerStack, IdSSLOpenSSL, IdHTTP, IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar;
var OutData : PChar): integer; stdcall;
var
HTTPReq : TIdHTTP;
SendStream : TStringStream;
IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
s : string;
begin
OutData := nil;
try
HTTPReq := TIdHTTP.Create(nil);
try
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(HTTPReq);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2];
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.HTTPOptions := [];
HTTPReq.Request.ContentType := 'text/xml';
HTTPReq.Request.Charset := 'UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
SendStream := TStringStream.Create(Body, TEncoding.UTF8);
try
s := HTTPReq.Post(string(url) + 'admin.asmx', SendStream);
finally
SendStream.Free;
end;
Result := Length(s);
if Result > 0 then begin
GetMem(OutData, (Result + 1) * Sizeof(Char));
Move(PChar(s)^, OutData^, (Result + 1) * Sizeof(Char));
end;
finally
HTTPReq.Free;
end;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
function FreeDataViaDll(Data : Pointer): integer; stdcall;
begin
try
FreeMem(Data);
Result := 0;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
exports
PostAdminDataToCenPosViaDll,
FreeDataViaDll;
begin
end.
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; var OutData : PChar): integer; stdcall;
TMyFree = function (Data Pointer): integer; stdcall;
var
hDll : THandle;
MyPost : TMyPost;
MyFree : TMyFree;
dataString : string;
returnData : PChar;
returnLen : Integer;
begin
hDll := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if hDll = 0 then begin
Application.MessageBox('Unable to load TestDLL.DLL.', 'Error posting', MB_ICONERROR or MB_OK);
Exit;
end;
try
try
MyPost := GetProcAddress(hDll, 'PostAdminDataViaDll');
MyFree := GetProcAddress(hDll, 'FreeDataViaDll');
if Assigned(MyPost) and Assigned(MyFree) then begin
returnLen := MyPost(PChar(body), PChar(method), PChar(url), returnData);
if returnLen > 0 then begin
try
SetString(dataString, returnData, returnLen);
finally
MyFree(returnData);
end;
end;
end;
finally
FreeLibrary(hDll);
end;
except
end;
if dataString <> '' then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;

Delphi WPD Event Callback - Get Filename

I'm trying to track when a file is created on a WPD-compatible device, such as a digital camera or Android phone. I register to receive events with Advice and my callback is called correctly, but I can't get the file name (perhaps the OBJECT_NAME) properly. Here is what I have:
TPortableDeviceEventsCallback = class(TInterfacedObject, IPortableDeviceEventCallback)
public
function OnEvent(const pEventParameters: IPortableDeviceValues): HResult; dynamic; stdcall;
end;
.
.
.
function TPortableDeviceEventsCallback.OnEvent(const pEventParameters: IPortableDeviceValues): HResult;
var
ObjName: PWideChar;
begin
pEventParameters.GetStringValue(WPD_EVENT_PARAMETER_OBJECT_NAME, ObjName);
Log(string(ObjName));
end;
I only get garbage instead of the added/removed object name. What am I missing here?
First, OnEvent() should not be declared as dynamic. It is already virtual in IPortableDeviceEventCallback.
Second, you are not doing any error handling on IPortableDeviceValues.GetStringValue(), or freeing the memory it returns. It should look more like this:
function TPortableDeviceEventsCallback.OnEvent(const pEventParameters: IPortableDeviceValues): HResult;
var
Hr: HResult;
ObjName: PWideChar;
begin
Hr := pEventParameters.GetStringValue(WPD_EVENT_PARAMETER_OBJECT_NAME, ObjName);
case Hr of
S_OK: begin
try
Log('Object Name: ' + String(ObjName));
finally
CoTaskMemFree(ObjName);
end;
end;
DISP_E_TYPEMISMATCH: begin
Log('Object Name is not a string!');
end;
$80070490: // HRESULT_FROM_WIN32(ERROR_NOT_FOUND)
begin
Log('Object Name is not found!');
end;
else
// some other error
Log('Error getting Object Name: $' + IntToHex(Hr, 8));
end;
Result := S_OK;
end;
Third, you are not looking at the value of the WPD_EVENT_PARAMETER_EVENT_ID parameter (which is the only required parameter) to know what event you are receiving in order to know what parameters are available with it. Different events have different parameter values.
Try enumerating the available values to see what you are actually receiving in each event:
function TPortableDeviceEventsCallback.OnEvent(const pEventParameters: IPortableDeviceValues): HResult;
var
Hr: HResult;
Count, I: DWORD;
Key: PROPERTYKEY;
Value: PROPVARIANT;
begin
Log('Event received');
Hr := pEventParameters.GetCount(Count);
if FAILED(Hr) or (Count = 0) then Exit;
Log('Param count: ' + IntToStr(Count));
for I := 0 to Count-1 do
begin
Hr := pEventParameters.GetAt(I, Key, Value);
if FAILED(Hr) then
begin
Log('Cant get parameter at index ' + IntToStr(I));
Continue;
end;
try
Log('Param Key: ' + GuidToString(Key.fmtid) + ', Value type: $' + IntToHex(Value.vt, 4));
// log content of Value based on its particular data type as needed...
finally
PropVariantClear(Value);
end;
end;
Result := S_OK;
end;

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.

How to make files really hidden in a directory?

I downloaded a program yesterday, it is for encryption and security. I won't name it here unless someone asks me to but it has a feature to make files inside a specified folder completely invisible.
I have Hidden Files and Folders - Selected and also Hide protected operating system files - Unselected yet the files are gone completely from view and don't show up in a search either. I copied the folder over from VMware Workstation to my main machine and still the files are super hidden! There are zero files in the folder according to Windows.
How is this voodoo magick possible? I want to emulate this using Delphi in my own encryption program. I have not found any way on here and via Google that suggests how it is possible but the actual programs help file says they are still in the folder but do not register with most normal Windows software that process files.
This is one of those questions where I can not give any code to show what I have tried, but rather open to suggestions of what I can try or maybe someone here knows exactly how it is done?
Since less informa
One possebility would be using alternative filestreams on NTFS, which can be added to files and folders. You can just try this by typing "notepad C:\temp:hidden1.txt" at the comandline, new filestream will be created if you aswer with yes. After saving you can reopen it exact the same way. This can also be done from delphi (loading/saving). Will only work if NTFS is used.
I don't know if this method is used in described case, finding ADS can be done with following code:
unit u_ListADS;
// 20120928 by Thomas Wassermann
// www.devworx.de
interface
uses
Windows, Messages, SysUtils, Variants, Classes, StrUtils;
Procedure GetADS(List: TStrings; const Path, WildCard: String; Recursiv: Boolean = false);
function NtQueryInformationFile(FileHandle: Cardinal; IoStatusBlock: Pointer; FileInformation: Pointer; FileInformationLength: Cardinal;
FileInformationClass: Cardinal): Cardinal; stdcall; external 'ntdll.dll';
implementation
type
_FILE_STREAM_INFORMATION = record
NextEntryOffset: Cardinal;
StreamNameLength: Cardinal;
StreamSize: int64;
StreamAllocationSize: int64;
StreamName: array [0 .. MAX_PATH] of WideChar;
end;
PFILE_STREAM_INFORMATION = ^_FILE_STREAM_INFORMATION;
function GetStreams(aFilename: String): TStringList;
var
FileHandle: Integer;
FileName: array [0 .. MAX_PATH] of WideChar;
StreamName: String;
InfoBlock: _FILE_STREAM_INFORMATION;
StatusBlock: record Status: Cardinal;
Information: PDWORD;
end;
Procedure Analyze;
begin
CopyMemory(#FileName, #InfoBlock.StreamName, InfoBlock.StreamNameLength);
StreamName := Copy(Filename, 1, PosEx(':', Filename, 2) - 1);
if StreamName <> ':' then Result.Add(StreamName);
end;
begin
Result := TStringList.Create;
FileHandle := FileOpen(aFilename, GENERIC_READ);
NtQueryInformationFile(FileHandle, #StatusBlock, #InfoBlock, SizeOf(InfoBlock), 22);
FileClose(FileHandle);
if InfoBlock.StreamNameLength <> 0 then
Repeat
if (InfoBlock.NextEntryOffset <> 0) then
begin
InfoBlock := PFILE_STREAM_INFORMATION(PByte(#InfoBlock) + InfoBlock.NextEntryOffset)^;
Analyze;
end;
until InfoBlock.NextEntryOffset = 0
end;
Procedure GetADS(List: TStrings; const Path, WildCard: String; Recursiv: Boolean = false);
Var
SR: SysUtils.TSearchRec;
RES: Integer;
SP: String;
StreamList: TStringList;
i: Integer;
begin
if length(Path) = 0 then
exit;
if length(WildCard) = 0 then
exit;
SP := IncludeTrailingBackSlash(Path) + WildCard;
RES := FindFirst(IncludeTrailingBackSlash(Path) + '*.*', faDirectory, SR);
While RES = 0 Do
Begin
If (SR.attr And faDirectory) <> 0 Then
If SR.Name[1] <> '.' Then
if Recursiv then
GetADS(List, IncludeTrailingBackSlash(Path) + SR.Name, WildCard, Recursiv);
RES := FindNext(SR);
End;
SysUtils.FindClose(SR);
RES := FindFirst(SP, $27, SR);
While RES = 0 Do
Begin
StreamList := GetStreams(IncludeTrailingBackSlash(Path) + SR.Name);
for i := 0 to StreamList.Count - 1 do
List.Add(IncludeTrailingBackSlash(Path) + SR.Name + StreamList[i]);
StreamList.Free;
RES := FindNext(SR);
End;
SysUtils.FindClose(SR);
end;
end.
Call could be e.g.
GetADS(Listbox1.Items,Directory.Text, WildCards.Text,rekursiv.checked);

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