Отображаем текст в System Tray.

Автор: Ruslan Abu Zant
Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.
Вызов просходит следующим образом....
StringToIcon('This Is Made By Ruslan K. Abu Zant');
N.B>> Не забудьте удалить объект 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); {Код исправлен by Alex (<a href="http://forum.vingrad.ru" title="http://forum.vingrad.ru">http://forum.vingrad.ru</a>)}

{$WRITEABLECONST ON}

const

 i: Integer = 0;

begin

 Inc(i);

 if i = 100 then i := 1;

 Application.Icon.Handle := StringToIcon(IntToStr(i));

{$WRITEABLECONST OFF}

end;

end.

Взято из http://forum.sources.ru

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...