teblndwk.pas

Do your applications look a little boring? Would you like to get spectacular yet easy to use visual

    {$ifndef CLX}
    BitBlt(WorkBmp.Canvas.Handle, 0, 0, WorkBmp.Width, WorkBmp.Height,
      DstBmp.Canvas.Handle, 0, 0, $00AC0744);
    {$else}
    Windows.BitBlt(QPainter_handle(WorkBmp.Canvas.Handle), 0, 0,
      WorkBmp.Width, WorkBmp.Height, QPainter_handle(DstBmp.Canvas.Handle), 0,
      0, $00AC0744);
    {$endif CLX}
    WorkBmp.Canvas.Brush.Bitmap := nil;
  end;

var
  Src,
  Dst,
  Work: PDWordArray;
  Size: Longint;
  ScanLineSize: Integer;
begin
  if BrushBmp <> nil
  then
  begin
    DoFuse(WorkBmp, DstBmp, SrcBmp, BrushBmp, Level);
  end
  else
  begin
    ScanLineSize := GetBytesPerScanline(DstBmp, PixelFormat, 32);

    Src          := PDWordArray(SrcBmp .ScanLine[WorkBmp.Height-1]);
    Dst          := PDWordArray(DstBmp .ScanLine[WorkBmp.Height-1]);
    Work         := PDWordArray(WorkBmp.ScanLine[WorkBmp.Height-1]);
    Size         := ScanLineSize * WorkBmp.Height;

    if(PixelFormat in [pf15bit, pf16bit]) or (not TEProcessorInfo.MMX)
    then TEAlphaBlendAsm(Work, Dst, Src, PixelFormat, Size, Level, EqualQuads,
           False, clNone)
    else TEAlphaBlendMMX(Work, Dst, Src, Size, Level);
  end;
end;

procedure BlendBmp(Bmp, BrushBmp: TBitmap; PixelFormat: TPixelFormat;
  Color: TColor; R: TRect; Level: Integer);

  procedure DoColorBlend_15or16(Work: PWordArray; Color: Word;
    ScanLineSize: Integer; i, BmpWidth, BmpHeight: Longint; R: TRect;
    Level: Longint; PixelFormat: TPixelFormat);

    procedure CalcColorBlend16R(R: TRect; BmpWidth, BmpHeight: Longint;
      var ScanLineSize, i, RWidth, Gap, Limit, W: Longint);
    var
      RightGap: Longint;
    begin
      ScanLineSize := ScanLineSize div 2;
      RWidth       := R.Right - R.Left;
      RightGap     := ScanLineSize - R.Right;
      Gap          := R.Left + RightGap;
      Limit        := -(R.Top * ScanLineSize + RightGap);
      Inc(i, R.Left + ((BmpHeight - R.Bottom) * ScanLineSize));
      W            := i + RWidth;
    end;

    procedure CalcColorArray(ColorBlendArray: PByteArray;
      ColorValue, Level, Bits: Byte);
    var
      LevelAux,
      LevelAux2,
      i: Integer;
    begin
      Inc(ColorValue);

      if Bits = 6
      then
      begin
        LevelAux  := (Level shr 2) + 1;
        LevelAux2 := 64 - LevelAux;

        for i:=0 to 63 do
          ColorBlendArray[i] :=
            (((ColorValue * LevelAux2) + ((i+1) * LevelAux)) div 64) - 1;
      end
      else
      begin
        LevelAux  := (Level shr 3) + 1;
        LevelAux2 := 32 - LevelAux;

        for i:=0 to 31 do
          ColorBlendArray[i] :=
            (((ColorValue * LevelAux2) + ((i+1) * LevelAux)) div 32) - 1;
      end;
    end;

  var
    ColorAux: Byte;
    W,
    RWidth,
    Gap,
    Limit: Longint;
  begin
    ColorAux := Color and $001F;
    if(not ColorBlendArrayInitialized)            or
      (ColorBlendArrayLevel <> Level)             or
      (ColorBlendArrayPixelFormat <> PixelFormat) or
      (ColorAux <> ColorBlendArrayBlueValue)      then
    begin // Recalculate blue lookup table
      ColorBlendArrayBlueValue := ColorAux;
      if PixelFormat = pf16bit
      then CalcColorArray(@ColorBlendArrayBlue, ColorBlendArrayBlueValue, Level, 5)
      else CalcColorArray(@ColorBlendArrayBlue, ColorBlendArrayBlueValue, Level, 5)
    end;

    if PixelFormat = pf16bit
    then ColorAux := (Color shr 5) and $003F
    else ColorAux := (Color shr 5) and $001F;
    if(not ColorBlendArrayInitialized)            or
      (ColorBlendArrayLevel <> Level)             or
      (ColorBlendArrayPixelFormat <> PixelFormat) or
      (ColorAux <> ColorBlendArrayGreenValue)     then
    begin // Recalculate green lookup table
      ColorBlendArrayGreenValue := ColorAux;
      if PixelFormat = pf16bit
      then CalcColorArray(@ColorBlendArrayGreen, ColorBlendArrayGreenValue, Level, 6)
      else CalcColorArray(@ColorBlendArrayGreen, ColorBlendArrayGreenValue, Level, 5)
    end;

    if PixelFormat = pf16bit
    then ColorAux := (Color shr 11) and $001F
    else ColorAux := (Color shr 10) and $001F;
    if(not ColorBlendArrayInitialized)            or
      (ColorBlendArrayLevel <> Level)             or
      (ColorBlendArrayPixelFormat <> PixelFormat) or
      (ColorAux <> ColorBlendArrayRedValue)       then
    begin // Recalculate red lookup table
      ColorBlendArrayRedValue := ColorAux;
      if PixelFormat = pf16bit
      then CalcColorArray(@ColorBlendArrayRed, ColorBlendArrayRedValue, Level, 5)
      else CalcColorArray(@ColorBlendArrayRed, ColorBlendArrayRedValue, Level, 5)
    end;
    ColorBlendArrayInitialized := True;
    ColorBlendArrayLevel       := Level;
    ColorBlendArrayPixelFormat := PixelFormat;

    if EqualRect(R, Rect(0, 0, BmpWidth, BmpHeight))
    then
    begin
      if PixelFormat = pf16bit
      then
      begin
        while i < 0 do
        begin
          Work[i] :=
            (ColorBlendArrayRed  [(Work[i] shr 11) and $001F] shl 11) or
            (ColorBlendArrayGreen[(Work[i] shr  5) and $003F] shl  5) or
            (ColorBlendArrayBlue [ Work[i]         and $001F]);
          Inc(i);
        end;
      end
      else
      begin
        while i < 0 do
        begin
          Work[i] :=
            $8000                                                     or
            (ColorBlendArrayRed  [(Work[i] shr 10) and $001F] shl 10) or
            (ColorBlendArrayGreen[(Work[i] shr  5) and $001F] shl  5) or
            (ColorBlendArrayBlue [ Work[i]         and $001F]);
          Inc(i);
        end;
      end;
    end
    else
    begin
      CalcColorBlend16R(R, BmpWidth, BmpHeight, ScanLineSize, i, RWidth, Gap,
        Limit, W);

      if PixelFormat = pf16bit
      then
      begin
        while i < Limit do
        begin
          while i < W do
          begin
            Work[i] :=
              (ColorBlendArrayRed  [(Work[i] shr 11) and $001F] shl 11) or
              (ColorBlendArrayGreen[(Work[i] shr  5) and $003F] shl  5) or
              (ColorBlendArrayBlue [ Work[i]         and $001F]);
            Inc(i);
          end;
          Inc(i, Gap);
          Inc(W, ScanLineSize);
        end
        end
        else
        begin
        while i < Limit do
        begin
          while i < W do
          begin
            Work[i] :=
              $8000                                                     or
              (ColorBlendArrayRed  [(Work[i] shr 10) and $001F] shl 10) or
              (ColorBlendArrayGreen[(Work[i] shr  5) and $001F] shl  5) or
              (ColorBlendArrayBlue [ Work[i]         and $001F]);
            Inc(i);
          end;
          Inc(i, Gap);
          Inc(W, ScanLineSize);
        end;
      end;
    end;
  end;

  procedure DoColorBlend_24or32(Work: PByteArray; Color: TColor;
    ScanLineSize: Integer; i, BmpWidth, BmpHeight: Longint; R: TRect;
    Level: Longint; PixelFormat: TPixelFormat);

    procedure CalcColorBlendR(R: TRect; BmpWidth, BmpHeight,
      ScanLineSize, BytesPerPixel: Longint;
      var i, RWidth, Gap, Limit, W: Longint);
    var
      RightGap: Longint;
    begin
      RWidth       := (R.Right  - R.Left) * BytesPerPixel;
      RightGap     := ScanLineSize - (R.Right * BytesPerPixel);
      Gap          := (R.Left * BytesPerPixel) + RightGap;
      Limit        := -(R.Top * ScanLineSize + RightGap);
      Inc(i, (R.Left * BytesPerPixel) + ((BmpHeight - R.Bottom) * ScanLineSize));
      W            := i + RWidth;
    end;

    procedure CalcColorArray(ColorBlendArray: PByteArray;
      ColorValue, Level: Word);
    var
      LevelAux: Word;
      i: Byte;
    begin
      Inc(ColorValue);
      Inc(Level);
      LevelAux := 256 - Level;
      for i:=0 to 255 do
        ColorBlendArray[i] :=
          (((ColorValue * LevelAux) + ((i+1) * Level)) div 256) - 1;
    end;

  var
    ColorAux,
    aux: Byte;
    W,
    RWidth,
    Gap,
    Limit: Longint;
    BytesPerPixel: Byte;
    Fast: Boolean;
  begin
    ColorAux := GetRValue(Color);
    if(not ColorBlendArrayInitialized)                         or
      (ColorBlendArrayLevel <> Level)                          or
      {$ifndef CLX}
      (not (ColorBlendArrayPixelFormat in [pf24bit, pf32bit])) or
      {$else}
      (ColorBlendArrayPixelFormat <> pf32bit) or
      {$endif CLX}
      (ColorAux <> ColorBlendArrayRedValue)                    then
    begin // Recalculate red lookup table
      ColorBlendArrayRedValue := ColorAux;
      CalcColorArray(@ColorBlendArrayRed, ColorBlendArrayRedValue, Level);
    end;
    ColorAux := GetGValue(Color);
    if(not ColorBlendArrayInitialized)                         or
      (ColorBlendArrayLevel <> Level)                          or
      {$ifndef CLX}
      (not (ColorBlendArrayPixelFormat in [pf24bit, pf32bit])) or
      {$else}
      (ColorBlendArrayPixelFormat <> pf32bit) or
      {$endif CLX}
      (ColorAux <> ColorBlendArrayGreenValue)                  then
    begin // Recalculate green lookup table
      ColorBlendArrayGreenValue := ColorAux;
      CalcColorArray(@ColorBlendArrayGreen, ColorBlendArrayGreenValue, Level);
    end;
    ColorAux := GetBValue(Color);
    if(not ColorBlendArrayInitialized)                         or
      (ColorBlendArrayLevel <> Level)                          or
      {$ifndef CLX}
      (not (ColorBlendArrayPixelFormat in [pf24bit, pf32bit])) or
      {$else}
      (ColorBlendArrayPixelFormat <> pf32bit) or
      {$endif CLX}
      (ColorAux <> ColorBlendArrayBlueValue)                   then
    begin // Recalculate blue lookup table
      ColorBlendArrayBlueValue := ColorAux;
      CalcColorArray(@ColorBlendArrayBlue, ColorBlendArrayBlueValue, Level);
    end;
    ColorBlendArrayInitialized := True;
    ColorBlendArrayLevel       := Level;
    ColorBlendArrayPixelFormat := PixelFormat;

    {$ifndef CLX}
    if PixelFormat = pf24bit
    then
    begin
      aux  := 1;
      Fast :=
        (Bmp.Width mod 4 = 0) and
        EqualRect(R, Rect(0, 0, BmpWidth, BmpHeight));
    end
    else
    {$endif CLX}
    begin
      aux  := 2;
      Fast := EqualRect(R, Rect(0, 0, BmpWidth, BmpHeight));
    end;

    if Fast
    then
    begin
      while i < 0 do
      begin
        Work[i] := ColorBlendArrayBlue [Work[i]];
        Inc(i);
        Work[i] := ColorBlendArrayGreen[Work[i]];
        Inc(i);
        Work[i] := ColorBlendArrayRed  [Work[i]];
        Inc(i, aux);
      end;
    end
    else
    begin
      BytesPerPixel := 0;
      case PixelFormat of
        {$ifndef CLX}
        pf24bit: BytesPerPixel := 3;
        {$endif CLX}
        pf32bit: BytesPerPixel := 4;
      end;
      CalcColorBlendR(R, BmpWidth, BmpHeight, ScanLineSize, BytesPerPixel, i,
        RWidth, Gap, Limit, W);

      while i < Limit do
      begin
        while i < W do
        begin
          Work[i] := ColorBlendArrayBlue [Work[i]];
          Inc(i);
          Work[i] := ColorBlendArrayGreen[Work[i]];
          Inc(i);
          Work[i] := ColorBlendArrayRed  [Work[i]];
          Inc(i, aux);
        end;
        Inc(i, Gap);
        Inc(W, ScanLineSize);
      end;
    end;
  end;

  procedure DoFuse(Bmp, BrushBmp: TBitmap; Color: TColor; R: TRect;
    Level: Integer);
  var
    i: Integer;
    ColorBmp: TBitmap;
  begin
    for i := 1 to Level do
      StandardFuseFrame(BrushBmp, i);

    Bmp.Canvas.Brush.Bitmap := BrushBmp;
    try
      ColorBmp := TBitmap.Create;
      try
        AdjustBmpForTransition(ColorBmp, {$ifndef CLX}0,{$endif CLX}
          R.Right - R.Left, R.Bottom - R.Top, Bmp.PixelFormat);
        ColorBmp.Canvas.Brush.Color := Color;
        ColorBmp.Canvas.FillRect(Rect(0, 0, ColorBmp.Width, ColorBmp.Height));

        {$ifndef CLX}
        BitBlt(Bmp.Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom,
          ColorBmp.Canvas.Handle, 0, 0, $00AC0744);
        {$else}
        Windows.BitBlt(QPainter_handle(Bmp.Canvas.Handle), R.Left, R.Top,
          R.Right, R.Bottom, QPainter_handle(ColorBmp.Canvas.Handle), 0, 0,
          $00AC0744);
        {$endif CLX}
      finally
        ColorBmp.Free;
      end;
    finally
      Bmp.Canvas.Brush.Bitmap := nil;
    end;
  end;

var
  Clr: PWordArray;
  Work: PDWordArray;
  i,
  ScanLineSize: Integer;
  ColorBmp: TBitmap;
begin
  Color := ColorToRGB(Color);

  begin
    if BrushBmp <> nil
    then DoFuse(Bmp, BrushBmp, Color, R, 64 - Level)
    else
    begin
      ScanLineSize := GetBytesPerScanline(Bmp, PixelFormat, 32);
      Work         := PDWordArray(PChar(Bmp.ScanLine[0]) + ScanlineSize);
      i            := -(ScanLineSize * Bmp.Height);

      {$ifndef CLX}
      if PixelFormat in [pf15bit, pf16bit]
      {$else}
      if PixelFormat = pf16bit
      {$endif CLX}
      then
      begin
        ColorBmp := TBitmap.Create;
        try
          AdjustBmpForTransition(ColorBmp, {$ifndef CLX}0,{$endif CLX}
            32, 1, PixelFormat);
          ColorBmp.Canvas.Pen.Color := Color;
          ColorBmp.Canvas.MoveTo( 0, 0);
          ColorBmp.Canvas.LineTo(32, 0);

          Clr := PWordArray(ColorBmp.ScanLine[0]);
          DoColorBlend_15or16(PWordArray(Work), Clr[0], ScanLineSize, i div 2,
            Bmp.Width, Bmp.Height, R, Level, PixelFormat)
        finally
          ColorBmp.Free;
        end;
      end
      else DoColorBlend_24or32(PByteArray(Work), Color, ScanLineSize, i,
             Bmp.Width, Bmp.Height, R, Level, PixelFormat);
    end;
  end;
end;

end.