Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Отображаем текст в System Tray

Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.

Вызов просходит следующим образом:


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.

Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.