[Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1878
  • Last Modified:

Blend 2 PNG images (morph from one to another)

I've come around with a few demos to do this like shown below, but those work only for bitmaps. I've tried doing this with Graphics32 library but to no avail. The first example shows pretty much the desired effect/

I want to blend 2 PNG images, morphing one into another (end result is only 2nd image)

It must work with alpha channel and remain transparent. I have D2009 so it can use either pngimage, G32's bitmap32 or delphi's bitmap (which now supports 32bit mode)

for a := 0 to 85 do
  begin
  MergeBitmaps(image1.Picture.bitmap,image2.Picture.bitmap,image3.Picture.bitmap,a*3);
   Application.ProcessMessages;
  end;
 
 
 
procedure MergeBitmaps(BM1, BM2, BM3 : TBitmap; Alpha : byte);
var
  bf:TBlendFunction;
begin
//if not Assigned(BM3) then BM3:= TBitmap32.Create;
BM3.Assign(BM1);
bf.BlendOp:=AC_SRC_OVER;
bf.BlendFlags:=0;
bf.SourceConstantAlpha:=Alpha;//0-255
bf.AlphaFormat:=0;// not use alpha-channel of bmp2
 
//if sizes of your source bmps are different, try uncomment
// and see result
//BM2.Width:=BM3.Width;
//BM2.Height:=BM3.Height;
 
AlphaBlend(BM3.Canvas.Handle,0,0,BM3.Width,BM3.Height,
   BM2.canvas.handle,0,0,BM2.Width,BM2.Height,bf);
end;
 
--------------------------------------------------------------------
 
This also works nicely, but again only 24b bitmaps
 
 
 
unit BSMorphButton;
 
interface
 
uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs , extctrls;
 
const
  Maxize = (1294967280 Div SizeOf(TPoint));
  MaxPixelCount   =  32768;
  Mask0101 = $00FF00FF;
  Mask1010 = $FF00FF00; 
 
type
  EMorphButton = class(Exception);
 
  PRGBArray  =  ^TRGBArray;
  TRGBArray  =  array[0..MaxPixelCount-1] of TRGBTriple;
 
  TPnts = array[0..Maxize - 1] of TPoint;
 
  TBSMorphButton = class(TGraphicControl)
  private
    {Private Declarations}
    bmF      : TBitmap;
    bmT      : TBitmap;
    bmZ      : TBitmap;
    FPicFrom : TPicture;
    FPicTo   : TPicture;
    FclFrom  : TColor;
    FclTo    : TColor;
    FBRate   : integer;
    FStretch : Boolean;
    FProcMsg : Boolean;
    FFinish  : Boolean;
    FOnBegin : TNotifyEvent;
    FOnEnd   : TNotifyEvent;
    FOnReset : TNotifyEvent;
    FAutoRev : Boolean;
    FRevSwap : Boolean;
    FReverst : Boolean;
    FStrTmp  : Boolean;
    FDelay   : integer;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    procedure CMMouseEnter(var Msg:TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg:TMessage); message CM_MOUSELEAVE;
    procedure chgPicF(Sender : TObject);
    procedure chgPicT(Sender : TObject);
    procedure WMEraseBkgnd(Var Msg : TMessage); message WM_ERASEBKGND;
    procedure SetpicFrom(Pic : TPicture);
    procedure SetpicTo(Pic : TPicture);
    procedure SetclFrom(Col : TColor);
    procedure SetclTo(Col : TColor);
    procedure SetBRate(Val : integer);
    procedure SetStretch(Val : Boolean);
    procedure SetProcMsg(Val : Boolean);
    procedure Blend;
    procedure UnBlend;
    procedure Blendit(bFr,bTo,bLn : Pointer ; Width,Height : Integer ; Dens : LongInt);
  protected
    procedure WMPosChg(var Msg : TMessage); message WM_WINDOWPOSCHANGED;
  public
    {Public Declarations}
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure Reset;
    procedure Complete;
    property Finish : Boolean read FFinish write FFinish default FALSE;
  published
    {Published Declarations}
    property MorphPic1 : TPicture read FPicFrom write SetpicFrom;
    property MorphPic2 : TPicture read FPicTo write SetpicTo;
    property MorphColor1 : TColor read FclFrom write SetclFrom default clBlack;
    property MorphColor2 : TColor read FclTo write SetclTo default clWhite;
    property MorphRate : integer read FBRate write SetBRate default 32;
    property StretchToFit : Boolean read FStretch write SetStretch default TRUE;
    property ProcessMsgs : Boolean read FProcMsg write SetProcMsg default TRUE;
    property Hint;
    property OnClick;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
  end;
 
procedure Register;
 
//{$R Data.res}
 
implementation
 
const HandCursor = 31;
 
Var
  EBX, ESI, EDI, ESP, EBP,
  FinA,
  Dens1, Dens2 : Longint;
 
 
constructor TBSMorphButton.Create(AOwner : TComponent);
Var
 Temp1:TBitmap;
begin
  inherited Create(AOwner);
  Screen.Cursors[HandCursor]:=LoadCursor (hInstance , 'CUR');
  Cursor:=HandCursor;
  FclFrom := clBlack;
  FclTo := clWhite;
  FBRate := 250;
  FStretch := TRUE;
  FStrTmp := TRUE;
  FProcMsg := TRUE;
  FFinish := FALSE;
  FAutoRev := FALSE;
  FRevSwap := TRUE;
  FReverst := FALSE;
  FDelay := 1;
  ControlStyle := ControlStyle + [csOpaque] + [csNoStdEvents];
 
 // Temp1:=TBitmap.Create;
 
 // Temp1.LoadFromResourceName (HInstance,'B1');
  FPicFrom := TPicture.Create;
 //  FPicFrom.Bitmap:=Temp1;
 
 // Temp1.LoadFromResourceName (HInstance,'B2');
  FPicTo := TPicture.Create;
 //  FPicTo.Bitmap:=Temp1;
 
  bmF := TBitmap.Create;
  bmT := TBitmap.Create;
  bmZ := TBitmap.Create;
  bmZ.PixelFormat := pf24bit;
  bmF.Canvas.Brush.Color := clBlack;
  FPicFrom.OnChange := chgPicF;
  FPicTo.OnChange := chgPicT;
  Width := 120;
  Height := 50;
  bmF.Width := Width;
  bmF.Height := Height;
end;
 
procedure DoIco(I : TGraphic; B : TBitmap; C : TColor; W : integer; H : integer);
var
  bmIco : TBitmap;
begin
  bmIco := TBitmap.Create;
  bmIco.Width := I.Width;
  bmIco.Height := I.Height;
  bmIco.Canvas.Brush.Color := C;
  bmIco.Canvas.FillRect(RECT(0,0,bmIco.Width,bmIco.Height));
  bmIco.Canvas.Draw(0,0,I);
  B.Canvas.StretchDraw(RECT(0,0,W,H),bmIco);
  bmIco.Free;
end;
 
procedure TBSMorphButton.Reset;
var
  pTmp : TPicture;
  cTmp : TColor;
begin
 
  bmF.PixelFormat := pf24bit;
  bmT.PixelFormat := pf24bit;
  bmZ.PixelFormat := pf24bit;
 
  if FReverst = TRUE then begin
    cTmp := FclFrom;
    FclFrom := FclTo;
    FclTo := cTmp;
    pTmp := TPicture.Create;
    pTmp.Assign(FPicFrom);
    FPicFrom.Assign(FPicTo);
    FPicTo.Assign(pTmp);
    bmF.Canvas.Brush.Color := FclFrom;
    bmT.Canvas.Brush.Color := FclTo;
    FReverst := FALSE;
    pTmp.Free;
    FStretch := FStrTmp;
  end;
 
  if FStretch = TRUE then begin
    bmF.Width := Width;
    bmF.Height := Height;
    if FPicFrom.Graphic = nil then
      bmF.Canvas.FillRect(RECT(0,0,Width,Height))
    else begin
      if FPicFrom.Graphic is TMetaFile then
        bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      if FPicFrom.Graphic is TIcon then begin
        DoIco(FPicFrom.Graphic, bmF, FclFrom, Width, Height);
      end
      else
      bmF.Canvas.StretchDraw(RECT(0,0,Width,Height),FPicFrom.Graphic);
    end;
    bmT.Width := Width;
    bmT.Height := Height;
    if FPicTo.Graphic = nil then
      bmT.Canvas.FillRect(RECT(0,0,Width,Height))
    else begin
      if FPicTo.Graphic is TMetaFile then
        bmT.Canvas.FillRect(RECT(0,0,Width,Height));
      if FPicTo.Graphic is TIcon then
        DoIco(FPicTo.Graphic, bmT, FclTo, Width, Height)
      else
      bmT.Canvas.StretchDraw(RECT(0,0,Width,Height),FPicTo.Graphic);
    end;
  end;
 
  if FStretch = FALSE then begin
    if (FPicTo.Graphic <> nil) and (FPicFrom.Graphic = nil) then begin
      Width := FPicTo.Width;
      Height := FPicTo.Height;
      bmT.Width := Width;
      bmT.Height := Height;
      if (FPicTo.Graphic is TMetaFile) or (FPicTo.Graphic is TIcon) then
        bmT.Canvas.FillRect(RECT(0,0,Width,Height));
      bmT.Canvas.Draw(0,0,FPicTo.Graphic);
      bmF.Width := Width;
      bmF.Height := Height;
      bmF.Canvas.FillRect(RECT(0,0,Width,Height));
    end;
    if (FPicFrom.Graphic <> nil) and (FPicTo.Graphic = nil) then begin
      Width := FPicFrom.Width;
      Height := FPicFrom.Height;
      bmF.Width := Width;
      bmF.Height := Height;
      if (FPicFrom.Graphic is TMetaFile) or (FPicFrom.Graphic is TIcon) then
        bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      bmF.Canvas.Draw(0,0,FPicFrom.Graphic);
      bmT.Width := Width;
      bmT.Height := Height;
      bmT.Canvas.FillRect(RECT(0,0,Width,Height));
    end;
    if (FPicFrom.Graphic = nil) and (FPicTo.Graphic = nil) then begin
      bmF.Width := Width;
      bmF.Height := Height;
      bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      bmT.Width := Width;
      bmT.Height := Height;
      bmT.Canvas.FillRect(RECT(0,0,Width,Height));
    end;
    if (FPicFrom.Graphic <> nil) and (FPicTo.Graphic <> nil) then begin
      Width := FPicFrom.Width;
      Height := FPicFrom.Height;
      bmF.Width := Width;
      bmF.Height := Height;
      if (FPicFrom.Graphic is TMetaFile) or (FPicFrom.Graphic is TIcon) then
        bmF.Canvas.FillRect(RECT(0,0,Width,Height));
      bmF.Canvas.Draw(0,0,FPicFrom.Graphic);
      bmT.Width := Width;
      bmT.Height := Height;
      if FPicTo.Graphic is TMetaFile then
        bmT.Canvas.FillRect(RECT(0,0,Width,Height));
      if FPicTo.Graphic is TIcon then begin
        DoIco(FPicTo.Graphic, bmT, FclTo, Width, Height);
      end
      else
      bmT.Canvas.StretchDraw(RECT(0,0,Width,Height),FPicTo.Graphic);
    end;
  end;
 
  bmZ.Width := bmF.Width;
  bmZ.Height := bmF.Height;
 
 
  Invalidate;
 
  if Assigned (FOnReset) then FOnReset(Self);
 
end;
 
 
procedure TBSMorphButton.WMEraseBkgnd(var Msg:TMessage);
begin
  Msg.Result := 1;
end;
 
procedure TBSMorphButton.Paint;
begin
 Canvas.Draw(0,0,bmF);
 Canvas.Brush.Style:=bsClear;
 
end;
 
 
 
procedure TBSMorphButton.Complete;
begin
  Canvas.Draw(0,0,bmT);
  if Assigned (FOnEnd) then FOnEnd(Self);
  FFinish := FALSE;
end;
 
Function Pt(B : TBitmap) : Pointer;
Begin
  Pt := B.Scanline[(B.Height-1)]
End;
 
procedure TBSMorphButton.Blendit(bFr,bTo,bLn : Pointer ; Width,Height : Integer ; Dens : LongInt); assembler;
 
ASM
 
  MOV &EBX, EBX
  MOV &EDI, EDI
  MOV &ESI, ESI
  MOV &ESP, ESP
  MOV &EBP, EBP
 
  MOV EBX, Dens 
  MOV Dens1, EBX
 
  NEG BL
  ADD BL, $20   
  MOV Dens2, EBX
  CMP Dens1, 0
  JZ  @Final
  MOV EDI, bFr
  MOV ESI, bTo
  MOV ECX, bLn
 
  MOV EAX, Width
  lea EAX, [EAX+EAX*2+3] 
  AND EAX, $FFFFFFFC
  IMUL Height
  ADD EAX, EDI
  MOV FinA, EAX
 
  MOV EBP,EDI
  MOV ESP,ESI
  MOV ECX,ECX
 
@LOOPA:  
  MOV  EAX, [EBP] 
  MOV  EDI, [ESP] 
  MOV  EBX, EAX   
  AND  EAX, Mask1010
  AND  EBX, Mask0101 
  SHR  EAX, 5       
  IMUL EAX, Dens2   
  IMUL EBX, Dens2   
  MOV  ESI, EDI     
  AND  EDI, Mask1010 
  AND  ESI, Mask0101 
  SHR  EDI, 5        
  IMUL EDI, Dens1    
  IMUL ESI, Dens1    
  ADD  EAX, EDI
  ADD  EBX, ESI     
  AND  EAX, Mask1010
  SHR  EBX, 5
  AND  EBX, Mask0101 
  OR   EAX, EBX      
  MOV [ECX], EAX     
 
  ADD  EBP, 4       
  ADD  ESP, 4
  ADD  ECX, 4
 
  CMP  EBP, FinA
  JNE  @LOOPA
 
@FINAL:
 
  MOV EBX, &EBX
  MOV EDI, &EDI
  MOV ESI, &ESI
  MOV ESP, &ESP
  MOV EBP, &EBP
 
End;
 
procedure TBSMorphButton.Blend;
var
  r : integer;
begin
  Reset;
  if FBRate < 1 then
    raise EMorphButton.Create('BlendRate must be between 0 and 256');
  if Assigned (FOnBegin) then FOnBegin(Self);
  bmZ.Canvas.Draw(0, 0, bmF);
  for r := 0 to FBRate do begin
  Blendit(Pt(bmZ),Pt(bmT),Pt(bmF),bmF.Width,bmF.Height,(r*$20 Div FBRate));
  RePaint;
  if FProcMsg = TRUE then
    Application.ProcessMessages;
 
    if FFinish = TRUE then begin
      Complete;
      Exit;
    end;
 
  end;
 
  if FAutoRev = TRUE then begin
    Sleep(FDelay * 1000);
  end;
  if Assigned (FOnEnd) then FOnEnd(Self);
end;
 
procedure TBSMorphButton.UnBlend;
var
  r : integer;
  pTmp : TPicture;
  cTmp : TColor;
begin
  FStrTmp := FStretch;
  FStretch := TRUE;
  bmF.Canvas.Brush.Color := FclTo;
  bmT.Canvas.Brush.Color := FclFrom;
  cTmp := FclFrom;
  FclFrom := FclTo;
  FclTo := cTmp;
  pTmp := TPicture.Create;
  pTmp.Assign(FPicFrom);
  FPicFrom.Assign(FPicTo);
  FPicTo.Assign(pTmp);
  pTmp.Free;
  Reset;
  FReverst := TRUE;
  bmZ.Canvas.Draw(0, 0, bmF);
  for r := 0 to FBRate do begin
  Blendit(Pt(bmZ),Pt(bmT),Pt(bmF),bmF.Width,bmF.Height,(r*$20 Div FBRate));
  RePaint;
  if FProcMsg = TRUE then
    Application.ProcessMessages;
 
    if FFinish = TRUE then begin
      Complete;
      Exit;
    end;
 
  end;
  Reset;
 
end;
 
procedure TBSMorphButton.WMPosChg(var Msg : TMessage);
begin
  Reset;
  Invalidate;
  inherited;
end;
 
procedure TBSMorphButton.CMMouseEnter(var Msg:TMessage);
begin
  inherited;
  if Assigned (FOnMouseEnter) then FOnMouseEnter(Self);
  Blend;
end;
 
procedure TBSMorphButton.CMMouseLeave(var Msg:TMessage);
begin
  inherited;
  if Assigned (FonMouseLeave) then FOnMouseLeave(Self);
  UnBlend;
end;
 
procedure TBSMorphButton.chgPicF(Sender : TObject);
begin
  if FReverst = TRUE then Exit;
  Reset;
  Invalidate;
end;
 
procedure TBSMorphButton.chgPicT(Sender : TObject);
begin
  if FReverst = TRUE then Exit;
  Reset;
  Invalidate;
end;
 
procedure TBSMorphButton.SetpicFrom(Pic : TPicture);
begin
  FPicFrom.Assign(Pic);
end;
 
procedure TBSMorphButton.SetpicTo(Pic : TPicture);
begin
  FPicTo.Assign(Pic);
end;
 
procedure TBSMorphButton.SetclFrom(Col : TColor);
begin
  if FclFrom <> Col then begin
    FclFrom := Col;
    bmF.Canvas.Brush.Color := Col;
    Reset;
    Invalidate;
  end;
end;
 
procedure TBSMorphButton.SetclTo(Col : TColor);
begin
  if FclTo <> Col then begin
    FclTo := Col;
    bmT.Canvas.Brush.Color := Col;
    Reset;
    Invalidate;
  end;
end;
 
procedure TBSMorphButton.SetBRate(Val : integer);
begin
  if FBRate <> Val then
    FBRate := Val;
  if FBRate < 1 then
    FBRate := 1;
  if FBRate > 255 then
    FBRate := 255;
end;
 
procedure TBSMorphButton.SetStretch(Val : Boolean);
begin
  if FStretch <> Val then begin
    FStretch := Val;
    Reset;
    Invalidate;
  end;
end;
 
procedure TBSMorphButton.SetProcMsg(Val : Boolean);
begin
  if FProcMsg <> Val then
    FProcMsg := Val;
end;
 
destructor TBSMorphButton.Destroy;
begin
  FPicFrom.Free;
  FPicTo.Free;
  bmF.Free;
  bmT.Free;
  bmZ.Free;
  inherited Destroy;
end;
 
procedure Register;
begin
  RegisterComponents('Samples', [TBSMorphButton]);
end;
 
end.

Open in new window

0
menorcanet
Asked:
menorcanet
1 Solution
 
JohnjcesCommented:
Are you wanting to load these png images from a file then morph them and display the morphed image or...

do you have the 2 images visible in your app and then wanting to show the morphed image.

It will make a difference on how we convert the png to a bitmap then back to png format.

John
0
 
bryan7Commented:
I have 2 PNGs in a resource. The first one is always loaded to a TImage. Sometimes I will load the 2nd one to the TImage, then the 1st one again after a few seconds. I want the 1st to blend into/become the 2nd one, then the same back to the first one.
0
 
stOrMCommented:
Hi,
you might want the same as I wanted for some weeks ago.
If you have access to the gr32 newsgroup then look in graphics32.general MessageID 8644

If not let me know I might find the source somewhere on my hdd's

Kindest regards
s!
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
menorcanetAuthor Commented:
I subscribed to the newsgroups, how can I find that Message ID there?
0
 
stOrMCommented:
Just search for my Nick stOrM! in the questions should be easy to find because there are only 2 questions there from myself...

regards
s!
0
 
stOrMCommented:
Ok found it for you!
Basically I used it for a mouse over effect on a button, so it will fade in and fade out 2 different pngs...

Hope it helps!
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, GR32, ExtCtrls, GR32_Image, GraphicEx {or PngImage};
 
type
  TForm1 = class(TForm)
    Image321: TImage32;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Image321MouseEnter(Sender: TObject);
    procedure Image321MouseLeave(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Background, Foreground: TBitmap32;
    MasterAlpha : Integer;
    AlphaAdd: Integer;
  end;
 
var
  Form1: TForm1;
 
const
  FADESPEED = 5;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Background := TBitmap32.Create;
  Background.DrawMode := dmBlend;
  Background.CombineMode := cmMerge;
  Background.LoadFromFile('Background.png');
 
  Foreground := TBitmap32.Create;
  Foreground.DrawMode := dmBlend;
  Foreground.CombineMode := cmMerge;
  Foreground.LoadFromFile('Foreground.png');
 
  MasterAlpha := 0;
 
  Image321.Bitmap.Assign(Background);
end;
 
procedure TForm1.Image321MouseEnter(Sender: TObject);
begin
  AlphaAdd := FADESPEED;
  Timer1.Enabled := True;
end;
 
procedure TForm1.Image321MouseLeave(Sender: TObject);
begin
  AlphaAdd := - FADESPEED;
  Timer1.Enabled := True;
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Inc(MasterAlpha, AlphaAdd);
  
  if MasterAlpha > 255 then
  begin
    MasterAlpha := 255;
    Timer1.Enabled := False;
    Exit;
  end else
  if MasterAlpha < 0 then
  begin
    MasterAlpha := 0;
    Timer1.Enabled := False;
    Exit;
  end;
 
  Image321.Bitmap.Assign(Background);
  Foreground.MasterAlpha := MasterAlpha;
  Image321.Bitmap.Draw(0, 0, Foreground);
 
  Image321.Repaint;
end;
 
end.

Open in new window

0
 
menorcanetAuthor Commented:
Hi, sorry about the delay.

The example works great, but it has a problem: no transparency:

The picture at the left is the Image32. The other 2 are normal TImages  using the source images Background and Foreground (using pngimage, since GraphicEx doesn't load the transparency properly even for those 2)


Cropped-Capture---00018.jpg
0
 
stOrMCommented:
Hi,
from what I know you cant with Image32, maybe at least with layers but not sure about it. That questions was often asked in the newsgroup how to make e.g. the background of image32 transparent havent seen an answer yet.

regards
s!
0
 
stOrMCommented:
btw thats my result also not much better then yours
Capture.png
0
 
menorcanetAuthor Commented:
I'll try digging some more into TImage32, since delphi 2009 now supports 32bit bitmaps natively, maybe we can come up with a new solution.

By the way, that background and button look like those from Kaspersky
0
 
stOrMCommented:
Would be nice if you can come up with a better solution.
It would be fine if you let me know when you get it done, because I'm currently make use of the windows search api, where later my gui needs some touch ups :-)

In the moment I'm using the usuaally UpdateLayeredWindows stuff but thats not a good solution working with a fake window to get the controls drawn thought.

btw. Yep thats kaspersky I don't wanted to fire up photoshop and draw a button for this example :-)

regards
s!
0
 
menorcanetAuthor Commented:
"working with a fake window to get the controls drawn thought "

yeah I'm doing the same, it's kinda troublesome but does the trick for now
0
 
menorcanetAuthor Commented:
Hi, haven't come up with anything better as of yet.
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now