Ignore:
Timestamp:
Apr 17, 2019, 12:58:41 AM (5 years ago)
Author:
chronos
Message:
  • Modified: Propagate project build mode options to used packages.
  • Added: Check memory leaks using heaptrc.
  • Modified: Update BGRABitmap package.
Location:
GraphicTest
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • GraphicTest

    • Property svn:ignore

      •  

        old new  
        88GraphicTest.lps
        99GraphicTest.dbg
         10heaptrclog.trc

  • GraphicTest/Packages/bgrabitmap/bgralclbitmap.pas

    r494 r521  
    2121      ): TBGRAPtrBitmap; override;
    2222    procedure AssignRasterImage(ARaster: TRasterImage); virtual;
     23    procedure ExtractXorMask;
    2324  public
    2425    procedure Assign(Source: TPersistent); override;
     26    procedure LoadFromResource(AFilename: string; AOptions: TBGRALoadingOptions); overload; override;
    2527    procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
    2628      AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    27     procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
     29    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
    2830      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
    2931    procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
    30     procedure LoadFromDevice({%H-}DC: System.THandle); override;
    31     procedure LoadFromDevice({%H-}DC: System.THandle; {%H-}ARect: TRect); override;
     32    procedure LoadFromDevice({%H-}DC: HDC); override;
     33    procedure LoadFromDevice({%H-}DC: HDC; {%H-}ARect: TRect); override;
    3234    procedure TakeScreenshotOfPrimaryMonitor; override;
    3335    procedure TakeScreenshot({%H-}ARect: TRect); override;
    … …  
    5456implementation
    5557
    56 uses BGRAText, LCLType, LCLIntf, FPimage;
     58uses Types, BGRAText, LCLType, LCLIntf, FPimage;
    5759
    5860type
    5961  TCopyPixelProc = procedure (psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
     62
     63procedure ApplyMask1bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
     64var currentBit: byte;
     65begin
     66  currentBit := 1;
     67  while count > 0 do
     68  begin
     69    if psrc^ and currentBit <> 0 then pdest^.alpha := 0;
     70    inc(pdest);
     71    if currentBit = 128 then
     72    begin
     73      currentBit := 1;
     74      inc(psrc);
     75    end else
     76      currentBit := currentBit shl 1;
     77    dec(count);
     78  end;
     79end;
     80
     81procedure ApplyMask1bitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; {%H-}defaultOpacity: byte);
     82var currentBit: byte;
     83begin
     84  currentBit := 128;
     85  while count > 0 do
     86  begin
     87    if psrc^ and currentBit <> 0 then pdest^.alpha := 0;
     88    inc(pdest);
     89    if currentBit = 1 then
     90    begin
     91      currentBit := 128;
     92      inc(psrc);
     93    end else
     94      currentBit := currentBit shr 1;
     95    dec(count);
     96  end;
     97end;
     98
     99procedure CopyFromBW_SetAlpha(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte);
     100var currentBit: byte;
     101begin
     102  currentBit := 1;
     103  while count > 0 do
     104  begin
     105    if psrc^ and currentBit <> 0 then
     106      pdest^ := BGRAWhite
     107    else
     108      pdest^ := BGRABlack;
     109    pdest^.alpha := DefaultOpacity;
     110    inc(pdest);
     111    if currentBit = 128 then
     112    begin
     113      currentBit := 1;
     114      inc(psrc);
     115    end else
     116      currentBit := currentBit shl 1;
     117    dec(count);
     118  end;
     119end;
     120
     121procedure CopyFromBW_SetAlphaBitRev(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; {%H-}sourcePixelSize: PtrInt; defaultOpacity: byte);
     122var currentBit: byte;
     123begin
     124  currentBit := 128;
     125  while count > 0 do
     126  begin
     127    if psrc^ and currentBit <> 0 then
     128      pdest^ := BGRAWhite
     129    else
     130      pdest^ := BGRABlack;
     131    pdest^.alpha := DefaultOpacity;
     132    inc(pdest);
     133    if currentBit = 1 then
     134    begin
     135      currentBit := 128;
     136      inc(psrc);
     137    end else
     138      currentBit := currentBit shr 1;
     139    dec(count);
     140  end;
     141end;
    60142
    61143procedure CopyFrom24Bit(psrc: PByte; pdest: PBGRAPixel; count: NativeInt; sourcePixelSize: PtrInt; defaultOpacity: byte);
    … …  
    255337end;
    256338
    257 { Load raw image data. It must be 32bit or 24 bits per pixel}
    258 function LoadFromRawImageImplementation(ADestination: TBGRADefaultBitmap; ARawImage: TRawImage;
    259   DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean;
    260 var
     339procedure DoCopyProc(ADestination: TBGRACustomBitmap; ACopyProc: TCopyPixelProc; AData: PByte; ABytesPerLine, ABitsPerPixel: integer; ALineOrder: TRawImageLineOrder; ADefaultOpacity: byte);
     340var
     341  n: integer;
    261342  psource_byte, pdest_byte,
    262343  psource_first, pdest_first: PByte;
    263344  psource_delta, pdest_delta: integer;
    264 
    265   n: integer;
     345begin
     346  if (ALineOrder = ADestination.LineOrder) and
     347    (ABytesPerLine = (ABitsPerPixel shr 3) * cardinal(ADestination.Width)) then
     348    ACopyProc(AData, ADestination.Data, ADestination.NbPixels, ABitsPerPixel shr 3, ADefaultOpacity)
     349  else
     350  begin
     351    if ALineOrder = riloTopToBottom then
     352    begin
     353      psource_first := AData;
     354      psource_delta := ABytesPerLine;
     355    end else
     356    begin
     357      psource_first := AData + (ADestination.Height-1) * ABytesPerLine;
     358      psource_delta := -ABytesPerLine;
     359    end;
     360
     361    if ADestination.LineOrder = riloTopToBottom then
     362    begin
     363      pdest_first := PByte(ADestination.Data);
     364      pdest_delta := ADestination.Width*sizeof(TBGRAPixel);
     365    end else
     366    begin
     367      pdest_first := PByte(ADestination.Data) + (ADestination.Height-1)*ADestination.Width*sizeof(TBGRAPixel);
     368      pdest_delta := -ADestination.Width*sizeof(TBGRAPixel);
     369    end;
     370
     371    psource_byte := psource_first;
     372    pdest_byte := pdest_first;
     373    for n := ADestination.Height-1 downto 0 do
     374    begin
     375      ACopyProc(psource_byte, PBGRAPixel(pdest_byte), ADestination.Width, ABitsPerPixel shr 3, ADefaultOpacity);
     376      inc(psource_byte, psource_delta);
     377      inc(pdest_byte, pdest_delta);
     378    end;
     379  end;
     380end;
     381
     382procedure ApplyRawImageMask(ADestination: TBGRACustomBitmap; const ARawImage: TRawImage);
     383var
     384  copyProc: TCopyPixelProc;
     385begin
     386  if (ARawImage.Description.MaskBitsPerPixel = 1) and (ARawImage.Mask <> nil) then
     387  begin
     388    if ARawImage.Description.BitOrder = riboBitsInOrder then
     389      copyProc := @ApplyMask1bit
     390    else
     391      copyProc := @ApplyMask1bitRev;
     392    DoCopyProc(ADestination, copyProc, ARawImage.Mask, ARawImage.Description.MaskBytesPerLine, ARawImage.Description.MaskBitsPerPixel, ARawImage.Description.LineOrder, 0);
     393    ADestination.InvalidateBitmap;
     394  end;
     395end;
     396
     397{ Load raw image data. It must be 32bit, 24 bits or 1bit per pixel}
     398function LoadFromRawImageImplementation(ADestination: TBGRADefaultBitmap; const ARawImage: TRawImage;
     399  DefaultOpacity: byte; AlwaysReplaceAlpha: boolean; RaiseErrorOnInvalidPixelFormat: boolean): boolean;
     400var
    266401  mustSwapRedBlue: boolean;
    267402  copyProc: TCopyPixelProc;
    … …  
    287422  end;
    288423
    289   if ((ARawImage.Description.BitsPerPixel and 7) <> 0) then
    290   begin
    291     result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but multiple of 8bit expected');
    292     exit;
    293   end;
    294 
    295   if (ARawImage.Description.BitsPerPixel < 24) then
    296   begin
    297     result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but at least 24bit expected');
    298     exit;
    299   end;
    300 
    301   nbColorChannels := 0;
    302   if (ARawImage.Description.RedPrec > 0)  then inc(nbColorChannels);
    303   if (ARawImage.Description.GreenPrec > 0)  then inc(nbColorChannels);
    304   if (ARawImage.Description.BluePrec > 0)  then inc(nbColorChannels);
    305 
    306   if (nbColorChannels < 3) then
    307   begin
    308     result := FormatError('One or more color channel is missing (RGB expected)');
    309     exit;
    310   end;
    311 
    312   //channels are in ARGB order
    313   if (ARawImage.Description.BitsPerPixel >= 32) and
    314      (ARawImage.Description.AlphaPrec = 8) and
    315     (((ARawImage.Description.AlphaShift = 0) and
    316     (ARawImage.Description.RedShift = 8) and
    317     (ARawImage.Description.GreenShift = 16) and
    318     (ARawImage.Description.BlueShift = 24) and
    319     (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    320     ((ARawImage.Description.AlphaShift = ARawImage.Description.BitsPerPixel - 8) and
    321     (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
    322     (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
    323     (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
    324     (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    325     begin
    326       if AlwaysReplaceAlpha then
    327         copyProc := @CopyFromARGB_SetAlpha
    328       else if DefaultOpacity = 0 then
    329         copyProc := @CopyFromARGB_KeepAlpha
     424  if ARawImage.Description.BitsPerPixel = 1 then
     425  begin
     426    if ARawImage.Description.BitOrder = riboBitsInOrder then
     427      copyProc := @CopyFromBW_SetAlpha
     428    else
     429      copyProc := @CopyFromBW_SetAlphaBitRev;
     430    DefaultOpacity := 255;
     431  end else
     432  begin
     433    if ((ARawImage.Description.BitsPerPixel and 7) <> 0) then
     434    begin
     435      result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but multiple of 8bit expected');
     436      exit;
     437    end;
     438
     439    if (ARawImage.Description.BitsPerPixel < 24) then
     440    begin
     441      result := FormatError(IntToStr(ARawImage.Description.Depth) + 'bit found but at least 24bit expected');
     442      exit;
     443    end;
     444
     445    nbColorChannels := 0;
     446    if (ARawImage.Description.RedPrec > 0)  then inc(nbColorChannels);
     447    if (ARawImage.Description.GreenPrec > 0)  then inc(nbColorChannels);
     448    if (ARawImage.Description.BluePrec > 0)  then inc(nbColorChannels);
     449
     450    if (nbColorChannels < 3) then
     451    begin
     452      result := FormatError('One or more color channel is missing (RGB expected)');
     453      exit;
     454    end;
     455
     456    //channels are in ARGB order
     457    if (ARawImage.Description.BitsPerPixel >= 32) and
     458       (ARawImage.Description.AlphaPrec = 8) and
     459      (((ARawImage.Description.AlphaShift = 0) and
     460      (ARawImage.Description.RedShift = 8) and
     461      (ARawImage.Description.GreenShift = 16) and
     462      (ARawImage.Description.BlueShift = 24) and
     463      (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     464      ((ARawImage.Description.AlphaShift = ARawImage.Description.BitsPerPixel - 8) and
     465      (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
     466      (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
     467      (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
     468      (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     469      begin
     470        if AlwaysReplaceAlpha then
     471          copyProc := @CopyFromARGB_SetAlpha
     472        else if DefaultOpacity = 0 then
     473          copyProc := @CopyFromARGB_KeepAlpha
     474        else
     475          copyProc := @CopyFromARGB_ReplaceZeroAlpha;
     476      end
     477    else //channels are in ARGB order but alpha is not used
     478    if (ARawImage.Description.BitsPerPixel >= 32) and
     479       (ARawImage.Description.AlphaPrec = 0) and
     480      (((ARawImage.Description.RedShift = 8) and
     481      (ARawImage.Description.GreenShift = 16) and
     482      (ARawImage.Description.BlueShift = 24) and
     483      (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     484      ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
     485      (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
     486      (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
     487      (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     488      begin
     489        DefaultOpacity := 255;
     490        copyProc := @CopyFromARGB_SetAlpha;
     491      end
     492    else
     493    begin
     494      //channels are in RGB order (alpha channel may follow)
     495      if (ARawImage.Description.BitsPerPixel >= 24) and
     496         (((ARawImage.Description.RedShift = 0) and
     497           (ARawImage.Description.GreenShift = 8) and
     498           (ARawImage.Description.BlueShift = 16) and
     499           (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     500          ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 8) and
     501           (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
     502           (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 24) and
     503           (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     504      begin
     505        mustSwapRedBlue:= not TBGRAPixel_RGBAOrder;
     506      end
    330507      else
    331         copyProc := @CopyFromARGB_ReplaceZeroAlpha;
    332     end
    333   else //channels are in ARGB order but alpha is not used
    334   if (ARawImage.Description.BitsPerPixel >= 32) and
    335      (ARawImage.Description.AlphaPrec = 0) and
    336     (((ARawImage.Description.RedShift = 8) and
    337     (ARawImage.Description.GreenShift = 16) and
    338     (ARawImage.Description.BlueShift = 24) and
    339     (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    340     ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 16) and
    341     (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 24) and
    342     (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 32) and
    343     (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    344     begin
    345       DefaultOpacity := 255;
    346       copyProc := @CopyFromARGB_SetAlpha;
    347     end
    348   else
    349   begin
    350     //channels are in RGB order (alpha channel may follow)
    351     if (ARawImage.Description.BitsPerPixel >= 24) and
    352        (((ARawImage.Description.RedShift = 0) and
    353          (ARawImage.Description.GreenShift = 8) and
    354          (ARawImage.Description.BlueShift = 16) and
    355          (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    356         ((ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 8) and
    357          (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
    358          (ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 24) and
    359          (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    360     begin
    361       mustSwapRedBlue:= not TBGRAPixel_RGBAOrder;
    362     end
    363     else
    364     //channels are in BGR order (alpha channel may follow)
    365     if (ARawImage.Description.BitsPerPixel >= 24) and
    366        (((ARawImage.Description.BlueShift = 0) and
    367          (ARawImage.Description.GreenShift = 8) and
    368          (ARawImage.Description.RedShift = 16) and
    369          (ARawImage.Description.ByteOrder = riboLSBFirst)) or
    370         ((ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 8) and
    371          (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
    372          (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 24) and
    373          (ARawImage.Description.ByteOrder = riboMSBFirst))) then
    374     begin
    375       mustSwapRedBlue:= TBGRAPixel_RGBAOrder;
    376     end
    377     else
    378     begin
    379       result := FormatError('BitsPerPixel: ' + IntToStr(ARawImage.Description.BitsPerPixel) + ', '
    380         + 'RedShit: ' + IntToStr(ARawImage.Description.RedShift) + ', Prec: ' + IntToStr(ARawImage.Description.RedPrec)+ ', '
    381         + 'GreenShit: ' + IntToStr(ARawImage.Description.GreenShift) + ', Prec: ' + IntToStr(ARawImage.Description.GreenPrec)+ ', '
    382         + 'BlueShift: ' + IntToStr(ARawImage.Description.BlueShift) + ', Prec: ' + IntToStr(ARawImage.Description.BluePrec)+ ', '
    383         + 'AlphaShift: ' + IntToStr(ARawImage.Description.AlphaShift) + ', Prec: ' + IntToStr(ARawImage.Description.AlphaPrec) );
    384       exit;
    385     end;
    386 
    387     if not mustSwapRedBlue then
    388     begin
    389       if ARawImage.Description.BitsPerPixel = 24 then
    390         copyProc := @CopyFrom24Bit
     508      //channels are in BGR order (alpha channel may follow)
     509      if (ARawImage.Description.BitsPerPixel >= 24) and
     510         (((ARawImage.Description.BlueShift = 0) and
     511           (ARawImage.Description.GreenShift = 8) and
     512           (ARawImage.Description.RedShift = 16) and
     513           (ARawImage.Description.ByteOrder = riboLSBFirst)) or
     514          ((ARawImage.Description.BlueShift = ARawImage.Description.BitsPerPixel - 8) and
     515           (ARawImage.Description.GreenShift = ARawImage.Description.BitsPerPixel - 16) and
     516           (ARawImage.Description.RedShift = ARawImage.Description.BitsPerPixel - 24) and
     517           (ARawImage.Description.ByteOrder = riboMSBFirst))) then
     518      begin
     519        mustSwapRedBlue:= TBGRAPixel_RGBAOrder;
     520      end
    391521      else
    392       if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
    393         copyProc := @CopyFrom32Bit_SetAlpha
    394       else if DefaultOpacity = 0 then
    395         copyProc := @CopyFrom32Bit_KeepAlpha
    396       else
    397         copyProc := @CopyFrom32Bit_ReplaceZeroAlpha;
    398     end else
    399     begin
    400       if ARawImage.Description.BitsPerPixel = 24 then
    401         copyProc := @CopyFrom24Bit_SwapRedBlue
    402       else
    403       if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
    404         copyProc := @CopyFrom32Bit_SwapRedBlue_SetAlpha
    405       else if DefaultOpacity = 0 then
    406         copyProc := @CopyFrom32Bit_SwapRedBlue_KeepAlpha
    407       else
    408         copyProc := @CopyFrom32Bit_SwapRedBlue_ReplaceZeroAlpha;
    409     end;
    410   end;
    411 
    412   if (ARawImage.Description.LineOrder = ADestination.LineOrder) and
    413     (ARawImage.Description.BytesPerLine = (ARawImage.Description.BitsPerPixel shr 3) * cardinal(ADestination.Width)) then
    414     copyProc(ARawImage.Data, ADestination.Data, ADestination.NbPixels, ARawImage.Description.BitsPerPixel shr 3, DefaultOpacity)
    415   else
    416   begin
    417     if ARawImage.Description.LineOrder = riloTopToBottom then
    418     begin
    419       psource_first := ARawImage.Data;
    420       psource_delta := ARawImage.Description.BytesPerLine;
    421     end else
    422     begin
    423       psource_first := ARawImage.Data + (ARawImage.Description.Height-1) * ARawImage.Description.BytesPerLine;
    424       psource_delta := -ARawImage.Description.BytesPerLine;
    425     end;
    426 
    427     if ADestination.LineOrder = riloTopToBottom then
    428     begin
    429       pdest_first := PByte(ADestination.Data);
    430       pdest_delta := ADestination.Width*sizeof(TBGRAPixel);
    431     end else
    432     begin
    433       pdest_first := PByte(ADestination.Data) + (ADestination.Height-1)*ADestination.Width*sizeof(TBGRAPixel);
    434       pdest_delta := -ADestination.Width*sizeof(TBGRAPixel);
    435     end;
    436 
    437     psource_byte := psource_first;
    438     pdest_byte := pdest_first;
    439     for n := ADestination.Height-1 downto 0 do
    440     begin
    441       copyProc(psource_byte, PBGRAPixel(pdest_byte), ADestination.Width, ARawImage.Description.BitsPerPixel shr 3, DefaultOpacity);
    442       inc(psource_byte, psource_delta);
    443       inc(pdest_byte, pdest_delta);
    444     end;
    445   end;
    446 
     522      begin
     523        result := FormatError('BitsPerPixel: ' + IntToStr(ARawImage.Description.BitsPerPixel) + ', '
     524          + 'RedShit: ' + IntToStr(ARawImage.Description.RedShift) + ', Prec: ' + IntToStr(ARawImage.Description.RedPrec)+ ', '
     525          + 'GreenShit: ' + IntToStr(ARawImage.Description.GreenShift) + ', Prec: ' + IntToStr(ARawImage.Description.GreenPrec)+ ', '
     526          + 'BlueShift: ' + IntToStr(ARawImage.Description.BlueShift) + ', Prec: ' + IntToStr(ARawImage.Description.BluePrec)+ ', '
     527          + 'AlphaShift: ' + IntToStr(ARawImage.Description.AlphaShift) + ', Prec: ' + IntToStr(ARawImage.Description.AlphaPrec) );
     528        exit;
     529      end;
     530
     531      if not mustSwapRedBlue then
     532      begin
     533        if ARawImage.Description.BitsPerPixel = 24 then
     534          copyProc := @CopyFrom24Bit
     535        else
     536        if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
     537          copyProc := @CopyFrom32Bit_SetAlpha
     538        else if DefaultOpacity = 0 then
     539          copyProc := @CopyFrom32Bit_KeepAlpha
     540        else
     541          copyProc := @CopyFrom32Bit_ReplaceZeroAlpha;
     542      end else
     543      begin
     544        if ARawImage.Description.BitsPerPixel = 24 then
     545          copyProc := @CopyFrom24Bit_SwapRedBlue
     546        else
     547        if AlwaysReplaceAlpha or (ARawImage.Description.AlphaPrec = 0) then
     548          copyProc := @CopyFrom32Bit_SwapRedBlue_SetAlpha
     549        else if DefaultOpacity = 0 then
     550          copyProc := @CopyFrom32Bit_SwapRedBlue_KeepAlpha
     551        else
     552          copyProc := @CopyFrom32Bit_SwapRedBlue_ReplaceZeroAlpha;
     553      end;
     554    end;
     555  end;
     556
     557  DoCopyProc(ADestination, copyProc, ARawImage.Data, ARawImage.Description.BytesPerLine, ARawImage.Description.BitsPerPixel, ARawImage.Description.LineOrder, DefaultOpacity);
    447558  ADestination.InvalidateBitmap;
     559
     560  ApplyRawImageMask(ADestination, ARawImage);
    448561  result := true;
    449562end;
    … …  
    635748begin
    636749  if FBitmap <> nil then
     750  begin
    637751    LoadFromRawImage(FBitmap.RawImage, FCanvasOpacity);
     752    if FAlphaCorrectionNeeded then DoAlphaCorrection;
     753  end;
    638754end;
    639755
    … …  
    666782  FBitmap.Canvas.AntialiasingMode := amOff;
    667783  FBitmapModified := False;
     784  FAlphaCorrectionNeeded:= false;
    668785end;
    669786
    … …  
    681798  end else
    682799    inherited Assign(Source);
     800
     801  if Source is TCursorImage then
     802  begin
     803    HotSpot := TCursorImage(Source).HotSpot;
     804    ExtractXorMask;
     805  end
     806  else if Source is TIcon then
     807  begin
     808    HotSpot := Point(0,0);
     809    ExtractXorMask;
     810  end;
     811end;
     812
     813procedure TBGRALCLBitmap.LoadFromResource(AFilename: string;
     814  AOptions: TBGRALoadingOptions);
     815var
     816  icon: TCustomIcon;
     817  ext: String;
     818begin
     819  if BGRAResource.IsWinResource(AFilename) then
     820  begin
     821    ext:= Uppercase(ExtractFileExt(AFilename));
     822    if (ext = '.ICO') or (ext = '.CUR') then
     823    begin
     824      if ext= '.ICO' then icon := TIcon.Create
     825      else icon := TCursorImage.Create;
     826      try
     827        icon.LoadFromResourceName(HInstance, ChangeFileExt(AFilename,''));
     828        icon.Current:= icon.GetBestIndexForSize(Size(65536,65536));
     829        self.AssignRasterImage(icon);
     830      finally
     831        icon.Free;
     832      end;
     833      exit;
     834    end;
     835  end;
     836
     837  inherited LoadFromResource(AFilename, AOptions);
    683838end;
    684839
    … …  
    688843  DiscardBitmapChange;
    689844  SetSize(ARaster.Width, ARaster.Height);
    690   if not LoadFromRawImage(ARaster.RawImage,0,False,False) then
    691   if ARaster is TBitmap then
     845  if LoadFromRawImage(ARaster.RawImage,0,False,False) then
     846  begin
     847    If Empty then
     848    begin
     849      AlphaFill(255); // if bitmap seems to be empty, assume
     850                      // it is an opaque bitmap without alpha channel
     851      ApplyRawImageMask(self, ARaster.RawImage);
     852    end;
     853  end else
     854  if (ARaster is TBitmap) or (ARaster is TCustomIcon) then
    692855  begin //try to convert
    693856    TempBmp := TBitmap.Create;
    … …  
    696859    TempBmp.Canvas.Draw(0,0,ARaster);
    697860    try
    698       LoadFromRawImage(TempBmp.RawImage,0,False,true);
     861      LoadFromRawImage(TempBmp.RawImage,255,False,true);
     862      ApplyRawImageMask(self, ARaster.RawImage);
    699863    finally
    700864      TempBmp.Free;
    … …  
    702866  end else
    703867    raise Exception.Create('Unable to convert image to 24 bit');
    704   If Empty then AlphaFill(255); // if bitmap seems to be empty, assume
    705                                 // it is an opaque bitmap without alpha channel
     868end;
     869
     870procedure TBGRALCLBitmap.ExtractXorMask;
     871var
     872  y, x: Integer;
     873  p: PBGRAPixel;
     874begin
     875  DiscardXorMask;
     876  for y := 0 to Height-1 do
     877  begin
     878    p := ScanLine[y];
     879    for x := 0 to Width-1 do
     880    begin
     881      if (p^.alpha = 0) and (PDWord(p)^<>0) then
     882      begin
     883        NeedXorMask;
     884        XorMask.SetPixel(x,y, p^);
     885      end;
     886      inc(p);
     887    end;
     888  end;
    706889end;
    707890
    … …  
    712895end;
    713896
    714 procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
     897procedure TBGRALCLBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
    715898  AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
    716899begin
    717   DataDrawOpaqueImplementation(ACanvas, Rect, AData, ALineOrder, AWidth, AHeight);
     900  DataDrawOpaqueImplementation(ACanvas, ARect, AData, ALineOrder, AWidth, AHeight);
    718901end;
    719902
    … …  
    725908end;
    726909
    727 procedure TBGRALCLBitmap.LoadFromDevice(DC: System.THandle);
     910procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC);
    728911var
    729912  rawImage: TRawImage;
    … …  
    747930end;
    748931
    749 procedure TBGRALCLBitmap.LoadFromDevice(DC: System.THandle; ARect: TRect);
     932procedure TBGRALCLBitmap.LoadFromDevice(DC: HDC; ARect: TRect);
    750933var
    751934  rawImage: TRawImage;
Note: See TracChangeset for help on using the changeset viewer.