How to get icon and description from file extension using Delphi? - windows

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

Related

Windows: Calling a WMI function using FreePascal -- Working example?

I am looking for sample code on how to call a WMI function. Does anyone has a working example in FreePascal, ideally including code on how to pass parameters to the function? Unfortunately, the "Delphi WMI code Creator" does not help me as the FreePascal code for creating a function does not work.
Just to be clear: This is not about querying WMI properties, but calling a function like Win32_Printer.AddPrinterConnection (just to name an example).
I found a piece of Delphi code that set up many of the standard objects in the same way as Drake Wu's C++ example did.
I was interested in that example because I'm interested in edids, so I fully translated said C++ article's solution to Delphi/FPC. It seems to work.
program wmiedidint2;
// based on https://theroadtodelphi.com/2011/04/21/accesing-the-wmi-from-delphi-and-fpc-via-com-without-late-binding-or-wbemscripting_tlb/
// modified to function as https://learn.microsoft.com/en-us/answers/questions/95631/wmi-c-application-problem-wmimonitordescriptormeth.html?childToView=96407#answer-96407
{$IFDEF FPC}
{$MODE DELPHI} {$H+}
{$ENDIF}
{$APPTYPE CONSOLE}
uses
Windows,
Variants,
SysUtils,
ActiveX,
JwaWbemCli;
const
RPC_C_AUTHN_LEVEL_DEFAULT = 0;
RPC_C_IMP_LEVEL_IMPERSONATE = 3;
RPC_C_AUTHN_WINNT = 10;
RPC_C_AUTHZ_NONE = 0;
RPC_C_AUTHN_LEVEL_CALL = 3;
EOAC_NONE = 0;
function GetBytesFromVariant(const V: Variant): TBytes;
// this function is a mess and only works for bytes. From SO
var
Len: Integer;
SafeArray: PVarArray;
begin
Len := 1+VarArrayHighBound(v, 1)-VarArrayLowBound(v, 1);
SetLength(Result, Len);
SafeArray := VarArrayAsPSafeArray(V);
Move(SafeArray.Data^, Pointer(Result)^, Length(result)*SizeOf(result[0]));
end;
procedure Test_IWbemServices_ExecQuery;
const
strLocale = '';
strUser = '';
strPassword = '';
strNetworkResource = 'root\WMI';
strAuthority = '';
WQL = 'SELECT * FROM WmiMonitorDescriptorMethods';
EDIDMethodname = 'WmiGetMonitorRawEEdidV1Block';
EDIDClassName = 'WmiMonitorDescriptorMethods';
var
FWbemLocator : IWbemLocator;
FWbemServices : IWbemServices;
FUnsecuredApartment : IUnsecuredApartment;
ppEnum : IEnumWbemClassObject;
apObjects : IWbemClassObject;
puReturned : ULONG;
pVal : OleVariant;
pType : Integer;
plFlavor : Integer;
Succeed : HRESULT;
varreturnvalue : olevariant;
varotherval : longint;
varcmd2 : tagVariant;
varcommand : olevariant; // tagVARIANT;
pOutParamsDefinition,
pInParamsDefinition,
pClass,
pClassInstance : IWbemClassObject;
callres : IWbemCallResult;
err : IErrorInfo;
aname,w2 : Widestring;
bytes : TBytes;
i : integer;
procedure teststatus(const msg:string);
begin
if Succeeded(succeed) then
writeln('Successs:',msg)
else
writeln('Fail:',msg)
end;
begin
// Set general COM security levels --------------------------
// Note: If you are using Windows 2000, you need to specify -
// the default authentication credentials for a user by using
// a SOLE_AUTHENTICATION_LIST structure in the pAuthList ----
// parameter of CoInitializeSecurity ------------------------
if Failed(CoInitializeSecurity(nil, -1, nil, nil, RPC_C_AUTHN_LEVEL_DEFAULT, RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE, nil)) then Exit;
// Obtain the initial locator to WMI -------------------------
if Succeeded(CoCreateInstance(CLSID_WbemLocator, nil, CLSCTX_INPROC_SERVER, IID_IWbemLocator, FWbemLocator)) then
try
// Connect to WMI through the IWbemLocator::ConnectServer method
if Succeeded(FWbemLocator.ConnectServer(strNetworkResource, strUser, strPassword, strLocale, WBEM_FLAG_CONNECT_USE_MAX_WAIT, strAuthority, nil, FWbemServices)) then
try
// Set security levels on the proxy -------------------------
if Failed(CoSetProxyBlanket(FWbemServices, RPC_C_AUTHN_WINNT, RPC_C_AUTHZ_NONE, nil, RPC_C_AUTHN_LEVEL_CALL, RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE)) then Exit;
if Succeeded(CoCreateInstance(CLSID_UnsecuredApartment, nil, CLSCTX_LOCAL_SERVER, IID_IUnsecuredApartment, FUnsecuredApartment)) then
try
// Use the IWbemServices pointer to make requests of WMI
//Succeed := FWbemServices.ExecQuery('WQL', WQL, WBEM_FLAG_FORWARD_ONLY OR WBEM_FLAG_RETURN_IMMEDIATELY, nil, ppEnum);
Succeed := FWbemServices.ExecQuery('WQL', WQL, WBEM_FLAG_FORWARD_ONLY, nil, ppEnum);
if Succeeded(Succeed) then
begin
Writeln('Running Wmi Query..Press Enter to exit');
// Get the data from the query
while (ppEnum.Next(WBEM_INFINITE, 1, apObjects, puReturned)=0) do
begin
succeed:= apObjects.Get('__PATH', 0, pVal, pType, plFlavor);
teststatus('get __PATH');
aname:=pval;
writeln('__PATH: ',aname);
succeed:=fwbemservices.GetObject(edidclassname,0,nil,pClass,callres);
teststatus('getobject');
succeed:=pClass.GetMethod(EDIDMethodname,0,pInParamsDefinition,pOutParamsDefinition);
teststatus('getmethod');
succeed:=pInParamsDefinition.SpawnInstance(0, pClassInstance);
teststatus('Spawn');
fillchar(varcmd2,sizeof(varcommand),#0);
varcmd2.vt:=VT_UI1;
varcmd2.bval:=0;
move(varcmd2,varcommand,sizeof(varcmd2));
succeed:= pClassInstance.Put('BlockId',0,#VarCommand,0);
teststatus('put blockid');
writeln('The BlockId is: ,',varCommand);
pOutParamsDefinition:=Nil;
callres:=nil;
w2:=EDIDMethodname;
succeed:= fwbemservices.ExecMethod(aname,w2,0,nil,pClassInstance,pOutParamsDefinition,callres);
if succeeded(succeed) then
begin
writeln('execute success!');
end;
succeed:= pOutParamsDefinition.Get('BlockType', 0, varreturnvalue,ptype,plFlavor);
if succeeded(succeed) then
begin
writeln('blocktype:',varreturnvalue);
varotherval:=varreturnvalue;
if varotherval=1 then
begin
succeed:= pOutParamsDefinition.Get('BlockContent', 0, varreturnvalue,ptype,plFlavor);
if succeeded(succeed) then
begin
bytes:=GetBytesFromVariant(varreturnvalue);
write('bytes:');
for i:=0 to length(bytes)-1 do
begin
write('$',inttohex(bytes[i],2),' ');
end;
writeln;
end;
end;
end;
end;
end
else
Writeln(Format('Error executing WQL sentence %x',[Succeed]));
finally
FUnsecuredApartment := nil;
end;
finally
FWbemServices := nil;
end;
finally
FWbemLocator := nil;
end;
end;
begin
// Initialize COM. ------------------------------------------
if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
try
Test_IWbemServices_ExecQuery;
finally
CoUninitialize();
end;
Readln;
end.
Note that the original (roadtodelphi) page also demonstrates event sinks
To call a WMI function, you need to:
Get the WMI class from IWbemServices.GetObject(ClassName)
Call IWbemClassObject.GetMethod(MethodName) to get the parameter information(In and Out Params) of the function
Pass the required value to the corresponding through a VARIANT: IWbemClassObject.Put("Name",VARIANT). Maybe just do this in pascal: objInParams.Properties_.Item('Name').Value := xxx;
Get an instance of the class and get its Object Path, and finally execute IWbemServices.ExecMethod(path,MethodName,objInParams,objOutParams).
There is also a C++ sample with WmiMonitorDescriptorMethods.WmiGetMonitorRawEEdidV1Block here, although I am not familiar with FreePascal, you could also follow the steps and convert it to FreePascal.

How to compile using Free Pascal

Guys I got a source from a friend that is suppose to help me learn RE a lot but I got error
Error:identifier not found "TResourceStream"
"Bool"
"TMemoryStream"
"TResourceInfo"
"try"
And
Fatal: Syntax error, ";" expected but " identifier MS" found
Please help I need to compile this.
Excuse me please I know nothing yet, about programming.
Here is the source
function EnumResourceNames(hModule: HMODULE; // EXE handle returned from LoadLibrary/Ex
lpType: PChar; // resource type (eg: RT_RCDATA)
lpEnumFunc: ENUMRESNAMEPROC; // callback function address
lParam: Integer // long integer (eg: pointer to an object)
): BOOL; stdcall;
function CB_EnumDfmNameProc(hModule: THandle; lpszType, lpszName: PChar;
lParam: Integer): Boolean; stdcall;
var
ms: TMemoryStream;
rs: TResourceStream;
Buffer: array of Byte;
begin
with TResourceInfo(lParam) do
begin
rs := TResourceStream.Create(TResourceInfo(lParam).Module,
lpszname, lpszType); // load resource in memory
try
ms := TMemoryStream.Create;
try
try
SetLength(Buffer, 4);
rs.Read(Buffer[0], SizeOf(Buffer)); // read the first 4 bytes
if string(Buffer) = 'TPF0' then // is it a DFM resource?
begin
rs.Seek(0, 0);
ObjectBinaryToText(rs, ms); // decode DFM
ms.Seek(0, 0);
AddDfm(StrPas(lpszName), ms); // add it to our own list
end;
except
raise;
end;
finally
ms.Free;
end;
finally
rs.free;
end;
end;
Result := True;
end;
procedure TResourceInfo.EnumDfmNames;
begin
if FModule > 0 then // if an EXE file has been loaded
EnumResourceNames(FModule, RT_RCDATA, // go and search RCDATA resources
#CB_EnumDfmNameProc, Integer(Self));
end;

How to get the shell image index of an object in the shell namespace?

I want to get the index in the system imagelist of an object in the shell namespace.
If this object was a file i could use SHGetFileInfo:
function GetFileImageIndex(const Filename: string): Integer;
var
sfi: TSHFileInfo;
begin
SHGetFileInfo(PChar(Filename), FILE_ATTRIBUTE_NORMAL, sfi, SizeOf(sfi),
SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX);
Result := sfi.iIcon;
end;
Except i don't have a file
The thing i have doesn't exist on the hard-drive as a folder or file, e.g.:
Control Panel
Homegroup
Network
But i still need to get the index in the system imagelist of the icon that corresponds to this thing. I started with SHGetFileInfo (as it supports pidls). But that fell apart. Then i tried using IExtractIcon, but that fell apart:
function GetObjectImageIndex(ParentFolder: IShellFolder; const ChildPidl: PItemIDList): Integer;
//var
// sfi: TSHFileInfo;
// extractIcon: IExtractIcon;
// iconFile: WideString;
// iconIndexInFile: Integer;
// flags: Cardinal;
begin
{
This function is the shell namespace equivalent of GetFileImageIndex helper function.
}
(*
Won't work (MSDN: "The PIDL must be a fully qualified PIDL. Relative PIDLs are not allowed.")
SHGetFileInfo(PWideChar(ChildPidl), FILE_ATTRIBUTE_NORMAL,
sfi, SizeOf(sfi),
SHGFI_PIDL or SHGFI_SYSICONINDEX);
*)
(*
Won't work. Doesn't return an index into the system imagelist
ParentFolder.GetUIObjectOf(0, 1, ChildPidl, IExtractIcon, nil, {out}extractIcon);
SetLength(iconFile, MAX_PATH);
extractIcon.GetIconLocation(0, PWideChar(iconFile), Length(iconFile), iconIndexInFile, {out}flags);
*)
Result := -1; //TODO: Figure out how to do it.
end;
Given an IShellFolder and a pidl in that folder, how do i get the icon in the system imagelist of that thing?
The simple answer is that you pass an absolute PIDL that identifies the object to SHGetFileInfo. You say you tried that without success, but this is the way to solve your problem.
You should go back to SHGetFileInfo and make it work. It looks like you got as far as having a relative PIDL and stopped. Make an absolute PIDL with ILCombine and you should be home.
If you don't have a PIDL for the containing IShellFolder then you'll want to read this topic: How to obtain the PIDL of an IShellFolder
function CreateGlobalChildIDList(AParentFolder: IShellFolder; const AChildIDList: PItemIDList): PItemIDList; forward;
function GetObjectImageIndex(AParentFolder: IShellFolder; const AChildIDList: PItemIDList): Integer;
var
ShellIcon: IShellIcon;
ChildIDList: PItemIDList;
FileInfo: TSHFileInfo;
begin
try
Result := -1;
try
OleCheck(AParentFolder.QueryInterface(IShellIcon, ShellIcon));
try
OleCheck(ShellIcon.GetIconOf(AChildIDList, GIL_FORSHELL, Result));
finally
ShellIcon := nil;
end;
except
Result := -1;
end;
if Result = -1 then
begin
ChildIDList := CreateGlobalChildIDList(AParentFolder, AChildIDList);
try
ZeroMemory(#FileInfo, SizeOf(FileInfo));
SHGetFileInfo(PWideChar(ChildIDList), FILE_ATTRIBUTE_NORMAL, FileInfo, SizeOf(FileInfo), SHGFI_PIDL or SHGFI_SYSICONINDEX);
Result := FileInfo.iIcon;
finally
CoTaskMemFree(ChildIDList);
end;
end;
except
Result := -1;
end;
end;
function CretaeGlobalChildIDList(AParentFolder: IShellFolder; const AChildIDList: PItemIDList): PItemIDList;
var
PersistFolder2: IPersistFolder2;
PersistIDList: IPersistIDList;
ParentIDList: PItemIDList;
begin
if Succeeded(AParentFolder.QueryInterface(IPersistFolder2, PersistFolder2)) then
try
OleCheck(PersistFolder2.GetCurFolder(ParentIDList));
try
Result := ILCombine(ParentIDList, AChildIDList);
finally
CoTaskMemFree(ParentIDList);
end;
finally
PersistFolder2 := nil;
end
else
if Succeeded(AParentFolder.QueryInterface(IPersistIDList, PersistIDList)) then
try
OleCheck(PersistIDList.GetIDList(ParentIDList));
try
Result := ILCombine(ParentIDList, AChildIDList);
finally
CoTaskMemFree(ParentIDList);
end;
finally
PersistIDList := nil;
end
else
raise Exception.Create('Cannot create PIDL');
end;

Set EXE VersionInfo

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.

Can overriding the CreateParams procedure allow me to still have full access to the WS_SYSMENU?

Complete source code can be found here:
http://www.eyeClaxton.com/download/delphi/SkinProject.zip
I'm trying to create a skinned form with no "Caption or Borders", but still leaving me with the full access to System Menu (I.E: Move, Minimize, Maximize, Restore and Size). I can achieve all of the menu items by overriding the CreateParams procedure by using WS_SYSMENU, WS_MAXIMIZEBOX, WS_MINIMIZEBOX. Using the WS_SIZEBOX gives me access to the menu "Size" command but paints a border I do not want. I have included a complete (Delphi 7) example in the link above. If more information is needed, please feel free to ask.
procedure TMainFrm.CreateParams(var Params: TCreateParams);
begin
FormStyle := fsNormal;
try
if (BorderIcons <> []) then BorderIcons := [];
if (BorderStyle <> bsNone) then BorderStyle := bsNone;
inherited CreateParams(Params);
Params.ExStyle := (Params.ExStyle and (not WS_EX_WINDOWEDGE)
and (not WS_EX_STATICEDGE) and (not WS_EX_DLGMODALFRAME) and (not WS_EX_CLIENTEDGE));
Params.Style := (Params.Style and (not WS_CAPTION) and (not DS_MODALFRAME)
and (not WS_DLGFRAME) and (not WS_THICKFRAME));
Params.Style := (Params.Style or WS_SYSMENU or WS_MAXIMIZEBOX or WS_MINIMIZEBOX or WS_SIZEBOX);
finally
Position := poScreenCenter;
end;
end;
SOLUTION:
unit WndProcUnit;
interface
uses
Windows, Messages, Classes, Controls, Forms, SysUtils;
type
EWndProc = class(Exception);
TWndProcMessages = class(TComponent)
private
{ Private declarations }
FOwnerWndProc: TFarProc;
FNewWndProc: TFarProc;
protected
{ Protected declarations }
procedure WndProc(var theMessage: TMessage); virtual;
public
{ Public declarations }
constructor Create(theOwner: TComponent); override;
destructor Destroy(); override;
procedure DefaultHandler(var theMessage); override;
end;
TWndProc = class(TWndProcMessages)
private
{ Private declarations }
protected
{ Protected declarations }
procedure Loaded(); override;
public
{ Public declarations }
constructor Create(theOwner: TComponent); override;
destructor Destroy(); override;
published
{ Published declarations }
end;
implementation
{ TWndProcMessages }
constructor TWndProcMessages.Create(theOwner: TComponent);
var
X, I: Integer;
begin
inherited Create(theOwner);
if (not (Owner is TForm)) then
raise EWndProc.Create('TWndProc parent must be a form!');
I := 0;
for X := 0 to (Owner.ComponentCount - 1) do
begin
if (Owner.Components[X] is TWndProc) then Inc(I);
if (I > 1) then Break;
end;
if (I > 1) then
begin
raise EWndProc.Create('The form already contains a TWndProc!');
end
else begin
FOwnerWndProc := TFarProc(GetWindowLong((Owner as TForm).Handle, GWL_WNDPROC));
FNewWndProc := Classes.MakeObjectInstance(WndProc);
if (not (csDesigning in ComponentState)) then
SetWindowLong((Owner as TForm).Handle, GWL_WNDPROC, LongInt(FNewWndProc));
end;
end;
destructor TWndProcMessages.Destroy();
begin
if Assigned(FNewWndProc) then
try
Classes.FreeObjectInstance(FNewWndProc);
finally
if (Pointer(FNewWndProc) <> nil) then Pointer(FNewWndProc) := nil;
end;
if Assigned(FOwnerWndProc) then Pointer(FOwnerWndProc) := nil;
inherited Destroy();
end;
procedure TWndProcMessages.DefaultHandler(var theMessage);
begin
if ((Owner as TForm).Handle <> 0) then
begin
case TMessage(theMessage).Msg of
WM_DESTROY:
SetWindowLong((Owner as TForm).Handle, GWL_WNDPROC, LongInt(FOwnerWndProc));
WM_INITMENU:
EnableMenuItem(TMessage(theMessage).WParam, SC_SIZE, MF_BYCOMMAND or MF_ENABLED);
else
with TMessage(theMessage) do
Result := CallWindowProc(FOwnerWndProc, (Owner as TForm).Handle, Msg, WParam, LParam);
end;
end
else
inherited DefaultHandler(theMessage);
end;
procedure TWndProcMessages.WndProc(var theMessage: TMessage);
begin
Dispatch(theMessage);
end;
{ TWndProc }
constructor TWndProc.Create(theOwner: TComponent);
begin
inherited Create(theOwner);
end;
destructor TWndProc.Destroy();
begin
inherited Destroy();
end;
procedure TWndProc.Loaded();
begin
inherited Loaded();
if (not (csDesigning in ComponentState)) then
GetSystemMenu((Owner as TForm).Handle, False);
end;
end.
Complete "updated" source code can be found here:
http://www.eyeClaxton.com/download/delphi/SkinProject.zip
Instead of having a border-less form and faking borders and caption all in the client area, the correct way to do this would be to handle WM_NCPAINT and draw your caption and border in the non-client area. Then, you wouldn't have to use an undocumented message to show the system menu on a caption-less window, or try to have the 'size' system menu item enabled on a window without a sizing border.
Anyway, if you want a quick workaround, enable the item yourself:
type
TMainFrm = class(TForm)
[...]
procedure FormCreate(Sender: TObject);
private
procedure WmInitMenuPopup(var Msg: TWMInitMenuPopup); message WM_INITMENUPOPUP;
[...]
procedure TMainFrm.FormCreate(Sender: TObject);
begin
GetSystemMenu(Handle, False); // force a copy of the system menu
[...]
end;
procedure TMainFrm.WmInitMenuPopup(var Msg: TWMInitMenuPopup);
begin
inherited;
if Msg.SystemMenu then
EnableMenuItem(Msg.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_ENABLED);
end;
PS:
In the code sample in the question, you're excluding WS_THICKFRAME, but including WS_SIZEBOX. They're, in fact, the same flag.
You've got a bit of a weird try-finally in your CreateParams. Form positioning have got nothing to do with the preceding code, you can put the 'Position := ' statement just before or after setting 'FormStyle' and drop the try-finally.

Resources