StringToIcon('Delphi World Is Cool !!!'); 
// Не забудьте удалить объект HIcon, после вызова функции... 

unit MainForm; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, ExtCtrls; 

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Image1: TImage; 
    Timer1: TTimer; 
    procedure Button1Click(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
  private 
    function StringToIcon (const st : string) : HIcon; 
  public 
    { Public declarations } 
end; 

var 
  Form1: TForm1; 

implementation 
{$R *.DFM} 

type 
  ICONIMAGE = record 
    Width, Height, Colors : DWORD; // Ширина, Высота и кол-во цветов 
    lpBits : PChar; // указатель на DIB биты 
    dwNumBytes : DWORD; // Сколько байт? 
    lpbi : PBitmapInfoHeader; // указатель на заголовок 
    lpXOR : PChar; // указатель на XOR биты изображения 
    lpAND : PChar; // указатель на AND биты изображения 
end; 

function CopyColorTable (var lpTarget: BITMAPINFO; 
const lpSource: BITMAPINFO): boolean; 
var 
  dc : HDC; 
  hPal : HPALETTE; 
  pe : array [0..255] of PALETTEENTRY; 
  i : Integer; 
begin 
  result := False; 
  case (lpTarget.bmiHeader.biBitCount) of 
    8 : 
      if lpSource.bmiHeader.biBitCount = 8 then 
      begin 
        Move (lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof (RGBQUAD)); 
        result := True 
      end 
      else 
      begin 
        dc := GetDC (0); 
        if dc <> 0 then 
          try 
            hPal := CreateHalftonePalette (dc); 
            if hPal <> 0 then 
              try 
                if GetPaletteEntries (hPal, 0, 256, pe) <> 0 then 
                begin 
                  for i := 0 to 255 do 
                  begin 
                    lpTarget.bmiColors [i].rgbRed := pe [i].peRed; 
                    lpTarget.bmiColors [i].rgbGreen := pe [i].peGreen; 
                    lpTarget.bmiColors [i].rgbBlue := pe [i].peBlue; 
                    lpTarget.bmiColors [i].rgbReserved := pe [i].peFlags;
                  end; 
                  result := True 
                end 
              finally 
                DeleteObject (hPal) 
              end 
          finally 
            ReleaseDC (0, dc) 
          end 
      end; 
    4 : 
      if lpSource.bmiHeader.biBitCount = 4 then 
      begin 
        Move (lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof (RGBQUAD)); 
        result := True 
      end 
      else 
      begin 
        hPal := GetStockObject (DEFAULT_PALETTE); 
        if (hPal <> 0) and (GetPaletteEntries (hPal, 0, 16, pe) <> 0) then 
        begin 
          for i := 0 to 15 do 
          begin 
            lpTarget.bmiColors [i].rgbRed := pe [i].peRed; 
            lpTarget.bmiColors [i].rgbGreen := pe [i].peGreen; 
            lpTarget.bmiColors [i].rgbBlue := pe [i].peBlue; 
            lpTarget.bmiColors [i].rgbReserved := pe [i].peFlags; 
          end; 
          result := True 
        end 
      end; 
    1: 
    begin 
      i := 0; 
      lpTarget.bmiColors[i].rgbRed := 0; 
      lpTarget.bmiColors[i].rgbGreen := 0; 
      lpTarget.bmiColors[i].rgbBlue := 0; 
      lpTarget.bmiColors[i].rgbReserved := 0; 
      i := 1; 
      lpTarget.bmiColors[i].rgbRed := 255; 
      lpTarget.bmiColors[i].rgbGreen := 255; 
      lpTarget.bmiColors[i].rgbBlue := 255; 
      lpTarget.bmiColors[i].rgbReserved := 0; 
      result := True 
    end; 
  else 
    result := True 
  end 
end; 

function WidthBytes (bits : DWORD) : DWORD; 
begin 
  result := ((bits + 31) shr 5) shl 2;
end; 

function BytesPerLine (const bmih : BITMAPINFOHEADER) : DWORD; 
begin 
  result := WidthBytes (bmih.biWidth * bmih.biPlanes * bmih.biBitCount); 
end; 

function DIBNumColors (const lpbi : BitmapInfoHeader) : word; 
var 
  dwClrUsed : DWORD; 
begin 
  dwClrUsed := lpbi.biClrUsed; 
  if dwClrUsed <> 0 then 
    result := Word (dwClrUsed) 
  else 
    case lpbi.biBitCount of 
      1 : result := 2; 
      4 : result := 16; 
      8 : result := 256 
      else 
        result := 0; 
    end 
end; 

function PaletteSize (const lpbi : BitmapInfoHeader) : word; 
begin 
  result := DIBNumColors (lpbi) * sizeof (RGBQUAD); 
end; 

function FindDIBBits (const lpbi : BitmapInfo) : PChar; 
begin 
  result := @lpbi; 
  result := result + lpbi.bmiHeader.biSize + PaletteSize (lpbi.bmiHeader); 
end; 

function ConvertDIBFormat (var lpSrcDIB : BITMAPINFO; nWidth, nHeight, 
nbpp : DWORD; bStretch : boolean) : PBitmapInfo; 
var 
  lpbmi : PBITMAPINFO; 
  lpSourceBits, lpTargetBits : Pointer; 
  DC, hSourceDC, hTargetDC : HDC;
  hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap : HBITMAP; 
  dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize : DWORD; 
begin 
  result := nil; 
  // Располагаем и заполняем структуру BITMAPINFO для нового DIB 
  // Обеспечиваем достаточно места для 256-цветной таблицы 
  dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( 256 * sizeof( RGBQUAD ) ); 
  GetMem (lpbmi, dwTargetHeaderSize); 
  try 
    lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER); 
    lpbmi^.bmiHeader.biWidth := nWidth; 
    lpbmi^.bmiHeader.biHeight := nHeight; 
    lpbmi^.bmiHeader.biPlanes := 1; 
    lpbmi^.bmiHeader.biBitCount := nbpp; 
    lpbmi^.bmiHeader.biCompression := BI_RGB; 
    lpbmi^.bmiHeader.biSizeImage := 0; 
    lpbmi^.bmiHeader.biXPelsPerMeter := 0; 
    lpbmi^.bmiHeader.biYPelsPerMeter := 0; 
    lpbmi^.bmiHeader.biClrUsed := 0; 
    lpbmi^.bmiHeader.biClrImportant := 0; 
    // Заполняем в таблице цветов 
    if CopyColorTable (lpbmi^, lpSrcDIB) then 
    begin 
      DC := GetDC (0); 
      hTargetBitmap := CreateDIBSection (DC, lpbmi^, DIB_RGB_COLORS, lpTargetBits, 0, 0 ); 
      hSourceBitmap := CreateDIBSection (DC, lpSrcDIB, DIB_RGB_COLORS, lpSourceBits, 0, 0 ); 
      try 
        if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then 
        begin 
          hSourceDC := CreateCompatibleDC (DC); 
          hTargetDC := CreateCompatibleDC (DC); 
          try 
            if (hSourceDC <> 0) and (hTargetDC <> 0) then 
            begin 
              // Flip the bits on the source DIBSection to match the source DIB 
              dwSourceBitsSize := DWORD (lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader); 
              dwTargetBitsSize := DWORD (lpbmi^.bmiHeader.biHeight) * BytesPerLine(lpbmi^.bmiHeader); 
              Move (FindDIBBits (lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize ); 
              // Select DIBSections into DCs 
              hOldSourceBitmap := SelectObject( hSourceDC, hSourceBitmap ); 
              hOldTargetBitmap := SelectObject( hTargetDC, hTargetBitmap ); 
              try 
                if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then 
                begin 
                  // Устанавливаем таблицу цветов для DIBSections 
                  if lpSrcDIB.bmiHeader.biBitCount <= 8 then 
                    SetDIBColorTable (hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors); 
                  if lpbmi^.bmiHeader.biBitCount <= 8 then 
                    SetDIBColorTable (hTargetDC, 0, 1 shl lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors ); 
                  // If we are asking for a straight copy, do it 
                  if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and 
                  (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then 
                    BitBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, 
                    hSourceDC, 0, 0, SRCCOPY) 
                  else 
                  if bStretch then 
                  begin 
                    SetStretchBltMode (hTargetDC, COLORONCOLOR); 
                    StretchBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, 
                    lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, 
                    lpSrcDIB.bmiHeader.biHeight, SRCCOPY ); 
                  end 
                  else 
                    BitBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, 
                    lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY ); 
                  GDIFlush; 
                  GetMem (result, Integer (dwTargetHeaderSize + dwTargetBitsSize)); 
                  Move (lpbmi^, result^, dwTargetHeaderSize); 
                  Move (lpTargetBits^, FindDIBBits (result^)^, dwTargetBitsSize); 
                end 
              finally 
                if hOldSourceBitmap <> 0 then 
                  SelectObject (hSourceDC, hOldSourceBitmap); 
                if hOldTargetBitmap <> 0 then 
                  SelectObject (hTargetDC, hOldTargetBitmap); 
              end 
            end 
          finally 
            if hSourceDC <> 0 then 
              DeleteDC (hSourceDC); 
            if hTargetDC <> 0 then 
              DeleteDC (hTargetDC); 
          end 
        end; 
      finally 
        if hTargetBitmap <> 0 then 
          DeleteObject (hTargetBitmap); 
        if hSourceBitmap <> 0 then 
          DeleteObject (hSourceBitmap); 
        if dc <> 0 then 
          ReleaseDC (0, dc) 
      end 
    end 
  finally 
    FreeMem (lpbmi) 
  end 
end; 

function DIBToIconImage (var lpii : ICONIMAGE; var lpDIB: 
BitmapInfo; bStretch : boolean) : boolean; 
var 
  lpNewDIB : PBitmapInfo; 
begin 
  result := False; 
  lpNewDIB := ConvertDIBFormat (lpDIB, lpii.Width, lpii.Height, lpii.Colors, bStretch ); 
  if Assigned (lpNewDIB) then 
    try 
      lpii.dwNumBytes := sizeof (BITMAPINFOHEADER)// Заголовок 
      + PaletteSize (lpNewDIB^.bmiHeader)// Палитра
      + lpii.Height * BytesPerLine (lpNewDIB^.bmiHeader)// XOR маска 
      + lpii.Height * WIDTHBYTES (lpii.Width);// AND маска 
      // Если здесь уже картинка, то освобождаем её 
    if lpii.lpBits <> nil then 
      FreeMem (lpii.lpBits); 
    GetMem (lpii.lpBits, lpii.dwNumBytes); 
    Move (lpNewDib^, lpii.lpBits^, sizeof (BITMAPINFOHEADER) + PaletteSize (lpNewDIB^.bmiHeader)); 
    // Выравниваем внутренние указатели/переменные для новой картинки 
    lpii.lpbi := PBITMAPINFOHEADER (lpii.lpBits); 
    lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2; 
    lpii.lpXOR := FindDIBBits (PBitmapInfo (lpii.lpbi)^); 
    Move (FindDIBBits (lpNewDIB^)^, lpii.lpXOR^, 
    lpii.Height * BytesPerLine (lpNewDIB^.bmiHeader)); 
    lpii.lpAND := lpii.lpXOR + lpii.Height * 
    BytesPerLine (lpNewDIB^.bmiHeader); 
    Fillchar (lpii.lpAnd^, lpii.Height * WIDTHBYTES (lpii.Width), $00); 
    result := True 
  finally 
    FreeMem (lpNewDIB) 
  end 
end; 

function TForm1.StringToIcon (const st : string) : HIcon; 
var 
  memDC : HDC; 
  bmp : HBITMAP; 
  oldObj : HGDIOBJ; 
  rect : TRect; 
  size : TSize; 
  infoHeaderSize : DWORD; 
  imageSize : DWORD; 
  infoHeader : PBitmapInfo; 
  icon : IconImage; 
  oldFont : HFONT; 
begin 
  result := 0; 
  memDC := CreateCompatibleDC (0); 
  if memDC <> 0 then 
    try 
      bmp := CreateCompatibleBitmap (Canvas.Handle, 16, 16); 
      if bmp <> 0 then 
        try 
          oldObj := SelectObject (memDC, bmp); 
          if oldObj <> 0 then 
            try 
              rect.Left := 0; 
              rect.top := 0; 
              rect.Right := 16; 
              rect.Bottom := 16; 
              SetTextColor (memDC, RGB (255, 0, 0)); 
              SetBkColor (memDC, RGB (128, 128, 128)); 
              oldFont := SelectObject (memDC, font.Handle); 
              GetTextExtentPoint32 (memDC, PChar (st), Length (st), size); 
              ExtTextOut (memDC, (rect.Right - size.cx) div 2, 
              (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, 
              PChar (st), Length (st), nil); 
              SelectObject (memDC, oldFont); 
              GDIFlush; 
              GetDibSizes (bmp, infoHeaderSize, imageSize); 
              GetMem (infoHeader, infoHeaderSize + ImageSize); 
              try 
                GetDib (bmp, SystemPalette16, infoHeader^, 
                PChar (DWORD (infoHeader) + infoHeaderSize)^); 
                icon.Colors := 4; 
                icon.Width := 32; 
                icon.Height := 32; 
                icon.lpBits := nil; 
                if DibToIconImage (icon, infoHeader^, True) then 
                  try 
                    result := CreateIconFromResource (PByte (icon.lpBits), 
                    icon.dwNumBytes, True, $00030000); 
                  finally 
                    FreeMem (icon.lpBits) 
                  end 
              finally 
                FreeMem (infoHeader) 
              end 
            finally 
              SelectObject (memDC, oldOBJ) 
            end 
          finally 
            DeleteObject (bmp) 
          end 
        finally 
          DeleteDC (memDC) 
        end 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Application.Icon.Handle := StringToIcon ('0'); 
  Timer1.Enabled := True; 
  Button1.Enabled := False; 
end; 

procedure TForm1.Timer1Timer(Sender: TObject); 
const 
  i : Integer = 0; 
begin 
  Inc (i); 
  if i = 100 then 
    i := 1; 
  Application.Icon.Handle := StringToIcon (IntToStr (i)); 
end; 

end.