sgraphutils.pas

AlphaControls是一个Delphi标准控件的集合

    0: begin
      FillDC(CanvasDst, Rect(PDst.x, PDst.y, PDst.x + WidthOf(RSrc), PDst.y + HeightOf(RSrc)), Color);
    end
    else begin
      Bmp := TBitmap.Create; Bmp.PixelFormat := pf24bit; Bmp.Width := WidthOf(rSrc); Bmp.Height := HeightOf(rSrc);
      TempBmp := TBitmap.Create; TempBmp.PixelFormat := pf24bit; TempBmp.Width := Bmp.Width; TempBmp.Height := Bmp.Height;
      Blur := Mini(Mini(TempBmp.Width div 2, TempBmp.Height div 2), Blur);

      RValue := 255 * Transparency div 100;
      SavedBmp := SaveDC(Bmp.Canvas.Handle);
      try

        bitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, CanvasSrc.Handle, RSrc.Left, RSrc.Top, SrcCopy);

        delta := (255 - RValue) / (Blur + 1);
        // Prepare mask
        TColor(c) := clWhite;
        TempBmp.Canvas.Pen.Style := psClear;
        TempBmp.Canvas.Brush.Style := bsSolid;
        TempBmp.Canvas.Brush.Color := clWhite;
        case Shape of
          ssRectangle: begin
            for i := 0 to Blur do begin
              c.R := RValue + Round(delta * (Blur - i));
              c.G := c.R;
              c.B := c.R;
              TempBmp.Canvas.Brush.Color := TColor(c);
              TempBmp.Canvas.RoundRect(i, i, TempBmp.Width - i + 1, TempBmp.Height - i + 1, Blur + Radius, Blur + Radius);
            end;
          end;
          ssEllipse: begin
            for i := 0 to Blur do begin
              c.R := RValue + Round(delta * (Blur - i));
              c.G := c.R;
              c.B := c.R;
              TempBmp.Canvas.Brush.Color := TColor(c);
              TempBmp.Canvas.Ellipse(Rect(i, i, TempBmp.Width - i, TempBmp.Height - i));
            end;
          end;
        end;

        BlendBmpByMask(Bmp, TempBmp, TsColor(Color));

        // Copy back
        BitBlt(CanvasDst, PDst.x, PDst.y, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);  // ???

      finally
        RestoreDC(Bmp.Canvas.Handle, SavedBmp);

        FreeAndNil(Bmp);
        FreeAndNil(TempBmp);
      end
    end;
  end;
  finally
    RestoreDC(CanvasSrc.Handle, SavedSrc);
    RestoreDC(CanvasDst, SavedDst);
  end;
end;

procedure FadeBmp(FadedBmp: TBitMap; aRect: TRect; Transparency: integer; Color: TsColor; Blur, Radius : integer);
var
  Bmp, TempBmp : Graphics.TBitmap;
  r: TRect;
  delta: real;
  RValue, i : integer;
  c : TsColor;
begin
  Bmp := Graphics.TBitmap.Create; Bmp.PixelFormat := pf24bit; Bmp.Width := aRect.Right - aRect.Left; Bmp.Height := aRect.Bottom - aRect.Top;
  TempBmp := Graphics.TBitmap.Create; TempBmp.PixelFormat := pf24bit; TempBmp.Width := Bmp.Width; TempBmp.Height := Bmp.Height;
  Blur := Mini(Mini(TempBmp.Width div 2, TempBmp.Height div 2), Blur);
  Radius := Mini(Mini(TempBmp.Width div 2, TempBmp.Height div 2), Radius);

  RValue := 255 * Transparency div 100;

  // Copy faded area in Ftb
  bitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, FadedBmp.Canvas.Handle, aRect.Left, aRect.Top, SrcCopy);

  TempBmp.Canvas.Pen.Style := psClear;
  TempBmp.Canvas.Brush.Style := bsSolid;
  TempBmp.Canvas.Brush.Color := clWhite;

  delta := (255 - RValue) / (Blur + 1);
  // Prepare template
  TColor(c) := clWhite;
  for i := 0 to Blur do begin

    r := Rect(i, i, TempBmp.Width - i, TempBmp.Height - i);
    TempBmp.Canvas.Brush.Color := TColor(c);
    TempBmp.Canvas.RoundRect(i, i, TempBmp.Width - i, TempBmp.Height - i, Radius, Radius);

    c.R := RValue + Round(delta * (Blur - i));
    c.G := c.R;
    c.B := c.R;
  end;
  r := Rect(Blur, Blur, TempBmp.Width - Blur, TempBmp.Height - Blur);


  TempBmp.Canvas.Pen.Style := psClear;
  TempBmp.Canvas.Brush.Style := bsSolid;

  TempBmp.Canvas.Brush.Color := TColor(c);
  TempBmp.Canvas.RoundRect(r.Left, R.Top, R.Right, R.Bottom, Blur, Blur);

  BlendBmpByMask(Bmp, TempBmp, Color);

  // Copy back
  BitBlt(FadedBmp.Canvas.Handle, aRect.Left, aRect.Top, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
  FreeAndNil(Bmp);
  FreeAndNil(TempBmp);
end;

{
procedure SumBitmapsTrans(var SrcBmp, MskBmp: TBitMap; Color, TransColor : TsColor); // ????
var
  S1, S2 : PRGBArray;
  X, Y, sw, sh: Integer;
begin
  Alert('SumBitmapsTrans used!');
  Color.C := ColorToRGB(Color.C);
  TransColor.C := ColorToRGB(TransColor.C);

  if SrcBmp.Height <> MskBmp.Height then Exit;
  if SrcBmp.Width <> MskBmp.Width then Exit;
  if SrcBmp.Height < 1 then Exit;
  if SrcBmp.Width < 1 then Exit;
  sw := SrcBmp.Width - 1;
  sh := SrcBmp.Height - 1;
  try
    for Y := 0 to sh do begin
      S1 := SrcBmp.ScanLine[Y];
      S2 := MskBmp.ScanLine[Y];
      for X := 0 to sw do begin
        if (S1[X].B <> TransColor.B) or (S1[X].G <> TransColor.G) or (S1[X].R <> TransColor.R) then begin
          S1[X].R := Min(Color.R + S2[X].R * (S1[X].R - Color.R) div 255, 255);
          S1[X].G := Min(Color.G + S2[X].G * (S1[X].G - Color.G) div 255, 255);
          S1[X].B := Min(Color.B + S2[X].B * (S1[X].B - Color.B) div 255, 255);
        end;
      end
    end;
  except
  end;
end;
}
procedure BlendTransRectangle(Dst: TBitmap; X, Y: integer; Src: TBitmap; aRect: TRect; Blend: real; TransColor: TsColor);
var
  dx, dy, h, w, width, height, curX, nextX : integer;
  S, D : PRGBArray;
begin
  if aRect.Top < 0 then aRect.Top := 0;
  if aRect.Left < 0 then aRect.Left := 0;
  if aRect.Bottom > Src.Height - 1 then aRect.Bottom := Src.Height - 1;
  if aRect.Right > Src.Width - 1 then aRect.Right := Src.Width - 1;

  try

    h := HeightOf(aRect);
    w := WidthOf(aRect);
    width := Dst.Width - 1;
    height := Dst.Height - 1;

    for dy := 0 to h do begin

      if (dy + Y > height) or (dy + Y < 0) then break;
      S := Src.ScanLine[dy + aRect.Top];
      D := Dst.ScanLine[dy + Y];

      for dx := 0 to w do begin
        nextX := dx + X;
        if (nextX > Width) or (nextX < 0) then break;
        CurX := dX + aRect.Left;

        // Optimized by Serge / 23.11.2003
        if TransColor.A <> 255 then begin
          if (S[CurX].B <> TransColor.B) or (S[CurX].G <> TransColor.G) or (S[CurX].R <> TransColor.R) then begin
            D[nextX].R := round(S[CurX].R - Blend * (S[CurX].R - D[nextX].R));
            D[nextX].G := round(S[CurX].G - Blend * (S[CurX].G - D[nextX].G));
            D[nextX].B := round(S[CurX].B - Blend * (S[CurX].B - D[nextX].B));
          end;
        end
        else begin
          D[nextX].R := round(S[CurX].R - Blend * (S[CurX].R - D[nextX].R));
          D[nextX].G := round(S[CurX].G - Blend * (S[CurX].G - D[nextX].G));
          D[nextX].B := round(S[CurX].B - Blend * (S[CurX].B - D[nextX].B));
        end;
      end;
    end;
  except
  end;
end;

procedure BlendTransBitmap(Bmp: TBitmap; Blend: real; Color, TransColor: TsColor);
var
  dx, dy : integer;
  S : PRGBArray;
  w, h : integer;
begin
  w := Bmp.Width - 1;
  h := Bmp.Height - 1;
  try
    for dy := 0 to h do begin
      S := Bmp.ScanLine[dy];
      for dx := 0 to w do begin
        if (S[dX].B <> TransColor.B) or (S[dX].G <> TransColor.G) or (S[dX].R <> TransColor.R) then begin
{ // Changed by Dima 04.04.04
          S[dX].R := round(S[dX].R - Blend * (S[dX].R - Color.R));
          S[dX].G := round(S[dX].G - Blend * (S[dX].G - Color.G));
          S[dX].B := round(S[dX].B - Blend * (S[dX].B - Color.B));
}

          S[dX].R := round((S[dX].R - Color.R) * Blend + Color.R);
          S[dX].G := round((S[dX].G - Color.G) * Blend + Color.G);
          S[dX].B := round((S[dX].B - Color.B) * Blend + Color.B);
//        Result := Round((Src1 - Src2) * PercentOfSrc1 + Src2); PercentOfSrc1 is a real value between 0 and 1
        end;
      end;
    end;
  except
  end;
end;

procedure BlendBmpByMask(SrcBmp, MskBmp: Graphics.TBitMap; BlendColor : TsColor);
var
  S1, S2 : PRGBArray;
  X, Y: Integer;
  minW, minH : integer;
  r, g, b : integer;
  function Div256(X: word): byte; asm
    MOV AX, X
    MOV AL, AH
    MOV AH, 0
  end;
begin
  if (SrcBmp.Width <> MskBmp.Width) or (SrcBmp.Height <> MskBmp.Height) then Exit;
  minH := SrcBmp.Height - 1;
  minW := SrcBmp.Width - 1;
  r := BlendColor.R * 255;
  g := BlendColor.G * 255;
  b := BlendColor.B * 255;
  for Y := 0 to minH do begin
    S1 := SrcBmp.ScanLine[Y];
    S2 := MskBmp.ScanLine[Y];
    for X := 0 to minW do begin
      S1[X].R := Div256((S1[X].R - BlendColor.R) * S2[X].R + r);
      S1[X].G := Div256((S1[X].G - BlendColor.G) * S2[X].G + g);
      S1[X].B := Div256((S1[X].B - BlendColor.B) * S2[X].B + b);
    end
  end;
end;

procedure SumBitmaps(SrcBmp, MskBmp: Graphics.TBitMap; Color : TsColor);
var
  S1, S2 : PRGBArray;
  X, Y: Integer;
  minW, minH : integer;
  r : real;
begin
  if (SrcBmp.Width <> MskBmp.Width) or (SrcBmp.Height <> MskBmp.Height) then Exit;
  minH := SrcBmp.Height - 1;
  minW := SrcBmp.Width - 1;
  r := Color.R / 256;
  for Y := 0 to minH do begin
    S1 := SrcBmp.ScanLine[Y];
    S2 := MskBmp.ScanLine[Y];
    for X := 0 to minW do begin
      // Optimized by Serge / 23.11.2003
      S1[X].R := Round((S1[X].R - S2[X].R) * r + S2[X].R);
      S1[X].G := Round((S1[X].G - S2[X].G) * r + S2[X].G);
      S1[X].B := Round((S1[X].B - S2[X].B) * r + S2[X].B);
    end
  end;
end;

procedure SumBmpRect(DstBmp, SrcBmp: Graphics.TBitMap; Color : TsColor; SrcRect : TRect; DstPoint : TPoint);
var
  S1, S2 : PRGBArray;
  X, Y: Integer;
  minW, minH : integer;
  r : real;
begin
  minH := HeightOf(SrcRect);
  minH := min(SrcBmp.Height - SrcRect.Top - 1, minH);
  minW := WidthOf(SrcRect);
  minW := min(SrcBmp.Width - SrcRect.Left - 1, minW);
  r := (Color.R + Color.G + Color.B) / 768;
  for Y := 0 to minH do begin
    if DstPoint.y + Y > DstBmp.Height - 1 then begin
      Color.R := 0;
      Continue;
    end;
    if SrcRect.Top + Y > SrcBmp.Height - 1 then begin
      Color.R := 0;
      Continue;
    end;
    S1 := DstBmp.ScanLine[DstPoint.y + Y];
    S2 := SrcBmp.ScanLine[SrcRect.Top + Y];
    for X := 0 to minW do begin
      // Optimized by Serge / 23.11.2003
      S1[DstPoint.x + X].R := Round((S1[DstPoint.x + X].R - S2[SrcRect.Left + X].R) * r + S2[SrcRect.Left + X].R);
      S1[DstPoint.x + X].G := Round((S1[DstPoint.x + X].G - S2[SrcRect.Left + X].G) * r + S2[SrcRect.Left + X].G);
      S1[DstPoint.x + X].B := Round((S1[DstPoint.x + X].B - S2[SrcRect.Left + X].B) * r + S2[SrcRect.Left + X].B);
    end
  end;
end;

procedure CopyByMask(R1, R2 : TRect; Bmp1, Bmp2 : TBitmap; CI : TCacheInfo);
var
  S1, S2, M : PRGBArray;
  X, Y, h, w: Integer;
  c : TsRGB;
  col : TsColor;
  function Div256(X: word): byte; asm
    MOV AX, X
    MOV AL, AH
    MOV AH, 0
  end;
begin
  h := Min(HeightOf(R1), HeightOf(R2));
  h := Min(h, Bmp1.Height - R1.Top);
  h := Min(h, Bmp2.Height - R2.Top) - 1; //!!!
  if h < 0 then Exit;
  w := Min(WidthOf(R1), WidthOf(R2));
  w := Min(w, Bmp1.Width - R1.Left);
  w := Min(w, Bmp2.Width - R2.Left) - 1;//!!!
  if w < 0 then Exit;
  if R1.Left < R2.Left then begin
    if (R1.Left < 0) then begin
      inc(R2.Left, - R1.Left);
      dec(h, - R1.Left);
      R1.Left := 0;
    end;
  end
  else begin
    if (R2.Left < 0) then begin
      inc(R1.Left, - R2.Left);
      dec(h, - R2.Left);
      R2.Left := 0;
    end;
  end;
  if R1.Top < R2.Top then begin
    if (R1.Top < 0) then begin
      inc(R2.Top, - R1.Top);
      dec(h, - R1.Top);
      R1.Top := 0;
    end;
  end
  else begin
    if (R2.Top < 0) then begin
      inc(R1.Top, - R2.Top);
      dec(h, - R2.Top);
      R2.Top := 0;
    end;
  end;

  try
    if not CI.Ready then begin
      for Y := 0 to h do begin
        S1 := Bmp1.ScanLine[R1.Top + Y];
        S2 := Bmp2.ScanLine[R2.Top + Y];
        M  := Bmp2.ScanLine[R2.Top + Bmp2.Height div 2 + Y];
        for X := 0 to w do begin
          S1[R1.Left + X].R := Div256((S1[R1.Left + X].R - S2[R2.Left + X].R) * M[R2.Left + X].R + S2[R2.Left + X].R * 256);
          S1[R1.Left + X].G := Div256((S1[R1.Left + X].G - S2[R2.Left + X].G) * M[R2.Left + X].G + S2[R2.Left + X].G * 256);
          S1[R1.Left + X].B := Div256((S1[R1.Left + X].B - S2[R2.Left + X].B) * M[R2.Left + X].B + S2[R2.Left + X].B * 256);
        end;
      end;
    end
    else begin
      col.C := clFuchsia;
      // clFuchsia - transparent
      c.R := 255;//col.R;
      c.G := 0;//col.G;
      c.B := 255;//col.B;
      for Y := 0 to h do begin
        S1 := Bmp1.ScanLine[R1.Top + Y];
        S2 := Bmp2.ScanLine[R2.Top + Y];
        M  := Bmp2.ScanLine[R2.Top + Bmp2.Height div 2 + Y];
        for X := 0 to w do begin
          if (S2[R2.Left + X].R <> c.R) or (S2[R2.Left + X].G <> c.G) or (S2[R2.Left + X].B <> c.B) then begin
            S1[R1.Left + X].R := Div256((S1[R1.Left + X].R - S2[R2.Left + X].R) * M[R2.Left + X].R