-large get the large version of the icon (small is the default) -selected get the appearance of the icon when it is selected -open get the icon that is shown when the file is opened (e.g. an opened folder)ScreenshotAn example of all the different icon types, note that the link overlay for shortcuts will be returned as well.
Example
# dll provides the package shellicon
load shellicon0.1.dll
label .l1 -image [::shellicon::get c:/Windows]
label .l2 -image [::shellicon::get -large c:/Windows]
label .l3 -image [::shellicon::get -selected c:/Windows]
label .l4 -image [::shellicon::get -large -selected c:/Windows]
label .l5 -image [::shellicon::get -open c:/Windows]
label .l6 -image [::shellicon::get -large -open c:/Windows]
label .l7 -image [::shellicon::get -open -selected c:/Windows]
label .l8 -image [::shellicon::get -large -open -selected c:/Windows]
grid .l1 .l2 .l3 .l4 .l5 .l6 .l7 .l8
catch {console show}BuildTo build with gcc use:gcc shellicon.c -lgdi32 -ltclstub85 -ltkstub85 -I/c/Tcl/include -L/c/Tcl/lib\ -DUSE_TCL_STUBS -DUSE_TK_STUBS -shared -o shellicon0.1.dllA stubs enabled dll for >8.5 can be downloaded from [2]. MHo 2018-06-18: dead link.AlanG - 2008-01-22 I can't follow the link above - 404 no such file. I tried various other versions of the file with no luck, could someone update the link please?MJ - URL changed to correct location.Source
#include <tcl.h>
#include <tk.h>
#include <windows.h>
#include <shellapi.h>
#include <stdio.h>
static int GetIcon_Cmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]) {
SHFILEINFOW shfi;
ICONINFO iconInfo ;
BITMAP bmp;
long imageSize ;
char * bitBuffer , * byteBuffer ;
int i, index;
int result, hasAlpha;
const char * image_name;
Tk_PhotoHandle photo;
Tk_PhotoImageBlock block;
const char * file_name;
int bitSize;
unsigned int uFlags;
static CONST char *options[] = {
"-large", "-open", "-selected", NULL};
enum IOption {
ILARGE, IOPEN, ISELECTED
};
if (objc < 2) {
Tcl_WrongNumArgs(interp,1,objv,"?options? fileName");
return TCL_ERROR;
}
/* SHGFI_ICON == SHGFI_LARGEICON so large is the default, select small instead
then remove the flag if -large is specified
*/
uFlags = SHGFI_ICON | SHGFI_SMALLICON;
for (i=1 ; i < objc-1 ; i++) {
result = Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
(int *) &index);
if (result != TCL_OK) {
return result;
}
switch (index) {
case ILARGE:
/* setting LARGE is equivalent to unsetting SMALL */
uFlags ^= SHGFI_SMALLICON;
break;
case IOPEN:
uFlags |= SHGFI_OPENICON;
break;
case ISELECTED:
uFlags |= SHGFI_SELECTED;
break;
default:
Tcl_Panic("option lookup failed");
}
}
/* Normalize the filename */
file_name = Tcl_FSGetNativePath(objv[objc-1]);
if (file_name == NULL) {
return TCL_ERROR;
}
result = SHGetFileInfoW(
(LPCWSTR) file_name,
0,
&shfi,
sizeof(SHFILEINFO),
uFlags
);
if (result == 0) {
WCHAR msg[255];
int l;
Tcl_SetResult(interp, "failed to load icon: ",NULL);
FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,0,GetLastError(),0,msg,255,0);
/* lose the newline */
l = 0;
while (msg[l]!='\r' && msg[l]!='\n' && msg[l]!='\0') {
l++;
}
msg[l]='\0';
Tcl_AppendResult(interp, msg,NULL);
return TCL_ERROR;
}
GetIconInfo(shfi.hIcon, &iconInfo);
result = GetObject(
iconInfo.hbmMask,
sizeof(BITMAP),
(void *)&bmp
);
bitSize = bmp.bmWidth * bmp.bmHeight * bmp.bmBitsPixel / 8;
bitBuffer = ckalloc(bitSize);
GetBitmapBits(iconInfo.hbmMask,bitSize,bitBuffer);
result = GetObject(
iconInfo.hbmColor,
sizeof(BITMAP),
(void *)&bmp
);
imageSize = bmp.bmWidth * bmp.bmHeight * bmp.bmBitsPixel / 8;
byteBuffer = ckalloc(imageSize);
GetBitmapBits(iconInfo.hbmColor,imageSize,byteBuffer);
/* Do some mask and Alpha channel voodoo, because not all Icons define an alpha channel
and MS has decided to make completely transparent the default in that case, AAARGGH
Might be some bit masking I am missing here though.
*/
hasAlpha = 0;
for (i = 0 ; i < imageSize ; i+=4) {
if (byteBuffer[i+offsetof(RGBQUAD,rgbReserved)]!=0) {
hasAlpha = 1;
break;
}
}
#define BIT_SET(x,y) (((x) >> (8-(y)) ) & 1 )
for (i=0;i<bitSize;i++) {
if (hasAlpha) break;
// if (i%2==0) {fprintf(stderr,"\n");}
int bit = 0;
for (bit=0; bit < 8 ; bit++) {
if (BIT_SET(bitBuffer[i],bit)) {
// fprintf(stderr,"0");
byteBuffer[(i*8+bit)*4+3] = 0;
} else {
// fprintf(stderr,"1");
byteBuffer[(i*8+bit)*4+3] = 255;
}
}
}
/* setup the Tk block structure */
block.pixelPtr = byteBuffer;
block.width = bmp.bmWidth;
block.height = bmp.bmHeight;
block.pitch = bmp.bmWidthBytes;
block.pixelSize = bmp.bmBitsPixel/8;
block.offset[0] = offsetof(RGBQUAD,rgbRed);
block.offset[1] = offsetof(RGBQUAD,rgbGreen);
block.offset[2] = offsetof(RGBQUAD,rgbBlue);
block.offset[3] = offsetof(RGBQUAD,rgbReserved);
/* Create the image */
result = Tcl_Eval(interp,"image create photo");
if (result != TCL_OK) {
return TCL_ERROR;
}
image_name = Tcl_GetStringResult(interp);
photo = Tk_FindPhoto(interp, image_name);
result = Tk_PhotoPutBlock( interp,photo, &block ,0,0,block.width, block.height,TK_PHOTO_COMPOSITE_SET);
if (result != TCL_OK) {
return TCL_ERROR;
}
//cleanup
ckfree(bitBuffer);
ckfree(byteBuffer);
DeleteObject(iconInfo.hbmMask);
DeleteObject(iconInfo.hbmColor);
DestroyIcon(shfi.hIcon);
Tcl_AppendResult(interp, image_name, NULL);
return TCL_OK;
}
int DLLEXPORT
Shellicon_Init(Tcl_Interp *interp)
{
if (Tcl_InitStubs(interp, "8.4", 0) == 0L) {
return TCL_ERROR;
}
if (Tk_InitStubs(interp, "8.4", 0) == 0L) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "shellicon::get", GetIcon_Cmd, NULL, NULL);
Tcl_PkgProvide(interp, "shellicon", "0.1");
return TCL_OK;
}I wonder if there are a series of these types of commands which would be useful to put together in a distributable form, or, even, together submitted as a TIP to be included in the Windows Tcl distribution?MJ - Extensions like these seem to be a prime candidate for a binary Tcllib/Tklib. Problem with adding this to the core is that similar functionallity for linux is almost impossible to build because it is so dependend on the file manager/destop being used.LV I was just thinking about the fact that we already have speciality extensions like Registry in the Tcl core. I don't know that, specifically, this one is as important as the registry extension, but certainly I would think there is room for specialty extensions. There's several Windows special extensions like twapi.NEM It should be possible to build a version of this for MacOS X. If I had the time, I'd do it myself.FM There is some internationalization problems here due to encoding. I suppose it come from Tcl_TranslateFileName. I try myself to correct it but I really don't understand how Tcl works in matter of encoding. Note what the Tcl 8.5 manual says about this procedure Tcl_TranslateFileName:However, with the advent of the newer Tcl_FSGetNormalizedPath and Tcl_GetNativePath, there is no longer any need to use this procedure. In particular, Tcl_GetNativePath performs all the necessary translation and encoding conversion, is virtual-filesystem aware, and caches the native result for faster repeated calls. Finally Tcl_GetNativePath does not require you to free anything afterwards.MJ Please try updated version above. With the update, the following works:
% file mkdir \u0e01 % load shellicon0.1.dll % label .l1 -image [::shellicon::get \u0e01] % pack .l1
