_graphics.pas

East make Tray Icon in delphi

    FreeAndNil(Bitmap);
    FreeAndNil(JPeg);
  end;
end;
{$ENDIF VCL}

{$IFDEF MSWINDOWS}
function ExtractIconCount(const FileName: string): Integer;
begin
  Result := ExtractIcon(HInstance, PChar(FileName), $FFFFFFFF);
end;

function BitmapToIcon(Bitmap: HBITMAP; cx, cy: Integer): HICON;
var
  ImgList: HIMAGELIST;
  I: Integer;
begin
  ImgList := ImageList_Create(cx, cy, ILC_COLOR, 1, 1);
  try
    I := ImageList_Add(ImgList, Bitmap, 0);
    Result := ImageList_GetIcon(ImgList, I, ILD_NORMAL);
  finally
    ImageList_Destroy(ImgList);
  end;
end;

function IconToBitmap(Icon: HICON): HBITMAP;
var
  IconInfo: TIconInfo;
begin
  Result := 0;
  if GetIconInfo(Icon, IconInfo) then
  begin
    DeleteObject(IconInfo.hbmMask);
    Result := IconInfo.hbmColor;
  end;
end;
{$ENDIF MSWINDOWS}

{$IFDEF VCL}
procedure GetIconFromBitmap(Icon: TIcon; Bitmap: TBitmap);
var
  IconInfo: TIconInfo;
begin
  with TBitmap.Create do
  try
    Assign(Bitmap);
    if not Transparent then
      TransparentColor := clNone;
    IconInfo.fIcon := True;
    IconInfo.hbmMask := MaskHandle;
    IconInfo.hbmColor := Handle;
    Icon.Handle := CreateIconIndirect(IconInfo);
  finally
    Free;
  end;
end;

const
  rc3_Icon = 1;

type
  PCursorOrIcon = ^TCursorOrIcon;
  TCursorOrIcon = packed record
    Reserved: Word;
    wType: Word;
    Count: Word;
  end;

  PIconRec = ^TIconRec;
  TIconRec = packed record
    Width: Byte;
    Height: Byte;
    Colors: Word;
    Reserved1: Word;
    Reserved2: Word;
    DIBSize: Longint;
    DIBOffset: Longint;
  end;

procedure WriteIcon(Stream: TStream; ColorBitmap, MaskBitmap: HBITMAP; WriteLength: Boolean = False);
var
  MonoInfoSize, ColorInfoSize: DWORD;
  MonoBitsSize, ColorBitsSize: DWORD;
  MonoInfo, MonoBits, ColorInfo, ColorBits: Pointer;
  CI: TCursorOrIcon;
  List: TIconRec;
  Length: Longint;
begin
  FillChar(CI, SizeOf(CI), 0);
  FillChar(List, SizeOf(List), 0);
  GetDIBSizes(MaskBitmap, MonoInfoSize, MonoBitsSize);
  GetDIBSizes(ColorBitmap, ColorInfoSize, ColorBitsSize);
  MonoInfo := nil;
  MonoBits := nil;
  ColorInfo := nil;
  ColorBits := nil;
  try
    MonoInfo := AllocMem(MonoInfoSize);
    MonoBits := AllocMem(MonoBitsSize);
    ColorInfo := AllocMem(ColorInfoSize);
    ColorBits := AllocMem(ColorBitsSize);
    GetDIB(MaskBitmap, 0, MonoInfo^, MonoBits^);
    GetDIB(ColorBitmap, 0, ColorInfo^, ColorBits^);
    if WriteLength then
    begin
      Length := SizeOf(CI) + SizeOf(List) + ColorInfoSize +
        ColorBitsSize + MonoBitsSize;
      Stream.Write(Length, SizeOf(Length));
    end;
    with CI do
    begin
      CI.wType := RC3_ICON;
      CI.Count := 1;
    end;
    Stream.Write(CI, SizeOf(CI));
    with List, PBitmapInfoHeader(ColorInfo)^ do
    begin
      Width := biWidth;
      Height := biHeight;
      Colors := biPlanes * biBitCount;
      DIBSize := ColorInfoSize + ColorBitsSize + MonoBitsSize;
      DIBOffset := SizeOf(CI) + SizeOf(List);
    end;
    Stream.Write(List, SizeOf(List));
    with PBitmapInfoHeader(ColorInfo)^ do
      Inc(biHeight, biHeight); { color height includes mono bits }
    Stream.Write(ColorInfo^, ColorInfoSize);
    Stream.Write(ColorBits^, ColorBitsSize);
    Stream.Write(MonoBits^, MonoBitsSize);
  finally
    FreeMem(ColorInfo, ColorInfoSize);
    FreeMem(ColorBits, ColorBitsSize);
    FreeMem(MonoInfo, MonoInfoSize);
    FreeMem(MonoBits, MonoBitsSize);
  end;
end;

// WriteIcon depends on unit Graphics by use of GetDIBSizes and GetDIB

procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean = False);
var
  IconInfo: TIconInfo;
begin
  if GetIconInfo(Icon, IconInfo) then
  try
    WriteIcon(Stream, IconInfo.hbmColor, IconInfo.hbmMask, WriteLength);
  finally
    DeleteObject(IconInfo.hbmColor);
    DeleteObject(IconInfo.hbmMask);
  end
  else
    RaiseLastOSError;
end;

procedure SaveIconToFile(Icon: HICON; const FileName: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    WriteIcon(Stream, Icon, False);
  finally
    Stream.Free;
  end;
end;
{$ENDIF VCL}

{$IFDEF Bitmap32}
procedure Transform(Dst, Src: TJclBitmap32; SrcRect: TRect;
  Transformation: TJclTransformation);
var
  SrcBlend: Boolean;
  C, SrcAlpha: TColor32;
  R, DstRect: TRect;
  Pixels: PColor32Array;
  I, J, X, Y: Integer;

  function GET_S256(X, Y: Integer; out C: TColor32): Boolean;
  var
    flrx, flry, celx, cely: Longword;
    C1, C2, C3, C4: TColor32;
    P: PColor32;
  begin
    flrx := X and $FF;
    flry := Y and $FF;

    X := Sar(X,8);
    Y := Sar(Y,8);

    celx := flrx xor 255;
    cely := flry xor 255;

    if (X >= SrcRect.Left) and (X < SrcRect.Right - 1) and
      (Y >= SrcRect.Top) and (Y < SrcRect.Bottom - 1) then
    begin
      // everything is ok take the four values and interpolate them
      P := Src.PixelPtr[X, Y];
      C1 := P^;
      Inc(P);
      C2 := P^;
      Inc(P, Src.Width);
      C4 := P^;
      Dec(P);
      C3 := P^;
      C := CombineReg(CombineReg(C1, C2, celx), CombineReg(C3, C4, celx), cely);
      Result := True;
    end
    else
    begin
      // (X,Y) coordinate is out of the SrcRect, do not interpolate
      C := 0; // just write something to disable compiler warnings
      Result := False;
    end;
  end;
begin
  SrcBlend := (Src.DrawMode = dmBlend);
  SrcAlpha := Src.MasterAlpha; // store it into a local variable

  // clip SrcRect
  R := SrcRect;
  IntersectRect(SrcRect, R, Rect(0, 0, Src.Width, Src.Height));
  if IsRectEmpty(SrcRect) then
    Exit;

  // clip DstRect
  R := Transformation.GetTransformedBounds(SrcRect);
  IntersectRect(DstRect, R, Rect(0, 0, Dst.Width, Dst.Height));
  if IsRectEmpty(DstRect) then
    Exit;

  try
    if Src.StretchFilter <> sfNearest then
      for J := DstRect.Top to DstRect.Bottom - 1 do
      begin
        Pixels := Dst.ScanLine[J];
        for I := DstRect.Left to DstRect.Right - 1 do
        begin
          Transformation.Transform256(I, J, X, Y);
          if GET_S256(X, Y, C) then
            if SrcBlend then
              BlendMemEx(C, Pixels[I], SrcAlpha)
            else
              Pixels[I] := C;
        end;
      end
    else // nearest filter
      for J := DstRect.Top to DstRect.Bottom - 1 do
      begin
        Pixels := Dst.ScanLine[J];
        for I := DstRect.Left to DstRect.Right - 1 do
        begin
          Transformation.Transform(I, J, X, Y);
          if (X >= SrcRect.Left) and (X < SrcRect.Right) and
            (Y >= SrcRect.Top) and (Y < SrcRect.Bottom) then
          begin
            if SrcBlend then
              BlendMemEx(Src.Pixel[X, Y], Pixels[I], SrcAlpha)
            else
              Pixels[I] := Src.Pixel[X, Y];
          end;
        end;
      end;
  finally
    EMMS;
  end;
  Dst.Changed;
end;

procedure SetBorderTransparent(ABitmap: TJclBitmap32; ARect: TRect);
var
  I: Integer;
begin
  if TestClip(ARect.Left, ARect.Right, ABitmap.Width) and
    TestClip(ARect.Top, ARect.Bottom, ABitmap.Height) then
  begin
    ABitmap.Changing;

    for I := ARect.Left to ARect.Right do
      ABitmap[I, ARect.Top] := ABitmap[I, ARect.Top] and $00FFFFFF;

    for I := ARect.Left to ARect.Right do
      ABitmap[I, ARect.Bottom] := ABitmap[I, ARect.Bottom] and $00FFFFFF;

    if ARect.Bottom > ARect.Top + 1 then
      for I := ARect.Top + 1 to ARect.Bottom - 1 do
      begin
        ABitmap[ARect.Left, I] := ABitmap[ARect.Left, I] and $00FFFFFF;
        ABitmap[ARect.Right, I] := ABitmap[ARect.Right, I] and $00FFFFFF;
      end;

    ABitmap.Changed;
  end;
end;
{$ENDIF Bitmap32}

{$IFDEF VCL}
function CreateRegionFromBitmap(Bitmap: TBitmap; RegionColor: TColor;
  RegionBitmapMode: TJclRegionBitmapMode): HRGN;
var
  FBitmap: TBitmap;
  X, Y: Integer;
  StartX: Integer;
  Region: HRGN;
begin
  Result := 0;

  if Bitmap = nil then
    EJclGraphicsError.CreateRes(@RsNoBitmapForRegion);

  if (Bitmap.Width = 0) or (Bitmap.Height = 0) then
    Exit;

  FBitmap := TBitmap.Create;
  try
    FBitmap.Assign(Bitmap);

    for Y := 0 to FBitmap.Height - 1 do
    begin
      X := 0;
      while X < FBitmap.Width do
      begin

        if RegionBitmapMode = rmExclude then
        begin
          while FBitmap.Canvas.Pixels[X,Y] = RegionColor do
          begin
            Inc(X);
            if X = FBitmap.Width then
              Break;
          end;
        end
        else
        begin
          while FBitmap.Canvas.Pixels[X,Y] <> RegionColor do
          begin
            Inc(X);
            if X = FBitmap.Width then
              Break;
          end;
        end;

        if X = FBitmap.Width then
          Break;

        StartX := X;
        if RegionBitmapMode = rmExclude then
        begin
          while FBitmap.Canvas.Pixels[X,Y] <> RegionColor do
          begin
            if X = FBitmap.Width then
              Break;
            Inc(X);
          end;
        end
        else
        begin
          while FBitmap.Canvas.Pixels[X,Y] = RegionColor do
          begin
            if X = FBitmap.Width then
              Break;
            Inc(X);
          end;
        end;

        if Result = 0 then
          Result := CreateRectRgn(StartX, Y, X, Y + 1)
        else
        begin
          Region := CreateRectRgn(StartX, Y, X, Y + 1);
          if Region <> 0 then
          begin
            CombineRgn(Result, Result, Region, RGN_OR);
            DeleteObject(Region);
          end;
        end;
      end;
    end;
  finally
    FBitmap.Free;
  end;
end;

procedure ScreenShot(bm: TBitmap; Left, Top, Width, Height: Integer; Window: HWND); overload;
var
  WinDC: HDC;
  Pal: TMaxLogPalette;
begin
  bm.Width := Width;
  bm.Height := Height;

  // Get the HDC of the window...
  WinDC := GetDC(Window);
  if WinDC = 0 then
    raise EJclGraphicsError.CreateRes(@RsNoDeviceContextForWindow);

  // Palette-device?
  if (GetDeviceCaps(WinDC, RASTERCAPS) and RC_PALETTE) = RC_PALETTE then
  begin
    FillChar(Pal, SizeOf(TMaxLogPalette), #0);  // fill the structure with zeros
    Pal.palVersion := $300;                     // fill in the palette version

    // grab the system palette entries...
    Pal.palNumEntries := GetSystemPaletteEntries(WinDC, 0, 256, Pal.palPalEntry);
    if Pal.PalNumEntries <> 0 then
      bm.Palette := CreatePalette(PLogPalette(@Pal)^);
  end;

  // copy from the screen to our bitmap...
  BitBlt(bm.Canvas.Handle, 0, 0, Width, Height, WinDC, Left, Top, SRCCOPY);

  ReleaseDC(Window, WinDC);        // finally, relase the DC of the window
end;

procedure ScreenShot(bm: TBitmap; IncludeTaskBar: Boolean = True); overload;
var
  R: TRect;
begin
  if In