_graphics.pas

East make Tray Icon in delphi

      if (Bias > 0) and (Bias <> 1) then
      begin
        Bias := 1 / Bias;
        for K := 0 to High(Result[I]) do
          Result[I][K].Weight := Round(Result[I][K].Weight * Bias);
      end;
    end;
  end
  else
  begin
    FilterWidth := 1 / FilterWidth;
    Scale := 1 / Scale;
    for I := 0 to DstWidth - 1 do
    begin
      Center := I * Scale;
      Left := Floor(Center - FilterWidth);
      Right := Ceil(Center + FilterWidth);
      for J := Left to Right do
      begin
        Weight := Round(255 * Filter(Center - J));
        if Weight <> 0 then
        begin
          K := Length(Result[I]);
          SetLength(Result[I], K + 1);
          Result[I][K].Pos := Constrain(J + SrcFrom, 0, SrcWidth - 1);
          Result[I][K].Weight := Weight;
        end;
      end;
    end;
  end;
end;

// Bitmap Functions
// Scales the source graphic to the given size (NewWidth, NewHeight) and stores the Result in Target.
// Filter describes the filter function to be applied and Radius the size of the filter area.
// Is Radius = 0 then the recommended filter area will be used (see DefaultFilterRadius).

procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
  Radius: Single; Source: TGraphic; Target: TBitmap);
var
  Temp: TBitmap;
begin
  if Source.Empty then
    Exit;               // do nothing

  if Radius = 0 then
    Radius := DefaultFilterRadius[Filter];

  Temp := TBitmap.Create;
  try
    // To allow Source = Target, the following assignment needs to be done initially
    Temp.Assign(Source);
    Temp.PixelFormat := pf32bit;

    Target.FreeImage;
    Target.PixelFormat := pf32bit;
    Target.Width := NewWidth;
    Target.Height := NewHeight;

    {$IFDEF VCL}if not Target.Empty then{$ENDIF VCL}
      DoStretch(FilterList[Filter], Radius, Temp, Target);
  finally
    Temp.Free;
  end;
end;

procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
  Radius: Single; Bitmap: TBitmap);
begin
  Stretch(NewWidth, NewHeight, Filter, Radius, Bitmap, Bitmap);
end;

{$IFDEF Bitmap32}
procedure StretchNearest(Dst: TJclBitmap32; DstRect: TRect;
  Src: TJclBitmap32; SrcRect: TRect; CombineOp: TDrawMode);
var
  SrcW, SrcH, DstW, DstH: Integer;
  MapX, MapY: array of Integer;
  DstX, DstY: Integer;
  R: TRect;
  I, J, Y: Integer;
  P: PColor32;
  MstrAlpha: TColor32;
begin
  // check source and destination
  CheckBitmaps(Dst, Src);
  if not CheckSrcRect(Src, SrcRect) then
    Exit;
  if IsRectEmpty(DstRect) then
    Exit;
  IntersectRect(R, DstRect, Rect(0, 0, Dst.Width, Dst.Height));
  if IsRectEmpty(R) then
    Exit;
  if (CombineOp = dmBlend) and (Src.MasterAlpha = 0) then
    Exit;

  SrcW := SrcRect.Right - SrcRect.Left;
  SrcH := SrcRect.Bottom - SrcRect.Top;
  DstW := DstRect.Right - DstRect.Left;
  DstH := DstRect.Bottom - DstRect.Top;
  DstX := DstRect.Left;
  DstY := DstRect.Top;

  // check if we actually have to stretch anything
  if (SrcW = DstW) and (SrcH = DstH) then
  begin
    BlockTransfer(Dst, DstX, DstY, Src, SrcRect, CombineOp);
    Exit;
  end;

  // build X coord mapping table
  SetLength(MapX, DstW);
  SetLength(MapY, DstH);

  try
    for I := 0 to DstW - 1 do
      MapX[I] := I * (SrcW) div (DstW) + SrcRect.Left;

    // build Y coord mapping table
    for J := 0 to DstH - 1 do
      MapY[J] := J * (SrcH) div (DstH) + SrcRect.Top;

    // transfer pixels
    case CombineOp of
      dmOpaque:
        for J := R.Top to R.Bottom - 1 do
        begin
          Y := MapY[J - DstY];
          P := Dst.PixelPtr[R.Left, J];
          for I := R.Left to R.Right - 1 do
          begin
            P^ := Src[MapX[I - DstX], Y];
            Inc(P);
          end;
        end;
      dmBlend:
        begin
          MstrAlpha := Src.MasterAlpha;
          if MstrAlpha = 255 then
            for J := R.Top to R.Bottom - 1 do
            begin
              Y := MapY[J - DstY];
              P := Dst.PixelPtr[R.Left, J];
              for I := R.Left to R.Right - 1 do
              begin
                BlendMem(Src[MapX[I - DstX], Y], P^);
                Inc(P);
              end;
            end
          else // Master Alpha is in [1..254] range
            for J := R.Top to R.Bottom - 1 do
            begin
              Y := MapY[J - DstY];
              P := Dst.PixelPtr[R.Left, J];
              for I := R.Left to R.Right - 1 do
              begin
                BlendMemEx(Src[MapX[I - DstX], Y], P^, MstrAlpha);
                Inc(P);
              end;
            end;
      end;
    end;
  finally
    EMMS;
    MapX := nil;
    MapY := nil;
  end;
end;

procedure BlockTransfer(Dst: TJclBitmap32; DstX: Integer; DstY: Integer; Src: TJclBitmap32;
  SrcRect: TRect; CombineOp: TDrawMode);
var
  SrcX, SrcY: Integer;
  S, D: TRect;
  J, N: Integer;
  Ps, Pd: PColor32;
  MstrAlpha: TColor32;
begin
  CheckBitmaps(Src, Dst);
  if CombineOp = dmOpaque then
  begin
    BitBlt(Dst.Handle, DstX, DstY, SrcRect.Right - SrcRect.Left,
      SrcRect.Bottom - SrcRect.Top, Src.Handle, SrcRect.Left, SrcRect.Top,
      SRCCOPY);
    Exit;
  end;

  if Src.MasterAlpha = 0 then
    Exit;

  // clip the rectangles with bitmap boundaries
  SrcX := SrcRect.Left;
  SrcY := SrcRect.Top;
  IntersectRect(S, SrcRect, Rect(0, 0, Src.Width, Src.Height));
  OffsetRect(S, DstX - SrcX, DstY - SrcY);
  IntersectRect(D, S, Rect(0, 0, Dst.Width, Dst.Height));
  if IsRectEmpty(D) then
    Exit;

  MstrAlpha := Src.MasterAlpha;
  N := D.Right - D.Left;

  try
    if MstrAlpha = 255 then
      for J := D.Top to D.Bottom - 1 do
      begin
        Ps := Src.PixelPtr[D.Left + SrcX - DstX, J + SrcY - DstY];
        Pd := Dst.PixelPtr[D.Left, J];
        BlendLine(Ps, Pd, N);
      end
    else
      for J := D.Top to D.Bottom - 1 do
      begin
        Ps := Src.PixelPtr[D.Left + SrcX - DstX, J + SrcY - DstY];
        Pd := Dst.PixelPtr[D.Left, J];
        BlendLineEx(Ps, Pd, N, MstrAlpha);
      end;
  finally
    EMMS;
  end;
end;

procedure StretchTransfer(Dst: TJclBitmap32; DstRect: TRect; Src: TJclBitmap32; SrcRect: TRect;
  StretchFilter: TStretchFilter; CombineOp: TDrawMode);
var
  SrcW, SrcH, DstW, DstH: Integer;
  MapX, MapY: TMappingTable;
  DstX, DstY: Integer;
  R: TRect;
  I, J, X, Y: Integer;
  P: PColor32;
  ClusterX, ClusterY: TCluster;
  C, Wt, Cr, Cg, Cb, Ca: Integer;
  MstrAlpha: TColor32;
begin
  // make compiler happy
  MapX := nil;
  MapY := nil;
  ClusterX := nil;
  ClusterY := nil;

  if StretchFilter = sfNearest then
  begin
    StretchNearest(Dst, DstRect, Src, SrcRect, CombineOp);
    Exit;
  end;

  // check source and destination
  CheckBitmaps(Dst, Src);
  if not CheckSrcRect(Src, SrcRect) then
    Exit;
  if IsRectEmpty(DstRect) then
    Exit;
  IntersectRect(R, DstRect, Rect(0, 0, Dst.Width, Dst.Height));
  if IsRectEmpty(R) then
    Exit;
  if (CombineOp = dmBlend) and (Src.MasterAlpha = 0) then
    Exit;

  SrcW := SrcRect.Right - SrcRect.Left;
  SrcH := SrcRect.Bottom - SrcRect.Top;
  DstW := DstRect.Right - DstRect.Left;
  DstH := DstRect.Bottom - DstRect.Top;
  DstX := DstRect.Left;
  DstY := DstRect.Top;
  MstrAlpha := Src.MasterAlpha;

  // check if we actually have to stretch anything
  if (SrcW = DstW) and (SrcH = DstH) then
  begin
    BlockTransfer(Dst, DstX, DstY, Src, SrcRect, CombineOp);
    Exit;
  end;

  // mapping tables
  MapX := BuildMappingTable(DstW, SrcRect.Left, SrcW, StretchFilter);
  MapY := BuildMappingTable(DstH, SrcRect.Top, SrcH, StretchFilter);
  try
    ClusterX := nil;
    ClusterY := nil;
    if (MapX = nil) or (MapY = nil) then
      Exit;

    // transfer pixels
    for J := R.Top to R.Bottom - 1 do
    begin
      ClusterY := MapY[J - DstY];
      P := Dst.PixelPtr[R.Left, J];
      for I := R.Left to R.Right - 1 do
      begin
        ClusterX := MapX[I - DstX];

        // reset color accumulators
        Ca := 0;
        Cr := 0;
        Cg := 0;
        Cb := 0;

        // now iterate through each cluster
        for Y := 0 to High(ClusterY) do
          for X := 0 to High(ClusterX) do
          begin
            C := Src[ClusterX[X].Pos, ClusterY[Y].Pos];
            Wt := ClusterX[X].Weight * ClusterY[Y].Weight;
            Inc(Ca, C shr 24 * Wt);
            Inc(Cr, (C and $00FF0000) shr 16 * Wt);
            Inc(Cg, (C and $0000FF00) shr 8 * Wt);
            Inc(Cb, (C and $000000FF) * Wt);
          end;
        Ca := Ca and $00FF0000;
        Cr := Cr and $00FF0000;
        Cg := Cg and $00FF0000;
        Cb := Cb and $00FF0000;
        C := (Ca shl 8) or Cr or (Cg shr 8) or (Cb shr 16);

        // combine it with the background
        case CombineOp of
          dmOpaque:
            P^ := C;
          dmBlend:
            BlendMemEx(C, P^, MstrAlpha);
        end;
        Inc(P);
      end;
    end;
  finally
    EMMS;
    MapX := nil;
    MapY := nil;
  end;
end;
{$ENDIF Bitmap32}

{$IFDEF MSWINDOWS}
procedure DrawBitmap(DC: HDC; Bitmap: HBITMAP; X, Y, Width, Height: Integer);
var
  MemDC: HDC;
  OldBitmap: HBITMAP;
begin
  MemDC := CreateCompatibleDC(DC);
  OldBitmap := SelectObject(MemDC, Bitmap);
  BitBlt(DC, X, Y, Width, Height, MemDC, 0, 0, SRCCOPY);
  SelectObject(MemDC, OldBitmap);
  DeleteObject(MemDC);
end;
{$ENDIF MSWINDOWS}

{$IFDEF VCL}
{ TODO : remove VCL-dependency by replacing pf24bit by pf32bit }

function GetAntialiasedBitmap(const Bitmap: TBitmap): TBitmap;
type
  TByteArray = array [0..MaxLongint - 1] of Byte;
  PByteArray = ^TByteArray;
var
  Antialias: TBitmap;
  X, Y: Integer;
  Line1, Line2, Line: PByteArray;
begin
 Assert(Bitmap <> nil);
 if Bitmap.PixelFormat <> pf24bit then
   Bitmap.PixelFormat := pf24bit;
 Antialias := TBitmap.Create;
 with Bitmap do
 begin
   Antialias.PixelFormat := pf24bit;
   Antialias.Width := Width div 2;
   Antialias.Height := Height div 2;
   for Y := 0 to Antialias.Height - 1 do
   begin
     Line1 := ScanLine[Y * 2];
     Line2 := ScanLine[Y * 2 + 1];
     Line := Antialias.ScanLine[Y];
     for X := 0 to Antialias.Width - 1 do
     begin
       Line[X * 3] := (Integer(Line1[X * 6]) + Integer(Line2[X * 6]) +
         Integer(Line1[X * 6 + 3]) + Integer(Line2[X * 6 + 3])) div 4;
       Line[X * 3 + 1] := (Integer(Line1[X * 6 + 1]) + Integer(Line2[X * 6 + 1]) +
         Integer(Line1[X * 6 + 3 + 1]) + Integer(Line2[X * 6 + 3 + 1])) div 4;
       Line[X * 3 + 2] := (Integer(Line1[X * 6 + 2]) + Integer(Line2[X * 6 + 2]) +
         Integer(Line1[X * 6 + 3 + 2]) + Integer(Line2[X * 6 + 3 + 2])) div 4;
     end;
    end;
  end;
  Result := Antialias;
end;

procedure JPegToBitmap(const FileName: string);
var
  Bitmap: TBitmap;
  JPeg: TJPegImage;
begin
  Bitmap := nil;
  JPeg := nil;
  try
    JPeg := TJPegImage.Create;
    JPeg.LoadFromFile(FileName);
    Bitmap := TBitmap.Create;
    Bitmap.Assign(JPeg);
    Bitmap.SaveToFile(ChangeFileExt(FileName, LoadResString(@RsBitmapExtension)));
  finally
    FreeAndNil(Bitmap);
    FreeAndNil(JPeg);
  end;
end;

procedure BitmapToJPeg(const FileName: string);
var
  Bitmap: TBitmap;
  JPeg: TJPegImage;
begin
  Bitmap := nil;
  JPeg := nil;
  try
    Bitmap := TBitmap.Create;
    Bitmap.LoadFromFile(FileName);
    JPeg := TJPegImage.Create;
    JPeg.Assign(Bitmap);
    JPeg.SaveToFile(ChangeFileExt(FileName, LoadResString(@RsJpegExtension)));
  finally