unit strtoicon;

interface
uses Windows;

function StringToIcon (const st : string;textcolor:dword) : HIcon;
procedure GetMaskBitmaps(hSourceBitmap:HBITMAP;clrTransparent:dword;
             var hAndMaskBitmap:HBitmap;var hXorMaskBitmap:HBitmap);
function CreateIconFromBitmap(hSourceBitmap:HBITMAP;clrTransparent:DWORD):HICON;

implementation

procedure GetMaskBitmaps(hSourceBitmap: HBITMAP;
  clrTransparent: dword; var hAndMaskBitmap, hXorMaskBitmap: HBitmap);
var dc:HDC;
    hMainDC:HDC;
    hAndMaskDC:HDC;
    hXorMaskDC:HDC;
    bm:BITMAP;
    hOldMainBitmap:HBitmap;
    hOldAndMaskBitmap:HBitmap;
    hOldXorMaskBitmap:HBitmap;
    MainBitPixel:DWORD;
    x,y:longint;
begin
        DC:=GetDC(0);
        hMainDC:=CreateCompatibleDC(DC);
        hAndMaskDC:=CreateCompatibleDC(DC);
        hXorMaskDC:=CreateCompatibleDC(DC);

        GetObject(hSourceBitmap,sizeof(BITMAP),@bm);

        hAndMaskBitmap  := CreateCompatibleBitmap(DC,bm.bmWidth,bm.bmHeight);
        hXorMaskBitmap  := CreateCompatibleBitmap(DC,bm.bmWidth,bm.bmHeight);

        hOldMainBitmap := SelectObject(hMainDC,hSourceBitmap);
        hOldAndMaskBitmap := SelectObject(hAndMaskDC,hAndMaskBitmap);
        hOldXorMaskBitmap := SelectObject(hXorMaskDC,hXorMaskBitmap);

        for x:=0 to bm.bmWidth-1 do
        begin
                for y:=0 to bm.bmHeight-1 do
                begin
                        MainBitPixel := GetPixel(hMainDC,x,y);
                        if(MainBitPixel = clrTransparent) then
                        begin
                                SetPixel(hAndMaskDC,x,y,RGB(255,255,255));
                                SetPixel(hXorMaskDC,x,y,RGB(0,0,0));
                        end
                        else
                        begin
                                SetPixel(hAndMaskDC,x,y,RGB(0,0,0));
                                SetPixel(hXorMaskDC,x,y,MainBitPixel);
                        end;
                end;
        end;

        SelectObject(hMainDC,hOldMainBitmap);
        SelectObject(hAndMaskDC,hOldAndMaskBitmap);
        SelectObject(hXorMaskDC,hOldXorMaskBitmap);

        DeleteDC(hXorMaskDC);
        DeleteDC(hAndMaskDC);
        DeleteDC(hMainDC);

        ReleaseDC(0,DC);

end;

function CreateIconFromBitmap(hSourceBitmap: HBITMAP;
  clrTransparent: DWORD): HICON;
var
    hAndMask:HBITMAP;
    hXorMask:HBITMAP;
    iconinfo:TICONINFO;
begin
        GetMaskBitmaps(hSourceBitmap,clrTransparent,hAndMask,hXorMask);
        if(hAndMask=0) or (hXorMask=0) then
        begin
             result:=0;
             exit;
        end;

        iconinfo.fIcon          := true;
        iconinfo.xHotspot       := 0;
        iconinfo.yHotspot       := 0;
        iconinfo.hbmMask        := hAndMask;
        iconinfo.hbmColor       := hXorMask;

        result := CreateIconIndirect(iconinfo);
        DeleteObject(hAndMask);
        DeleteObject(hXorMask);
end;

function StringToIcon (const st : string;textcolor:dword) : HIcon;
var bm:HBitmap;
    dc:HDC;
    hb,font:THandle;
    brush:TLogBrush;
    r:TRect;
begin
     bm:=CreateBitmap(16,16,1,32,nil);
     dc:=CreateCompatibleDC(0);
     DeleteObject(SelectObject(dc,bm));

     brush.lbColor:=$808000;
     brush.lbStyle:=BS_SOLID;
     brush.lbHatch:=0;
     hb:=CreateBrushIndirect(brush);
     DeleteObject(SelectObject(dc,hb));
     r.Left:=0;
     r.Top:=0;
     r.Right:=16;
     r.Bottom:=16;
     FillRect(dc,r,hb);
     font:=CreateFont(16,7,0,0,0,0,1,0,ANSI_CHARSET,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, ANTIALIASED_QUALITY,
        FF_DONTCARE, 'Tahoma');
     DeleteObject(SelectObject(dc,font));
     SetTextColor(dc, textcolor);
     SetBkMode(dc, TRANSPARENT);
     TextOut(dc,0,0,PChar(st),2);

     DeleteDC(dc);
     result:=CreateIconFromBitmap(bm,$808000);
     DeleteObject(hb);
     DeleteObject(font);
     DeleteObject(bm);
end;
end.

  hImageList := ImageList_Create(16, 16, ILC_MASK, 1, 0);
  ImageList_AddMasked(hImageList, hBMP, RGB(128, 0, 128));
  Icon.Handle := ImageList_GetIcon(hImageList,0, ILD_TRANSPARENT);

  hBMP := LoadBitmap(GetModuleHandle(0), 'MAINBMP');
  hImageList := ImageList_Create(16, 16, ILC_MASK, 1, 0);
  ImageList_AddMasked(hImageList, hBMP, RGB(128, 0, 128));
  Icon.Handle := ImageList_GetIcon(hImageList,0, ILD_TRANSPARENT);
  ImageList_DrawEx(hImageList, 0, GetWindowDC(handle), 100, 100, 0, 0, CLR_NONE, CLR_DEFAULT, ILD_TRANSPARENT);

function StringToIcon(const st: string; textcolor: dword): HIcon;
const TransparentBkColor = clBlack;
var bm: HBitmap; dc: HDC; hb,font: THandle; hImageList: THandle;
begin
  bm := CreateBitmap(16,16,1,32,nil);
  dc := CreateCompatibleDC(0);
  DeleteObject(SelectObject(dc,bm));

  SetBkColor(DC, TransparentBkColor);

  font:=CreateFont(16,7,0,0,0,0,1,0,ANSI_CHARSET,OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, ANTIALIASED_QUALITY, FF_DONTCARE, 'Tahoma');

  DeleteObject(SelectObject(dc,font));
  SetTextColor(DC, textColor);
  TextOut(dc,0,0,PChar(st),2);

  DeleteDC(dc);
  DeleteObject(hb);
  DeleteObject(font);

  hImageList := ImageList_Create(16, 16, ILC_MASK, 1, 0);
  ImageList_AddMasked(hImageList, bm, TransparentBkColor);
  DeleteObject(bm);

  result := ImageList_GetIcon(hImageList, 0, ILD_TRANSPARENT);
  ImageList_Destroy(hImageList);
end;

int WINAPI ImageList_AddMaskedHelper(IMAGELIST* piml, HBITMAP hbmImage, COLORREF crMask)
{
    COLORREF crbO, crtO;
    HBITMAP hbmMask;
    int cImage;
    int retval;
    int n,i;
    BITMAP bm;
    DWORD ColorTableSave[256];
    DWORD ColorTable[256];

    if (GetObject(hbmImage, sizeof(bm), &bm) != sizeof(bm))
        return -1;

    hbmMask = CreateMonoBitmap(bm.bmWidth, bm.bmHeight);
    if (!hbmMask)
        return -1;

    ENTERCRITICAL;

    // copy color to mono, with crMask turning 1 and all others 0, then
    // punch all crMask pixels in color to 0
    ImageList_SelectSrcBitmap(hbmImage);
    ImageList_SelectDstBitmap(hbmMask);

    // crMask == CLR_DEFAULT, means use the pixel in the upper left
    //
    if (crMask == CLR_DEFAULT)
        crMask = GetPixel(g_hdcSrc, 0, 0);

    // DIBSections dont do color->mono like DDBs do, so we have to do it.
    // this only works for <=8bpp DIBSections, this method does not work
    // for HiColor DIBSections.
    //
    // Please note, this code has an endianship problems the comparision in the if statement
    // below is sensitive to endianship
    // ----> if (ColorTableSave[i] == RGB(GetBValue(crMask),GetGValue(crMask),GetRValue(crMask))
    //
    if (bm.bmBits != NULL && bm.bmBitsPixel <= 8)
    {
        n = GetDIBColorTable(g_hdcSrc, 0, 256, (RGBQUAD*)ColorTableSave);

        for (i=0; i<n; i++)
        {
            if (ColorTableSave[i] == RGB(GetBValue(crMask),GetGValue(crMask),GetRValue(crMask)))
                ColorTable[i] = 0x00FFFFFF;
            else
                ColorTable[i] = 0x00000000;
        }

        SetDIBColorTable(g_hdcSrc, 0, n, (RGBQUAD*)ColorTable);
    }
    else if (bm.bmBits != NULL && bm.bmBitsPixel > 8)
    {
        RIPMSG(0, "ImageList_AddMask on a bmp with more than 256 colors is not supported\r\nFix your bmp to use fewer colors");
    }

    crbO = SetBkColor(g_hdcSrc, crMask);
    BitBlt(g_hdcDst, 0, 0, bm.bmWidth, bm.bmHeight, g_hdcSrc, 0, 0, SRCCOPY);
    SetBkColor(g_hdcSrc, 0x00FFFFFFL);
    crtO = SetTextColor(g_hdcSrc, 0x00L);
    BitBlt(g_hdcSrc, 0, 0, bm.bmWidth, bm.bmHeight, g_hdcDst, 0, 0, ROP_DSna);
    SetBkColor(g_hdcSrc, crbO);
    SetTextColor(g_hdcSrc, crtO);

    if (bm.bmBits != NULL && bm.bmBitsPixel <= 8)
    {
        SetDIBColorTable(g_hdcSrc, 0, n, (RGBQUAD*)ColorTableSave);
    }

    ImageList_SelectSrcBitmap(NULL);
    ImageList_SelectDstBitmap(NULL);

    ASSERT(piml->cx);
    cImage = bm.bmWidth / piml->cx;    // # of images in source

    retval = ImageList_Add2(piml, hbmImage, hbmMask, cImage, 0, 0);

    DeleteObject(hbmMask);
    LEAVECRITICAL;
    return retval;
}