harmfade.pas

一款很漂亮的按钮组件Delphi,有源码哦。

  end;
  Repaint;
  FreeMem(FPnts, FNumPix * SizeOf(TPoint));

  if FAutoRev = TRUE then begin
    Sleep(FDelay * 1000);
    if FRevSwap = TRUE then
      UnBlend
    else
      UnDissolve;
  end;
  if Assigned (FOnEnd) then FOnEnd(Self);
end;

procedure THarmFade.UnDissolve;
var
  x, y, n, r, l : integer;
  Block : integer;
  ba, bb : pByteArray;
  cTmp : TColor;
  pTmp : TPicture;
  lasttime : TDateTime;
  waittime : Integer;
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;
  SetPnts;
  Block := FNumPix Div FDRate;

  lasttime := now;
  for r := 0 to ((FNumPix Div Block)-1) do begin
    for n := (r * Block) to ((r * Block) + Block - 1) do begin
      x := Fpnts^[n].x;
      y := Fpnts^[n].y;
      ba := bmT.ScanLine[x];
      bb := bmF.ScanLine[x];
      for l := 0 to 2 do
        bb[(y*3) + l] := ba[(y*3) + l];
    end;
    Repaint;

    lasttime := lasttime+MsecperFrame/(24*60*60*1000);
    waittime := round( 24*60*60*1000*( lasttime-now ) );  // Waittime calculation
    if waittime<0 then waittime := 0;                                           // Safty

    if FProcMsg = TRUE then begin                                               // begin end
      repeat
        Application.ProcessMessages;
      until now>lasttime;                                                       // another kind of Sleep !!!

      if FFinish = TRUE then begin
        FinishIt;
        FreeMem(FPnts, FNumPix * SizeOf(TPoint));
        Exit;
      end;
    end else Sleep( Waittime )                                                  // begin end
  end;
  for n := ((FNumPix div Block) * Block) to (FNumPix-1) do begin
    x := Fpnts^[n].x;
    y := Fpnts^[n].y;
    ba := bmT.ScanLine[x];
    bb := bmF.ScanLine[x];
    for l := 0 to 2 do
      bb[(y*3) + l] := ba[(y*3) + l];
  end;
  Repaint;
  FreeMem(FPnts, FNumPix * SizeOf(TPoint));
  Reset;
end;

procedure THarmFade.FinishIt;
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 THarmFade.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 THarmFade.Blend;
var
  r : integer;
  lasttime : TDateTime;
  waittime : Integer;
begin
  Reset;
  if FBRate < 1 then
    raise EHarmFade.Create('BlendRate must be between 0 and 256');
  if Assigned (FOnBegin) then FOnBegin(Self);
  bmZ.Canvas.Draw(0, 0, bmF);
  lasttime := now;
  for r := 0 to FBRate do begin
    Blendit(Pt(bmZ),Pt(bmT),Pt(bmF),bmF.Width,bmF.Height,(r*$20 Div FBRate));
    RePaint;


    lasttime := lasttime+MsecperFrame/(24*60*60*1000);
    waittime := round( 24*60*60*1000*( lasttime-now ) );  // Waittime calculation
    if waittime<0 then waittime := 0;                                           // Safty

    if FProcMsg = TRUE then begin
      repeat
        Application.ProcessMessages;
      until now>lasttime;                                                       // another kind of Sleep !!!
      if FFinish = TRUE then begin
        FinishIt;
        Exit;
      end;
    end else Sleep( Waittime )                                                  // begin end

  end;

  if FAutoRev = TRUE then begin
    Sleep(FDelay * 1000);
    if FRevSwap = TRUE then
      UnDissolve
    else
      UnBlend;
  end;
  if Assigned (FOnEnd) then FOnEnd(Self);
end;

procedure THarmFade.UnBlend;
var
  r : integer;
  pTmp : TPicture;
  cTmp : TColor;
  lasttime : TDateTime;
  waittime : Integer;
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);
  lasttime := now;
  for r := 0 to FBRate do begin
    Blendit(Pt(bmZ),Pt(bmT),Pt(bmF),bmF.Width,bmF.Height,(r*$20 Div FBRate));
    RePaint;

    lasttime := lasttime+MsecperFrame/(24*60*60*1000);
    waittime := round( 24*60*60*1000*( lasttime-now ) );  // Waittime calculation
    if waittime<0 then waittime := 0;                                           // Safty

    if FProcMsg = TRUE then begin
      repeat
        Application.ProcessMessages;
      until now>lasttime;                                                       // another kind of Sleep !!!
      if FFinish = TRUE then begin
        FinishIt;
        Exit;
      end;
    end else Sleep( Waittime )                                                  // begin end

  end;
  Reset;

end;

procedure THarmFade.WMPosChg(var Msg : TMessage);
begin
  Reset;
  Invalidate;
  inherited;
end;

procedure THarmFade.CMMouseEnter(var Msg:TMessage);
begin
  inherited;
  if Assigned (FOnMouseEnter) then FOnMouseEnter(Self);
end;

procedure THarmFade.CMMouseLeave(var Msg:TMessage);
begin
  inherited;
  if Assigned (FonMouseLeave) then FOnMouseLeave(Self);
end;

procedure THarmFade.chgPicF(Sender : TObject);
begin
  if FReverst = TRUE then Exit;
  Reset;
  Invalidate;
end;

procedure THarmFade.chgPicT(Sender : TObject);
begin
  if FReverst = TRUE then Exit;
  Reset;
  Invalidate;
end;

procedure THarmFade.SetpicFrom(Pic : TPicture);
begin
  FPicFrom.Assign(Pic);
end;

procedure THarmfade.SetpicTo(Pic : TPicture);
begin
  FPicTo.Assign(Pic);
end;

procedure THarmFade.SetclFrom(Col : TColor);
begin
  if FclFrom <> Col then begin
    FclFrom := Col;
    bmF.Canvas.Brush.Color := Col;
    Reset;
    Invalidate;
  end;
end;

procedure THarmFade.SetclTo(Col : TColor);
begin
  if FclTo <> Col then begin
    FclTo := Col;
    bmT.Canvas.Brush.Color := Col;
    Reset;
    Invalidate;
  end;
end;

procedure THarmFade.SetDRate(Val : integer);
begin
  if FDRate <> Val then
    FDRate := Val;
  if FDRate < 1 then
    FDRate := 1;
  if FDRate > (Width * Height) then
    FDRate := Width * Height;
end;

procedure THarmFade.SetBRate(Val : integer);
begin
  if FBRate <> Val then
    FBRate := Val;
  if FBRate < 1 then
    FBRate := 1;
 // if FBRate > 255 then
 //   FBRate := 255;
end;

procedure THarmFade.SetStretch(Val : Boolean);
begin
  if FStretch <> Val then begin
    FStretch := Val;
    Reset;
    Invalidate;
  end;
end;

procedure THarmFade.SetProcMsg(Val : Boolean);
begin
  if FProcMsg <> Val then
    FProcMsg := Val;
end;

procedure THarmFade.SetAutoRev(Val : Boolean);
begin
  if FAutoRev <> Val then
    FAutoRev := Val;
end;

procedure THarmFade.SetRevSwap(Val : Boolean);
begin
  if FRevSwap <> Val then
    FRevSwap := Val;
end;

procedure THarmFade.SetDelay(Val : integer);
begin
  if FDelay <> Val then
    FDelay := Val;
end;

destructor THarmFade.Destroy;
begin
  FPicFrom.Free;
  FPicTo.Free;
  bmF.Free;
  bmT.Free;
  bmZ.Free;
  inherited Destroy;
end;

procedure Register;
begin
  RegisterComponents('Samples', [THarmFade]);
end;

end.