The information on the version Exe-file I receive by means of VerQueryValue. Is there an inverse function (WinApi or Delphi) which can register (establish or change) such information?
Here, for example, there is a program which is able to do so. How may it work (http://www.angusj.com/resourcehacker)?
The version information is stored via resources; to edit that you simply need to edit that resource. Here is a unit I found that can clone an existing file version information and attach it to another file. It's very easy to do what you want starting from this code (it's coded by a friend of mine and is available public):
unit cloneinfo;
interface
uses Windows, SysUtils;
type
LANGANDCODEPAGE = record
wLanguage: Word;
wCodePage: Word;
end;
procedure clone(sFile,output:string);
implementation
procedure clone(sFile,output:string);
var
dwHandle, cbTranslate: cardinal;
sizeVers: DWord;
lpData, langData: Pointer;
lpTranslate: ^LANGANDCODEPAGE;
hRes : THandle;
begin
sizeVers := GetFileVersionInfoSize(PChar(sFile), dwHandle);
If sizeVers = 0 then
exit;
GetMem(lpData, sizeVers);
try
ZeroMemory(lpData, sizeVers);
GetFileVersionInfo (PChar(sFile), 0, sizeVers, lpData);
If not VerQueryValue (lpData, '\VarFileInfo\Translation', langData, cbTranslate) then
exit;
hRes := BeginUpdateResource(pchar(output), FALSE);
//For i := 0 to (cbTranslate div sizeof(LANGANDCODEPAGE)) do
//begin
lpTranslate := Pointer(Integer(langData) + sizeof(LANGANDCODEPAGE));
UpdateResource(hRes, RT_VERSION, MAKEINTRESOURCE(VS_VERSION_INFO), lpTranslate^.wLanguage,lpData, sizeVers);
//end;
EndUpdateResource(hRes, FALSE);
finally
FreeMem(lpData);
end;
end;
end.
Related
I have a simple Delphi application that creates a desktop shortcut for a URL. It makes a two-line text file with a .url filename extension in the user's Desktop folder:
[InternetShortcut]
URL=http://127.0.0.1/admin
That works fine. When I need to update the file with a new URL, I overwrite the old file. But Windows will not recognize the change until I restart Explorer or reboot. So I learned about SHChangeNotify() and called it after overwriting the file:
SHChangeNotify(SHCNE_UPDATEITEM, SHCNF_PATH or SHCNF_FLUSH, PChar(Path), nil);
But it has no effect:
I tried with and without the SHCNF_FLUSH flag;
also the SHCNF_FLUSHNOWAIT flag makes no difference.
I also tried deleting the file first and then using the SHCNE_DELETE event and then re-creating the file. That doesn't work either, it just keeps using the old URL.
How do I force Explorer to reload the URL from the file without a restart?
While the file's content can be treated like any INI file I yet have not found a direct way to control manipulations to it:
When creating a file its content is read as expected: the system's default application for the URL='s protocol is started (i.e. for http it is most likely the internet browser).
Modifying the file per file systems has no effect - either MSIE itself maintains a cache or the COM's magic.
Indirectly manipulation is possible in the following way:
Empty the file's existing content. Why? Because the later step will just add the same INI section with an URL= value again, but the first section's URL= value remains the one that is taken into account.
Access the file per COM and change its properties. Sadly this writes more into the file - in my case the outcome/file's content was:
[{000214A0-0000-0000-C000-000000000046}]
Prop3=19,2
[InternetShortcut]
URL=http://127.0.0.1/index.php
IDList=
However, it "works" as in: the change (speak: a different URL) is recognized. Putting it all together my following code for Delphi 7 on Windows 7 should also work for you - just call the function:
uses
ShlObj, ActiveX, ComObj;
const
SID_IUniformResourceLocatorA= '{FBF23B80-E3F0-101B-8488-00AA003E56F8}';
SID_IUniformResourceLocatorW= '{CABB0DA0-DA57-11CF-9974-0020AFD79762}';
SID_InternetShortcut= '{FBF23B40-E3F0-101B-8488-00AA003E56F8}';
type
PUrlInvokeCommandInfoA= ^TUrlInvokeCommandInfoA;
TUrlInvokeCommandInfoA= record
dwcbSize,
dwFlags: DWORD; // Bit field of IURL_INVOKECOMMAND_FLAGS
hwndParent: HWND; // Parent window. Valid only if IURL_INVOKECOMMAND_FL_ALLOW_UI is set.
pcszVerb: LPCSTR; // Verb to invoke. Ignored if IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB is set.
end;
PUrlInvokeCommandInfoW= ^TUrlInvokeCommandInfoW;
TUrlInvokeCommandInfoW= record
dwcbSize,
dwFlags: DWORD;
hwndParent: HWND;
pcszVerb: LPCWSTR;
end;
IUniformResourceLocatorA= interface( IUnknown )
[SID_IUniformResourceLocatorA]
function SetURL( pcszURL: LPCSTR; dwInFlags: DWORD ): HRESULT; stdcall;
function GetURL( ppszURL: LPSTR ): HRESULT; stdcall;
function InvokeCommand( purlici: PUrlInvokeCommandInfoA ): HRESULT; stdcall;
end;
IUniformResourceLocatorW= interface( IUnknown )
[SID_IUniformResourceLocatorW]
function SetURL( pcszURL: LPCWSTR; dwInFlags: DWORD ): HRESULT; stdcall;
function GetURL( ppszURL: LPWSTR ): HRESULT; stdcall;
function InvokeCommand(purlici: PUrlInvokeCommandInfoW ): HRESULT; stdcall;
end;
function SetURL( sFile, sUrl: Widestring ): Integer;
const
CLSID_InternetShortCut: TGUID= SID_InternetShortcut;
var
oUrl: IUniformResourceLocatorW;
oFile: IPersistFile;
hFile: THandle;
begin
// First, the existing file's content should be emptied
hFile:= CreateFileW( PWideChar(sFile), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0 );
if hFile= INVALID_HANDLE_VALUE then begin
result:= 1; // File might not exist, sharing violation, etc.
exit;
end;
// Initial file pointer is at position 0
if not SetEndOfFile( hFile ) then begin
result:= 2; // Missing permissions, etc.
CloseHandle( hFile );
exit;
end;
// Gracefully end accessing the file
if not CloseHandle( hFile ) then begin
result:= 3; // File system crashed, etc.
exit;
end;
// Using COM to access properties
result:= 0;
try
oUrl:= CreateComObject( CLSID_InternetShortCut ) as IUniformResourceLocatorW;
except
result:= 4; // CLSID unsupported, COM not available, etc.
end;
if result<> 0 then exit;
// Opening the file again
oFile:= oUrl as IPersistFile;
if oFile.Load( PWideChar(sFile), STGM_READWRITE )<> S_OK then begin
result:= 5; // Sharing violations, access permissions, etc.
exit;
end;
// Set the property as per interface - only saving the file is not enough
if oUrl.SetURL( PWideChar(sUrl), 0 )<> S_OK then begin
result:= 6;
exit;
end;
// Storing the file's new content - setting only the property is not enough
if oFile.Save( PWideChar(sFile), TRUE )<> S_OK then begin
result:= 7;
exit;
end;
// Success!
result:= 0;
end;
As per my desktop firewall the executing process modifies the memory of explorer.exe upon IPersistFile.Save() - after that executing the URL file should reflect its new content, while any attempt before that should still act upon the old file's content.
function GetFileIcon(const filename:string): HICON;
var
shfi: TShFileInfo;
begin
try
FillChar(shfi, SizeOf(TShFileInfo), 0);
ShGetFileInfo(PChar(filename), 0, shfi, SizeOf(TShFileInfo), SHGFI_ICON or SHGFI_LARGEICON);
Result := shfi.hIcon;
except
Result := 0;
end;
end;
Using delphi xe2, on win 7 64bits, this function will often return 0 when called inside a Tthread, but is always working fine when called from main thread. It looks like a shell initialization problem, because after a while it will work in the Thread as well.
I found a similar question in stack overflow (Calling SHGetFileInfo in thread to avoid UI freeze) but it is for c++ language so I did not sort it out.
Update: It seems ShGetFileInfo is not threadsafe. When there are multiple threads calling it simultaneously, it fails. See David
Hefferman's answer below. Also using CoInitializeEx instead of Coinitialize does not help with multiple threads. You have to serilize access using a TCriticalSection.
From the documentation:
You must initialize Component Object Model (COM) with CoInitialize or OleInitialize prior to calling SHGetFileInfo.
In a GUI app, the COM is initialized in the main thread. But from other threads that does not happen automatically. You will need to do it explicitly.
Beyond that you are not handling errors correctly. Remember that Windows API functions do not raise exceptions. So your exception handler is pointless and should be removed. Instead you need to check the return value of your call to SHGetFileInfo, as described in the documentation.
Beyond that your code works, as this program demonstrates:
{$APPTYPE CONSOLE}
uses
Classes, Windows, ActiveX, ShellAPI;
var
hThread: THandle;
ThreadId: Cardinal;
function ThreadFunc(Parameter: Pointer): Integer;
var
shfi: TSHFileInfo;
begin
CoInitialize(nil);
Try
if ShGetFileInfo('C:\windows\explorer.exe', 0, shfi, SizeOf(shfi), SHGFI_ICON or SHGFI_LARGEICON)=0 then
begin
Writeln('ShGetFileInfo Failed');
Result := 1;
exit;
end;
Writeln(shfi.hIcon);
Finally
CoUninitialize;
End;
Result := 0;
end;
begin
hThread := BeginThread(nil, 0, ThreadFunc, nil, 0, ThreadId);
WaitForSingleObject(hThread, INFINITE);
CloseHandle(hThread);
Readln;
end.
I expect that any failure you observe is actually related to the particular file that you are trying to inspect.
Update: It seems ShGetFileInfo is not threadsafe. When there are multiple threads calling it simultaneously, it fails. I believe that you will need to serialize the calls to ShGetFileInfo with a lock. For instance, TCriticalSection.
The following program, based on the SSCCE you provided in the comments, demonstrates this:
{$APPTYPE CONSOLE}
uses
SysUtils,
Classes,
SyncObjs,
Windows,
ActiveX,
ShellAPI;
var
hThreads: TWOHandleArray;
ThreadId: Cardinal;
Lock: TCriticalSection;
function ThreadFunc(Parameter: Pointer): Integer;
var
shfi: TSHFileInfo;
randomnumber: integer;
fname: string;
begin
CoInitialize(nil);
Try
fname := 'c:\desktop\file'+IntToStr(Integer(Parameter))+'.exe';
Lock.Acquire;
try
if ShGetFileInfo(pchar(fname), 0, shfi, SizeOf(shfi), SHGFI_ICON or SHGFI_LARGEICON)=0 then
begin
Writeln('ShGetFileInfo Failed');
Result := 1;
exit;
end;
Writeln(shfi.hIcon);
finally
Lock.Release;
end;
Finally
CoUninitialize;
End;
Result := 0;
end;
var
i: integer;
begin
Lock := TCriticalSection.Create;
for i := 0 to 9 do
hThreads[i] := BeginThread(nil, 0, ThreadFunc, Pointer(i), 0, ThreadId);
WaitForMultipleObjects(10, #hThreads,true, INFINITE);
Readln;
end.
Remove the critical section, and the calls to ShGetFileInfo succeed, but return 0 for the icon handle. With the critical section, valid icon handles are returned.
I have been writing a program that ideally will run on a server in the background without ever closing - therefore it is important that any memory leaks are non existent. My program involves retrieving live session information using the Windows Terminal Services API (wtsapi32.dll) and since the information must be live the function is being run every few seconds, I have found that calling the WTSEnumerateSessionsEx function has lead to a fairly sizable memory leak. It seems the call to WTSFreeMemoryEx as instructed in the MSDN documentation seems to have no impact yet I receive no error messages from either call.
To summarize: the problem is not in execution of WTSEnumerateSessionsEx since valid data is returned; the memory is simply not being freed and this leads to problems when left to run for extended periods of time.
Currently the short-term solution has been to restart the process when used memory exceeds a threshold however this doesn't seem to be a satisfactory solution and rectifying this leak would be most desirable.
The enumeration types have been taken directly from the Microsoft MSDN documentation.
Attached is the relevant source file.
unit WtsAPI32;
interface
uses Windows, Classes, Dialogs, SysUtils, StrUtils;
const
WTS_CURRENT_SERVER_HANDLE = 0;
type
WTS_CONNECTSTATE_CLASS = (WTSActive, WTSConnected, WTSConnectQuery,
WTSShadow, WTSDisconnected, WTSIdle, WTSListen, WTSReset, WTSDown,
WTSInit);
type
WTS_TYPE_CLASS = (WTSTypeProcessInfoLevel0, WTSTypeProcessInfoLevel1,
WTSTypeSessionInfoLevel1);
type
WTS_SESSION_INFO_1 = record
ExecEnvId: DWord;
State: WTS_CONNECTSTATE_CLASS;
SessionId: DWord;
pSessionName: LPtStr;
pHostName: LPtStr;
pUserName: LPtStr;
pDomainName: LPtStr;
pFarmName: LPtStr;
end;
type
TSessionInfoEx = record
ExecEnvId: DWord;
State: WTS_CONNECTSTATE_CLASS;
SessionId: DWord;
pSessionName: string;
pHostName: string;
pUserName: string;
pDomainName: string;
pFarmName: string;
end;
TSessions = array of TSessionInfoEx;
function FreeMemoryEx(WTSTypeClass: WTS_TYPE_CLASS; pMemory: Pointer;
NumberOfEntries: Integer): BOOL; stdcall;
external 'wtsapi32.dll' name 'WTSFreeMemoryExW';
function FreeMemory(pMemory: Pointer): DWord; stdcall;
external 'wtsapi32.dll' name 'WTSFreeMemory';
function EnumerateSessionsEx(hServer: THandle; var pLevel: DWord;
Filter: DWord; var ppSessionInfo: Pointer; var pCount: DWord): BOOL;
stdcall; external 'wtsapi32.dll' name 'WTSEnumerateSessionsExW';
function EnumerateSessions(var Sessions: TSessions): Boolean;
implementation
function EnumerateSessions(var Sessions: TSessions): Boolean;
type
TSessionInfoExArr = array[0..2000 div SizeOf(WTS_SESSION_INFO_1)] of WTS_SESSION_INFO_1;
var
ppSessionInfo: Pointer;
pCount: DWord;
hServer: THandle;
level: DWord;
i: Integer;
ErrCode: Integer;
Return: DWord;
begin
pCount := 0;
level := 1;
hServer := WTS_CURRENT_SERVER_HANDLE;
ppSessionInfo := NIL;
if not EnumerateSessionsEx(hServer, level, 0, ppSessionInfo, pCount) then
begin
ErrCode := GetLastError;
ShowMessage('Error in EnumerateSessionsEx - Code: ' + IntToStr(ErrCode)
+ ' Message: ' + SysErrorMessage(ErrCode));
en
else
begin
SetLength(Sessions, pCount);
for i := 0 to pCount - 1 do
begin
Sessions[i].ExecEnvId := TSessionInfoExArr(ppSessionInfo^)[i].ExecEnvId;
Sessions[i].State := TSessionInfoExArr(ppSessionInfo^)[i].State;
Sessions[i].SessionId := TSessionInfoExArr(ppSessionInfo^)[i].SessionId;
Sessions[i].pSessionName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pSessionName);
Sessions[i].pHostName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pHostName);
Sessions[i].pUserName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pUserName);
Sessions[i].pDomainName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pDomainName);
Sessions[i].pFarmName := WideCharToString
(TSessionInfoExArr(ppSessionInfo^)[i].pFarmName);
end;
if not FreeBufferEx(WTSTypeSessionInfoLevel1, ppSessionInfo, pCount);
begin
ErrCode := GetLastError;
ShowMessage('Error in EnumerateSessionsEx - Code: ' + IntToStr(ErrCode)
+ ' Message: ' + SysErrorMessage(ErrCode));
end;
ppSessionInfo := nil;
end;
end;
end.
Here's is a minimal SSCCE that demonstrates the issue. When this program executes, it exhausts available memory in short time.
program SO17839270;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
const
WTS_CURRENT_SERVER_HANDLE = 0;
type
WTS_TYPE_CLASS = (WTSTypeProcessInfoLevel0, WTSTypeProcessInfoLevel1,
WTSTypeSessionInfoLevel1);
function WTSEnumerateSessionsEx(hServer: THandle; var pLevel: DWORD;
Filter: DWORD; var ppSessionInfo: Pointer; var pCount: DWORD): BOOL; stdcall;
external 'wtsapi32.dll' name 'WTSEnumerateSessionsExW';
function WTSFreeMemoryEx(WTSTypeClass: WTS_TYPE_CLASS; pMemory: Pointer;
NumberOfEntries: Integer): BOOL; stdcall;
external 'wtsapi32.dll' name 'WTSFreeMemoryExW';
procedure EnumerateSessionsEx;
var
ppSessionInfo: Pointer;
pCount: DWORD;
level: DWORD;
begin
level := 1;
if not WTSEnumerateSessionsEx(WTS_CURRENT_SERVER_HANDLE, level, 0,
ppSessionInfo, pCount) then
RaiseLastOSError;
if not WTSFreeMemoryEx(WTSTypeSessionInfoLevel1, ppSessionInfo, pCount) then
RaiseLastOSError;
end;
begin
while True do
EnumerateSessionsEx;
end.
To summarise the comment trail, I think that there is a fault in the WTS library code, that afflicts the WTSEnumerateSessionsEx and WTSFreeMemoryEx functions. The SSCCE that I added to the question gives a pretty clear demonstration of that.
So, your options to work around the fault would appear to be:
Only call WTSEnumerateSessionsEx when you get notified that a session is created or destroyed. That would minimise the number of calls you make. You'd still be left with a leak, but I suspect that it would take a very long time before you encountered problems.
Switch to WTSEnumerateSessions and then call WTSQuerySessionInformation to obtain any extra information that you need. From my trials, WTSEnumerateSessions would appear not to be afflicted by the same problem as WTSEnumerateSessionsEx.
I created the same sample in MSVC:
#include <Windows.h>
#include <WtsApi32.h>
#pragma comment(lib, "wtsapi32")
int _tmain(int argc, _TCHAR* argv[])
{
DWORD Level = 1;
PWTS_SESSION_INFO_1 pSessionInfo;
DWORD Count = 0;
BOOL bRes;
while (WTSEnumerateSessionsEx(WTS_CURRENT_SERVER_HANDLE, &Level, 0, &pSessionInfo, &Count))
{
if (!WTSFreeMemoryEx(WTSTypeSessionInfoLevel1, pSessionInfo, Count))
{
break;
}
}
return 0;
}
I am observing the same behaviour in Task Manager and even though Task Manager is not a tool to track memory leaks this behaviour is clearly a leak and it seems like a bug.
It happens both in x86 and x64 build (x64 uses the x64 version of WtsApi32.dll).
When you have finished using the array, free it by calling the WTSFreeMemoryEx function. You should also set the pointer to NULL.
(C) https://learn.microsoft.com/en-us/windows/desktop/api/wtsapi32/nf-wtsapi32-wtsenumeratesessionsexa
Process Hacker has a process manager in C.
When you double-click in process manager on a process e.g. Explorer
You see a lot of info, including:
Topics related to the process. PDD, Cycles Delta Start, Address, priority.
Well I tried to do something similar in Delphi, but I get only the TID and priority ...
I can not put the info Start Address as follows: "msiltcfg.dll 0x258!" or can only return
00630EFA.
The (Original) Application Process Hacker show the information in the image below:
How do I solve this? based on the code example below.
procedure TForm1.Button7Click (Sender: TObject);
var
tbi: THREAD_BASIC_INFORMATION;
hThreadSnap, Process, hThread, ThreadInfo: THandle;
te32: tagTHREADENTRY32;
me32: MODULEENTRY32;
th32: THREADENTRY32;
dwPID: DWORD;
startaddr: Pointer;
Status: LongInt;
Error: DWORD;
modname: String;
hToken: DWORD;
TKP: TOKEN_PRIVILEGES;
otkp: TOKEN_PRIVILEGES;
dwLen: dword;
begin
hThreadSnap: = CreateToolhelp32Snapshot (TH32CS_SNAPTHREAD, 0);
if hThreadSnap = INVALID_HANDLE_VALUE then
Exit;
try
dwPID: = GetProcessID (Trim (Edit1.Text));
te32.dwSize: = SizeOf (THREADENTRY32);
me32.dwSize: = SizeOf (MODULEENTRY32);
ListBox1.Items.Clear;
ListBox2.Items.Clear;
if not Thread32First (hThreadSnap, te32) then
Exit;
repeat
if te32.th32OwnerProcessID = dwPID then
begin
hThread: = OpenThread (THREAD_ALL_ACCESS,
False, te32.th32ThreadID);
status: = ZwQueryInformationThread (hThread,
9,
ThreadQuerySetWin32StartAddress {}
#Startaddr,
SizeOf (startaddr)
# DwLen);
listbox1.Items.AddObject (Format ('StartAddress:% p'
[Startaddr]) + 'ID:' + IntToStr(te32.th32ThreadID), TObject (hThread));
if hThread <> 0 then
CloseHandle (hThread);
end;
Until not Thread32Next (hThreadSnap, te32);
finally
CloseHandle (hThreadSnap);
end;
end;
Take a look at our logging class in the Open Source SynCommons.pas unit: you can trace the stack of any method into the log file. If the .map (or its compressed .mab equivalence) is available, the line number will be displayed.
I'm working on a log viewer able to add source code lines during viewing, from a save .map/.mab file.
It's now used by the unit testing classes, so that any failure will create an entry in the log with the source line, and stack trace:
C:\Dev\lib\SQLite3\exe\TestSQL3.exe 0.0.0.0 (2011-04-13)
Host=Laptop User=MyName CPU=2*0-15-1027 OS=2.3=5.1.2600 Wow64=0 Freq=3579545
TSynLogTest 1.13 2011-04-13 05:40:25
20110413 05402559 fail TTestLowLevelCommon(00B31D70) Low level common: TDynArray "" stack trace 0002FE0B SynCommons.TDynArray.Init (15148) 00036736 SynCommons.Test64K (18206) 0003682F SynCommons.TTestLowLevelCommon._TDynArray (18214) 000E9C94 TestSQL3 (163)
The difference between a test suit without logging (TSynTests) and a test suit with logging (TSynTestsLogged) is only this:
procedure TSynTestsLogged.Failed(const msg: string; aTest: TSynTestCase);
begin
inherited;
with TestCase[fCurrentMethod] do begin
fLogFile.Log(sllFail,'%: % "%"',
[Ident,TestName[fCurrentMethodIndex],msg],aTest);
end; {with}
end;
The sllFail level if used here, but you can use any available level.
Basically I have a TcxGrid which will be listing various files names and I'd like to give further details based on the file extension, specifically it's description (e.g. for .PDF it's "Adobe Acrobat Document") and it's related icon.
I notice there is a very similar question already but it's C# related and I'd like something Delphi based.
Suggestions on where to look for this kind of info would be good and if there is a class similar to the one mentioned in the C# post above (obviously in Delphi) that would be great.
Thanks to Rob Kennedy for pointing me in the direction of ShGetFileInfo. I then Googled on that and found these two examples - Delphi 3000, Torry's. From that I wrote the following class to do what I needed.
Also, just as I was finishing up Bill Miller's answer gave me the final bit of help I needed. Originally I was passing full file names through to ShGetFileInfo, which wasn't ideally what I wanted. The tweak suggested of passing "*.EXT" was great.
The class could do with more work but it does what I need. It seems to handle file extensions that have no details associated either.
Finally, in what I'm using I've switched it to using a TcxImageList instead of a TImageList, since I was having problems with black borders appearing on the icons, because it was a quick fix.
unit FileAssociationDetails;
{
Created : 2009-05-07
Description : Class to get file type description and icons.
* Extensions and Descriptions are held in a TStringLists.
* Icons are stored in a TImageList.
Assumption is all lists are in same order.
}
interface
uses Classes, Controls;
type
TFileAssociationDetails = class(TObject)
private
FImages : TImageList;
FExtensions : TStringList;
FDescriptions : TStringList;
public
constructor Create;
destructor Destroy; override;
procedure AddFile(FileName : string);
procedure AddExtension(Extension : string);
procedure Clear;
procedure GetFileIconsAndDescriptions;
property Images : TImageList read FImages;
property Extensions : TStringList read FExtensions;
property Descriptions : TStringList read FDescriptions;
end;
implementation
uses SysUtils, ShellAPI, Graphics, Windows;
{ TFileAssociationDetails }
constructor TFileAssociationDetails.Create;
begin
try
inherited;
FExtensions := TStringList.Create;
FExtensions.Sorted := true;
FDescriptions := TStringList.Create;
FImages := TImageList.Create(nil);
except
end;
end;
destructor TFileAssociationDetails.Destroy;
begin
try
FExtensions.Free;
FDescriptions.Free;
FImages.Free;
finally
inherited;
end;
end;
procedure TFileAssociationDetails.AddFile(FileName: string);
begin
AddExtension(ExtractFileExt(FileName));
end;
procedure TFileAssociationDetails.AddExtension(Extension : string);
begin
Extension := UpperCase(Extension);
if (Trim(Extension) <> '') and
(FExtensions.IndexOf(Extension) = -1) then
FExtensions.Add(Extension);
end;
procedure TFileAssociationDetails.Clear;
begin
FExtensions.Clear;
end;
procedure TFileAssociationDetails.GetFileIconsAndDescriptions;
var
Icon: TIcon;
iCount : integer;
Extension : string;
FileInfo : SHFILEINFO;
begin
FImages.Clear;
FDescriptions.Clear;
Icon := TIcon.Create;
try
// Loop through all stored extensions and retrieve relevant info
for iCount := 0 to FExtensions.Count - 1 do
begin
Extension := '*' + FExtensions.Strings[iCount];
// Get description type
SHGetFileInfo(PChar(Extension),
FILE_ATTRIBUTE_NORMAL,
FileInfo,
SizeOf(FileInfo),
SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES
);
FDescriptions.Add(FileInfo.szTypeName);
// Get icon and copy into ImageList
SHGetFileInfo(PChar(Extension),
FILE_ATTRIBUTE_NORMAL,
FileInfo,
SizeOf(FileInfo),
SHGFI_ICON or SHGFI_SMALLICON or
SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES
);
Icon.Handle := FileInfo.hIcon;
FImages.AddIcon(Icon);
end;
finally
Icon.Free;
end;
end;
end.
Also here is an example test app using it, it's very simple, just a form with a TPageControl on it. My actual use was not for this, but for with a Developer Express TcxImageComboxBox in a TcxGrid.
unit Main;
{
Created : 2009-05-07
Description : Test app for TFileAssociationDetails.
}
interface
uses
Windows, Forms, FileAssociationDetails, Classes, Controls, ComCtrls;
type
TfmTest = class(TForm)
PageControl1: TPageControl;
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
FFileDetails : TFileAssociationDetails;
public
{ Public declarations }
end;
var
fmTest: TfmTest;
implementation
{$R *.dfm}
procedure TfmTest.FormShow(Sender: TObject);
var
iCount : integer;
NewTab : TTabSheet;
begin
FFileDetails := TFileAssociationDetails.Create;
FFileDetails.AddFile('C:\Documents and Settings\...\Test.XLS');
FFileDetails.AddExtension('.zip');
FFileDetails.AddExtension('.pdf');
FFileDetails.AddExtension('.pas');
FFileDetails.AddExtension('.XML');
FFileDetails.AddExtension('.poo');
FFileDetails.GetFileIconsAndDescriptions;
PageControl1.Images := FFileDetails.Images;
for iCount := 0 to FFileDetails.Descriptions.Count - 1 do
begin
NewTab := TTabSheet.Create(PageControl1);
NewTab.PageControl := PageControl1;
NewTab.Caption := FFileDetails.Descriptions.Strings[iCount];
NewTab.ImageIndex := iCount;
end;
end;
procedure TfmTest.FormClose(Sender: TObject; var Action: TCloseAction);
begin
PageControl1.Images := nil;
FFileDetails.Free;
end;
end.
Thanks everyone for your answers!
Call ShGetFileInfo. It can tell you the description (the "type name," in that function's vocabulary), and it can give you an icon handle, or a handle to the system image list, where the icon resides, or the path to the module that holds the image resource. That function can do lots of different things, so make sure to read the documentation carefully.
MSDN says ShGetFileInfo "may be slow" and calls the IExtractIcon interface a "more flexible and efficient" alternative. But the sequence it recommends is to use an IShellFolder interface, then call GetUIObjectOf to get the file's IExtractIcon interface, and then call GetIconLocation and Extract on it to retrieve the icon's handle.
For all I know, that's exactly what ShGetFileInfo does anyway, but it's much more cumbersome, and after you've done all that, you still wouldn't have the file's type description. Stick with ShGetFileInfo until speed and efficiency become a noticeable problem.
function GetGenericFileType( AExtension: string ): string;
{ Get file type for an extension }
var
AInfo: TSHFileInfo;
begin
SHGetFileInfo( PChar( AExtension ), FILE_ATTRIBUTE_NORMAL, AInfo, SizeOf( AInfo ),
SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES );
Result := AInfo.szTypeName;
end;
function GetGenericIconIndex( AExtension: string ): integer;
{ Get icon index for an extension type }
var
AInfo: TSHFileInfo;
begin
if SHGetFileInfo( PChar( AExtension ), FILE_ATTRIBUTE_NORMAL, AInfo, SizeOf( AInfo ),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES ) <> 0 then
Result := AInfo.iIcon
else
Result := -1;
end;
function GetGenericFileIcon( AExtension: string ): TIcon;
{ Get icon for an extension }
var
AInfo: TSHFileInfo;
AIcon: TIcon;
begin
if SHGetFileInfo( PChar( AExtension ), FILE_ATTRIBUTE_NORMAL, AInfo, SizeOf( AInfo ),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES ) <> 0 then
begin
AIcon := TIcon.Create;
try
AIcon.Handle := AInfo.hIcon;
Result := AIcon;
except
AIcon.Free;
raise;
end;
end
else
Result := nil;
end;
uses ShellAPI;
var
AExtension: string;
AFileType: string;
AListItem: TListItem;
AFileInfo: TSHFileInfo;
begin
// get the extensions file icon
AExtension := ExtractFileExt( FileName );
if SHGetFileInfo( PChar( '*' + AExtension ), FILE_ATTRIBUTE_NORMAL, AFileInfo, SizeOf
( AFileInfo ), SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_USEFILEATTRIBUTES ) <> 0 then
AIndex := AFileInfo.iIcon
else
AIndex := -1;
AListItem.ImageIndex := AIndex;
// get extensions file info
if SHGetFileInfo( PChar( '*' + AExtension ), FILE_ATTRIBUTE_NORMAL, Info, SizeOf( Info ),
SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES ) then
AFileType := AFileInfo.szTypeName;
end;
Not to sound glib, but Google is your friend. Here are a couple of the first results for "delphi associated icon":
http://www.delphi3000.com/articles/article_453.asp?SK=
http://www.jpgriffiths.com/tutorial/Snippets%5Cgetassociatedicon.html
The other method is to hunt down the extension in the registry under HKEY_CLASSES_ROOT, then follow the key in the default value (if available) and its default is the description. This second level is also where you can get the shell commands to open, or print the file type as well as the path to the default icon.
Here are a couple good examples of using ShGetFileInfo from bitwisemag.com:
http://www.bitwisemag.com/copy/delphi/lpad1.html
http://www.bitwisemag.com/copy/delphi/prog_groups2.html