Posted to tcl by KFF at Tue Apr 12 19:02:16 GMT 2016view raw
- #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[]) {
- SHFILEINFO 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;
- Tcl_DString ds;
- HDC hdc;
- int bitSize;
- unsigned int uFlags;
- Tcl_Obj *pathPtr;
- int bit;
- CONST TCHAR *native;
- 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 */
- //norm = Tcl_FSGetNormalizedPath(interp, objv[objc]);
- //Tcl_UtfToExternalDString(NULL, Tcl_GetString(norm), -1, &ds);
- file_name = Tcl_GetString (objv[objc-1]);
- //file_name = Tcl_DuplicateObj(objv[1]);
- //Tcl_IncrRefCount(file_name);
- //if (Tcl_FSConvertToPathType(interp, file_name) != TCL_OK ) {
- // Tcl_DecrRefCount(file_name);
- // return TCL_ERROR;
- //}
- //if (Tcl_FSGetNormalizedPath(interp, file_name) == NULL) {
- // Tcl_DecrRefCount(file_name);
- // return TCL_ERROR;
- //}
- native = (CONST TCHAR*) Tcl_FSGetNativePath(file_name);
- native = Tcl_WinUtfToTChar(native, -1, &ds);
- //native = Tcl_WinUtfToTChar(dirName, -1, &ds);
- file_name = Tcl_TranslateFileName(interp, native, &ds);
- if (file_name == NULL) {
- return TCL_ERROR;
- }
- result = SHGetFileInfo(
- Tcl_DStringValue(&ds),
- 0,
- &shfi,
- sizeof(SHFILEINFO),
- uFlags
- );
- Tcl_DStringFree(&ds);
- if (result == 0) {
- char msg[255];
- int l;
- Tcl_SetResult(interp, "failed to load icon: ", NULL);
- FormatMessage(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");}
- 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;
- }