New versions by DRON. Untested + want to remove TAlphaBitmap all together.

Components/BitmapImage.pas

@@ -11,43 +11,17 @@ unit BitmapImage;
 
 interface
 
-{$I ..\Projects\VERSION.INC}
-
 uses
   Windows, Controls, Graphics, Classes, Resample;
 
 type
-{$IFNDEF IS_D3}
-  {$DEFINE CUSTOM_PIXELFORMAT_D2}
-{$ENDIF}
-
-{$IFDEF CUSTOM_PIXELFORMAT_D2}
-  TPixelFormat = (pfUndefined, pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
-{$ENDIF}
-  TAlphaFormat = (afIgnored, afDefined, afPremultiplied);
-  TAlphaBitmap = class(TBitmap)
-  private
-    FAlphaFormat: TAlphaFormat;
-    procedure PreMultiplyAlpha;
-{$IFDEF CUSTOM_PIXELFORMAT_D2}
-  private
-    FPixelFormat: TPixelFormat;
-    function GetPixelFormat: TPixelFormat;
-{$ENDIF}
-  public
-    procedure Assign(Source: TPersistent); override;
-    procedure LoadFromStream(Stream: TStream); override;
-    property AlphaFormat: TAlphaFormat read FAlphaFormat write FAlphaFormat;
-{$IFDEF CUSTOM_PIXELFORMAT_D2}
-    property PixelFormat: TPixelFormat read GetPixelFormat;
-{$ENDIF}
-  end;
+  TAlphaBitmap = TBitmap;
 
   TBitmapImage = class(TGraphicControl)
   private
     FAutoSize: Boolean;
     FBackColor: TColor;
-    FBitmap: TAlphaBitmap;
+    FBitmap: TBitmap;
     FCenter: Boolean;
     FReplaceColor: TColor;
     FReplaceWithColor: TColor;
@@ -65,7 +39,7 @@ type
   protected
     function GetPalette: HPALETTE; override;
     procedure Paint; override;
-    procedure SetAutoSize(Value: Boolean); {$IFDEF UNICODE}override;{$ENDIF}
+    procedure SetAutoSize(Value: Boolean); override;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
@@ -100,23 +74,6 @@ 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]);
@@ -127,7 +84,7 @@ begin
   inherited Create(AOwner);
   ControlStyle := ControlStyle + [csReplicatable];
   FBackColor := clBtnFace;
-  FBitmap := TAlphaBitmap.Create;
+  FBitmap := TBitmap.Create;
   FBitmap.OnChange := BitmapChanged;
   FReplaceColor := clNone;
   FReplaceWithColor := clNone;
@@ -218,13 +175,6 @@ begin
 end;
 
 procedure TBitmapImage.Paint;
-const
-  Bf: TBlendFunction =(
-    BlendOp: AC_SRC_OVER;
-    BlendFlags: 0;
-    SourceConstantAlpha: 255;
-    AlphaFormat: AC_SRC_ALPHA);
-
 var
   R: TRect;
   Bmp: TBitmap;
@@ -247,7 +197,7 @@ begin
           FStretchedBitmap.Assign(FBitmap)
         else begin
           FStretchedBitmap.Assign(nil);
-          if not StretchBmp(Canvas, FBitmap, FStretchedBitmap, W, H, Is32bit) then begin
+          if not StretchBmp(FBitmap, FStretchedBitmap, W, H, Is32bit) then begin
             if Is32bit then begin
               FStretchedBitmapValid := False;
               Bmp := FBitmap;
@@ -290,11 +240,7 @@ begin
       Y := 0;
     end;
 
-    if Is32bit then begin
-      if AlphaBlend(Handle, X, Y, W, H, Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bf) then
-        Exit;
-    end;
-    if (FReplaceColor <> clNone) and (FReplaceWithColor <> clNone) then begin
+    if not Is32bit and (FReplaceColor <> clNone) and (FReplaceWithColor <> clNone) then begin
       Brush.Color := FReplaceWithColor;
       BrushCopy(Rect(X, Y, X + W, Y + H), Bmp, Rect(0, 0, Bmp.Width, Bmp.Height), FReplaceColor);
     end else
@@ -302,116 +248,4 @@ begin
   end;
 end;
 
-{$IFDEF CUSTOM_PIXELFORMAT_D2}
-// Types defined to access internal private fields, must match exactly the
-// implementation of both types from Graphics.
-type
-  TBitmapImageAccess = class(TObject)
-  private
-    // TInternalImage
-    FRefCount: Integer;
-    FMemoryManager: Pointer;
-    // TBitmapImage
-    FHandle, FPalette: THandle;
-    FWidth, FHeight: LongInt;
-    FDIBHeader: ^TBitmapInfoHeader;
-    FDIBBits: Pointer;
-  end;
-
-  TBitmapAccess = class(TGraphic)
-  private
-    FImage: TBitmapImageAccess;
-  end;
-{$ENDIF}
-
-{ 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;
-
-{$IFDEF CUSTOM_PIXELFORMAT_D2}
-function TAlphaBitmap.GetPixelFormat: TPixelFormat;
-begin
-  // We use cached value as default since after the canvas handle has been
-  // created the DIB section is no longer valid and the painting must remember
-  // whether the bitmap has alpha or not.
-  Result := FPixelFormat;
-  if TBitmapAccess(Self).FImage = nil then
-    Exit;
-  with TBitmapAccess(Self).FImage do
-  begin
-    if (FDIBHeader = nil) or (FDIBBits = nil) then
-      Exit;
-    Result := pfCustom;
-    case FDIBHeader^.biBitCount of
-      1: Result := pf1Bit;
-      4: Result := pf4Bit;
-      8: Result := pf8Bit;
-     16: case FDIBHeader^.biCompression of
-           BI_RGB : Result := pf15Bit;
-           // BI_BITFIELDS: if FDIBHeader^.dsBitFields[1] = $7E0 then Result := pf16Bit;
-         end;
-     24: Result := pf24Bit;
-     32: if FDIBHeader^.biCompression = BI_RGB then Result := pf32Bit;
-    end;
-  end;
-  FPixelFormat := Result;
-end;
-{$ENDIF}
-
-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
-{$IFNDEF CUSTOM_PIXELFORMAT_D2}
-    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;
-{$ELSE}
-    Pointer(ImageData) := TBitmapAccess(Self).FImage.FDIBBits;
-{$ENDIF}
-    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;
-
-end.
+end.

Components/Resample.pas

@@ -3,7 +3,7 @@ interface
 uses
   Windows, Math, Graphics;
 
-function StretchBmp(Canvas: TCanvas; SrcBitmap, DstBitmap: TBitmap;
+function StretchBmp(SrcBitmap, DstBitmap: TBitmap;
   DstWidth, DstHeight: Integer; Is32bit: Boolean): Boolean;
 
 implementation
@@ -136,71 +136,73 @@ begin
   end;
 end;
 
-function StretchBmp(Canvas: TCanvas; SrcBitmap, DstBitmap: TBitmap;
+
+function StretchBmp(SrcBitmap, DstBitmap: TBitmap;
   DstWidth, DstHeight: Integer; Is32bit: Boolean): Boolean;
 var
-  SrcLineSize, DstLineSize, SrcWidth, SrcHeight, PixelSize: Integer;
-  SrcBits, DstBits, tmpBits: Pointer;
-  BI: TBitmapInfo;
-  DIB: HBITMAP;
+  SrcWidth, SrcHeight, SrcLineSize, DstLineSize, PixelSize: Integer;
+  SrcBits, DstBits, TmpBits: Pointer;
+  PixelFormat: TPixelFormat;
   Proc: TPutPixelProc;
-const
-  NULL = {$IFDEF VER90}nil{$ELSE}0{$ENDIF};
 begin
   Result := False;
   try
     if (DstWidth <= 0) or (DstHeight <= 0) then Exit;
-    //High quality resampling makes sense only
-    //in True Color and High Color display modes.
-    if GetDeviceCaps(Canvas.Handle, BITSPIXEL) <= 8 then Exit;
-    SrcWidth  := SrcBitmap.Width;
+    SrcWidth := SrcBitmap.Width;
     SrcHeight := SrcBitmap.Height;
     if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit;
-    FillChar(BI, SizeOf(BI), 0);
-    BI.bmiHeader.biSize := SizeOf(BI.bmiHeader);
-    BI.bmiHeader.biWidth := SrcWidth;
-    BI.bmiHeader.biHeight := SrcHeight;
-    BI.bmiHeader.biPlanes := 1;
-    BI.bmiHeader.biCompression := BI_RGB;
     if Is32bit then begin
-      BI.bmiHeader.biBitCount := 32;
+      PixelFormat := pf32bit;
       PixelSize := 4;
       Proc := PutPixel32P;
     end else begin
-      BI.bmiHeader.biBitCount := 24;
+      PixelFormat := pf24bit;
       PixelSize := 3;
       Proc := PutPixel24;
     end;
-    DstLineSize := (DstWidth * PixelSize + 3) and not 3;
-    SrcLineSize := (SrcWidth * PixelSize + 3) and not 3;
-    GetMem(tmpBits, SrcHeight * DstLineSize);
+    //NOTE: Irreversible change of SrcBitmap pixel format
+    SrcBitmap.PixelFormat := PixelFormat;
+    SrcLineSize := WPARAM(SrcBitmap.ScanLine[0]) - WPARAM(SrcBitmap.ScanLine[1]);
+    if SrcLineSize >= 0 then
+      SrcBits := SrcBitmap.ScanLine[SrcHeight - 1]
+    else begin
+      SrcLineSize := -SrcLineSize;
+      SrcBits := SrcBitmap.ScanLine[0];
+    end;
+    DstBitmap.PixelFormat := PixelFormat;
+    DstBitmap.AlphaFormat := SrcBitmap.AlphaFormat;
+    DstBitmap.Width := DstWidth;
+    DstBitmap.Height := DstHeight;
+    DstLineSize := WPARAM(DstBitmap.ScanLine[0]) - WPARAM(DstBitmap.ScanLine[1]);
+    if DstLineSize >= 0 then
+      DstBits := DstBitmap.ScanLine[DstHeight - 1]
+    else begin
+      DstLineSize := -DstLineSize;
+      DstBits := DstBitmap.ScanLine[0];
+    end;
+    TmpBits := nil;
     try
-      GetMem(SrcBits, SrcLineSize * SrcHeight);
-      try
-        if GetDIBits(Canvas.Handle, SrcBitmap.Handle,
-          0, SrcHeight, SrcBits, BI, DIB_RGB_COLORS) = 0 then Exit;
+      //Minimize temporary allocations by choosing right stretch order
+      if DstWidth * SrcHeight < DstHeight * SrcWidth then begin
+        GetMem(TmpBits, SrcHeight * DstLineSize);
         //Stretch horizontally
-        ResampleBits(DstWidth, SrcWidth, SrcBits, tmpBits,
-          PixelSize, SrcHeight, SrcLineSize, DstLineSize, Proc);
-      finally
-        FreeMem(SrcBits);
-      end;
-      BI.bmiHeader.biWidth := DstWidth;
-      BI.bmiHeader.biHeight := DstHeight;
-      DIB := CreateDIBSection(Canvas.Handle, BI, DIB_RGB_COLORS, DstBits, NULL, 0);
-      if DIB = 0 then Exit;
-      try
+        ResampleBits(DstWidth, SrcWidth, SrcBits, TmpBits, PixelSize,
+          SrcHeight, SrcLineSize, DstLineSize, Proc);
+        //Stretch vertically
+        ResampleBits(DstHeight, SrcHeight, TmpBits, DstBits, DstLineSize,
+          DstWidth, PixelSize, PixelSize, Proc);
+      end else begin
+        GetMem(TmpBits, DstHeight * SrcLineSize);
         //Stretch vertically
-        ResampleBits(DstHeight, SrcHeight, tmpBits, DstBits,
-          DstLineSize, DstWidth, PixelSize, PixelSize, Proc);
-        DstBitmap.Handle := DIB;
-        Result := True;
-      except
-        DeleteObject(DIB);
-        raise;
+        ResampleBits(DstHeight, SrcHeight, SrcBits, TmpBits, SrcLineSize,
+          SrcWidth, PixelSize, PixelSize, Proc);
+        //Stretch horizontally
+        ResampleBits(DstWidth, SrcWidth, TmpBits, DstBits, PixelSize,
+          DstHeight, SrcLineSize, DstLineSize, Proc);
       end;
+      Result := True;
     finally
-      FreeMem(tmpBits);
+      FreeMem(TmpBits);
     end;
   except
   end;