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

Материал из DRKB

Отображаем текст в System Tray.[править | править код]

Данный код сперва конвертирует Ваш текст в 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;

{ Код исправлен by Alex (http://forum.vingrad.ru) }
procedure TForm1.Timer1Timer(Sender: TObject);
{$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.


Author: Ruslan Abu Zant
Source: Взято из http://forum.sources.ru
ID: 01761