added TAlphaBitmap class that adds AlphaFormat support to all Delphi versions

Components/BitmapImage.pas

@@ -13,15 +13,33 @@ unit BitmapImage;
 
 interface
 
+{$I ..\Projects\VERSION.INC}
+
 uses
   Windows, Controls, Graphics, Classes;
 
 type
+{$IFDEF IS_D12}
+  TAlphaBitmap = TBitmap;
+{$ELSE}
+  {$DEFINE CUSTOM_BITMAP}
+  TAlphaFormat = (afIgnored, afDefined, afPremultiplied);
+  TAlphaBitmap = class(TBitmap)
+  private
+    FAlphaFormat: TAlphaFormat;
+    procedure PreMultiplyAlpha;
+  public
+    procedure Assign(Source: TPersistent); override;
+    procedure LoadFromStream(Stream: TStream); override;
+    property AlphaFormat: TAlphaFormat read FAlphaFormat write FAlphaFormat;
+  end;
+{$ENDIF}
+
   TBitmapImage = class(TGraphicControl)
   private
     FAutoSize: Boolean;
     FBackColor: TColor;
-    FBitmap: TBitmap;
+    FBitmap: TAlphaBitmap;
     FCenter: Boolean;
     FReplaceColor: TColor;
     FReplaceWithColor: TColor;
@@ -35,6 +53,7 @@ type
     procedure SetReplaceColor(Value: TColor);
     procedure SetReplaceWithColor(Value: TColor);
     procedure SetStretch(Value: Boolean);
+    function GetBitmap: TBitmap;
   protected
     function GetPalette: HPALETTE; override;
     procedure Paint; override;
@@ -51,7 +70,7 @@ type
     property DragMode;
     property Enabled;
     property ParentShowHint;
-    property Bitmap: TBitmap read FBitmap write SetBitmap;
+    property Bitmap: TBitmap read GetBitmap write SetBitmap;
     property PopupMenu;
     property ShowHint;
     property Stretch: Boolean read FStretch write SetStretch default False;
@@ -73,6 +92,23 @@ procedure Register;
 
 implementation
 
+{$IFNDEF IS_D6}
+type
+  TBlendFunction = record
+    BlendOp: BYTE;
+    BlendFlags: BYTE;
+    SourceConstantAlpha: BYTE;
+    AlphaFormat: BYTE;
+  end;
+
+const
+  AC_SRC_OVER = $00;
+  AC_SRC_ALPHA = $01;
+
+function AlphaBlend(DC: HDC; p2, p3, p4, p5: Integer; DC6: HDC; p7, p8, p9,
+  p10: Integer; p11: TBlendFunction): BOOL; stdcall; external 'msimg32.dll' name 'AlphaBlend';
+{$ENDIF}
+
 procedure Register;
 begin
   RegisterComponents('JR', [TBitmapImage]);
@@ -83,7 +119,7 @@ begin
   inherited Create(AOwner);
   ControlStyle := ControlStyle + [csReplicatable];
   FBackColor := clBtnFace;
-  FBitmap := TBitmap.Create;
+  FBitmap := TAlphaBitmap.Create;
   FBitmap.OnChange := BitmapChanged;
   FReplaceColor := clNone;
   FReplaceWithColor := clNone;
@@ -163,6 +199,11 @@ begin
   end;
 end;
 
+function TBitmapImage.GetBitmap: TBitmap;
+begin
+  Result := FBitmap;
+end;
+
 function TBitmapImage.GetPalette: HPALETTE;
 begin
   Result := FBitmap.Palette;
@@ -184,7 +225,8 @@ var
 begin
   with Canvas do begin
     R := ClientRect;
-    Is32bit := FBitmap.PixelFormat = pf32bit;
+    Is32bit := (FBitmap.PixelFormat = pf32bit) and
+      (FBitmap.AlphaFormat in [afDefined, afPremultiplied]);
 
     if Stretch then begin
       W := R.Right;
@@ -249,4 +291,64 @@ begin
   end;
 end;
 
+{$IFDEF CUSTOM_BITMAP}
+
+{ TAlphaBitmap }
+
+type
+  // Some type that we know all Delphi supports and has correct width on all
+  // platforms.
+  NativeUInt = WPARAM;
+
+procedure TAlphaBitmap.Assign(Source: TPersistent);
+begin
+  inherited;
+  if Source is TAlphaBitmap then
+    FAlphaFormat := TAlphaBitmap(Source).AlphaFormat;
+end;
+
+procedure TAlphaBitmap.LoadFromStream(Stream: TStream);
+begin
+  inherited;
+  if (PixelFormat = pf32bit) and (FAlphaFormat = afDefined) then
+    PreMultiplyAlpha;
+end;
+
+function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
+begin
+  Dec(Alignment);
+  Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
+  Result := Result div 8;
+end;
+
+procedure TAlphaBitmap.PreMultiplyAlpha;
+var
+  Alpha: Word;
+  ImageData, Limit: NativeUInt;
+begin
+  if (PixelFormat = pf32bit) then //Premultiply the alpha into the color
+  begin
+    Pointer(ImageData) := ScanLine[0];
+    if ImageData = NativeUInt(nil) then
+      Exit;
+    Pointer(Limit) := ScanLine[Height - 1];
+    // Is bottom up? (this can be distinguished by biHeight being positive but
+    // since we don't have direct access to the headers we need to work around
+    // that.
+    if Limit < ImageData then
+      ImageData := Limit;
+    Limit := ImageData + NativeUInt(BytesPerScanline(Width, 32, 32) * Height);
+    while ImageData < Limit do
+    begin
+      Alpha := PByte(ImageData + 3)^;
+      PByte(ImageData)^ := MulDiv(PByte(ImageData)^, Alpha, 255);
+      PByte(ImageData + 1)^ := MulDiv(PByte(ImageData + 1)^, Alpha, 255);
+      PByte(ImageData + 2)^ := MulDiv(PByte(ImageData + 2)^, Alpha, 255);
+      Inc(ImageData, 4);
+    end;
+  end;
+end;
+
+{$ENDIF}
+
 end.