txbutton.pas

Special picture button, easy configure... release. You only need one picture for pressed and one for

        tR.Left := 0;
        tR.Right := W;

        For T := Trunc(H/2)-1 to Height-Trunc(H/2) Do
        Begin
            { Destinaction }
            tR1.Top := T;
            tR1.Bottom := T+1;
            tR1.Left := 0;
            tR1.Right := W;

            FDrawImgNSel.Canvas.CopyRect(tR1, FDrawImgNSel.Canvas, tR);
        End;

        { Desna Ivica }
        { Source }
        tR.Top := 0;
        tR.Bottom := Height;
        tR.Left := Trunc(W/2);
        tR.Right := W;

        { Destinaction }
        tR1.Top := 0;
        tR1.Bottom := Height;
        tR1.Left := Width+tR.Left-tR.Right;
        tR1.Right := Width;

        FDrawImgNSel.Canvas.CopyRect(tR1, FDrawImgNSel.Canvas, tR);

        { Desno razvlacenje }
        { Source }
        tR.Top := 0;
        tR.Bottom := Height;
        tR.Left := Trunc(W/2)-1;
        tR.Right := Trunc(W/2);

        For T := Trunc(W/2)-1 to Width-Trunc(W/2) do
        Begin
            { Destinaction }
            tR1.Top := 0;
            tR1.Bottom := Height;
            tR1.Left := T;
            tR1.Right := T+1;

            FDrawImgNSel.Canvas.CopyRect(tR1, FDrawImgNSel.Canvas, tR);
        End;

         { Caption NSEl }
        FDrawImgNSel.Canvas.Font := FFont;
        FDrawImgNSel.Canvas.Brush.Style := bsClear;        
        FDrawImgNSel.Canvas.TextRect (Rect (4, 4, Width-4, Height-4),
          (Width - FDrawImgNSel.Canvas.TextWidth (AText)) div 2 + Integer (FDowned),
          (Height - FDrawImgNSel.Canvas.TextHeight (AText)) div 2 + Integer (FDowned), AText);

          If Pos ('&', FCaption) <> 0 then
          begin
            FDrawImgNSel.Canvas.Pen.Color := FDrawImgNSel.Canvas.Font.Color;
            FDrawImgNSel.Canvas.Pen.Width := 1;
            FDrawImgNSel.Canvas.MoveTo (((Width - FDrawImgNSel.Canvas.TextWidth (AText)) div 2) + FDrawImgNSel.Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption)-1)) + Integer (FDowned),
                           ((Height - FDrawImgNSel.Canvas.TextHeight (AText)) div 2) + FDrawImgNSel.Canvas.TextHeight (AText) + Integer (FDowned));
            FDrawImgNSel.Canvas.LineTo (((Width - FDrawImgNSel.Canvas.TextWidth (AText)) div 2) + Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption))) + Integer (FDowned),
                           ((Height - FDrawImgNSel.Canvas.TextHeight (AText)) div 2) + FDrawImgNSel.Canvas.TextHeight (AText) + Integer (FDowned));
          end;

        Antialiasing(FDrawImgNSel, (Width - FDrawImgNSel.Canvas.TextWidth (AText)) div 2,
            (Height - FDrawImgNSel.Canvas.TextHeight (AText)) div 2,
            Width-((Width - FDrawImgNSel.Canvas.TextWidth (AText)) div 2),
            Height-((Height - FDrawImgNSel.Canvas.TextHeight (AText)) div 2 ) );
          

        FDrawImgNEna.Assign( FDrawImgNSel );
        GrayScale( FDrawImgNEna );

End;

procedure TTButton.Paint;
begin
{
  AText := FCaption;
  If Pos ('&', FCaption) <> 0 then Delete (AText, Pos ('&', AText), 1);
 }
  If (FDrawImgSel.Height <> Height) or
    (FDrawImgSel.Width <> Width) Then
        ImageResize;

    Canvas.Brush.Style := bsClear;
{    Canvas.Font := FFont;}

    If Enabled Then
    Begin
        If FDowned then
        begin
            Canvas.CopyMode := cmNotSrcCopy;
            Canvas.Draw(0, 0, FDrawImgSel );
        end
        else If FFocused or FExecuted then
        begin
            Canvas.CopyMode := cmSrcCopy;
            Canvas.Draw(0, 0, FDrawImgSel );
        end
        else
        begin
            Canvas.CopyMode := cmSrcCopy;        
            Canvas.Draw(0, 0, FDrawImgNSel );
        End;
    End
    Else
    Begin
        Canvas.Draw(0, 0, FDrawImgNEna );
{        Canvas.Font.Color := RGB (161, 161, 146);}
    End;

{    Canvas.TextRect (Rect (4, 4, Width-4, Height-4),
      (Width - Canvas.TextWidth (AText)) div 2 + Integer (FDowned),
      (Height - Canvas.TextHeight (AText)) div 2 + Integer (FDowned), AText);

  if Pos ('&', FCaption) <> 0 then
  begin
    Canvas.Pen.Color := Canvas.Font.Color;
    Canvas.Pen.Width := 1;
    Canvas.MoveTo (((Width - Canvas.TextWidth (AText)) div 2) + Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption)-1)) + Integer (FDowned),
                   ((Height - Canvas.TextHeight (AText)) div 2) + Canvas.TextHeight (AText) + Integer (FDowned));
    Canvas.LineTo (((Width - Canvas.TextWidth (AText)) div 2) + Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption))) + Integer (FDowned),
                   ((Height - Canvas.TextHeight (AText)) div 2) + Canvas.TextHeight (AText) + Integer (FDowned));
  end;
}
    Canvas.Brush.Style := bsClear;
end;


procedure TTButton.MouseEnter (var Message : TMessage);
begin
 If Enabled and (not FFocused) Then
 Begin
  Try
    SetFocus;
    Paint;
  except
  end;
 End;
end;


procedure TTButton.MouseLeave (var Message : TMessage);
begin
 If Enabled Then
 Begin
    FFocused := False;
    Paint;
 End;
end;

procedure TTButton.SetCaption (ACaption : TCaption);
begin
  if FCaption <> ACaption then
  Begin
    FCaption := ACaption;
    if (Pos ('&', FCaption) <> 0) and (Pos ('&', FCaption) < Length (FCaption)) then
      FHotKey := UpperCase (String (Copy (FCaption, Pos ('&', FCaption)+1, 1)))[1]
    else
      FHotKey := #0;
{    ImageResize;}
    Repaint;
  end;
end;

function  TTButton.GetCaption : TCaption;
begin
  Result := FCaption;
end;

{procedure TTButton.SetDowned (ADowned : Boolean);
begin
  if FDowned <> ADowned then
  Begin
    FDowned := ADowned;
    Repaint;
  end;
end;

function  TTButton.GetDowned : Boolean;
begin
  Result := FDowned;
end;
}

procedure TTButton.SetFont (AFont : TFont);
begin
  FFont.Assign (AFont);
  RePaint;
end;

function  TTButton.GetFont : TFont;
begin
  Result := FFont;
end;


procedure TTButton.LMouseDblClick  (var Message : TMessage);
begin
  FOnButtonClick;
end;



procedure TTButton.LMouseDown  (var Message : TMessage);
begin
  if not FDowned then
  begin
    FDowned := true;
    if (not Focused) and (Enabled) then SetFocus;
    Repaint;
  end;
end;


{
procedure TTButton.RMouseDown  (var Message : TMessage);
begin

end;
}



procedure TTButton.LMouseUp  (var Message : TMessage);
begin
  if FDowned then
  begin
    FDowned := False;
    Repaint;
    FOnButtonClick;
  end;
end;


{
procedure TTButton.RMouseUp  (var Message : TMessage);
begin

end;
}

procedure TTButton.CMEnter(var Message: TCMGotFocus);
begin
  inherited;
  if Assigned (FOnEnter) then FOnEnter (self);
end;


procedure TTButton.CMExit(var Message: TCMLostFocus);
begin
  inherited;
  if Assigned (FOnExit) then FOnExit (self);
end;



procedure TTButton.WMSetFocus(var Message: TMessage);
begin
{    Blend;}
  if Enabled and (not FFocused) then
  begin
    FFocused := true;
    Invalidate;
  end;
end;


procedure TTButton.WMKillFocus(var Message: TMessage);
begin
  if FFocused then
  begin
    FFocused := False;
    Invalidate;
  end;
end;


procedure TTButton.WMKeyDown (var Message: TMessage);
begin
  if (not FDowned) and ((Message.WParam = VK_RETURN) or (Message.WParam = VK_SPACE)) then
  Begin
    FDowned := true;
    Invalidate;
  end;
  inherited;
end;


procedure TTButton.WMKeyUp (var Message: TMessage);
Begin
  if FDowned then
  begin
    FDowned := False;
    Invalidate;
    FOnButtonClick;
  end;
  inherited;
end;


procedure TTButton.SetModalResult (AModalResult : TModalResult);
begin
  FModalResult := AModalResult;
end;

function  TTButton.GetModalResult : TModalResult;
begin
  Result := FModalResult;
end;

procedure TTButton.FOnButtonClick;
begin
 If Enabled Then
 Begin
  if (not Focused) and (Enabled) then SetFocus;
   
  If not FExecuted Then FExecuted := True;
  RePaint;

  If Assigned (FOnClick) then
  Begin
    FOnClick (Self);
  End;
  If (FModalResult <> mrNone) and (Owner.InheritsFrom (TCustomForm)) then
    (Owner as TCustomForm).ModalResult := FModalResult;

  FExecuted := False;
 End;
end;


procedure TTButton.CMDialogChar(var Message : TCMDialogChar);
begin
  if Enabled and IsAccel (Message.CharCode, FCaption) then
    FOnButtonClick;
end;

Procedure TTButton.SetImgNSel(Pic:TPicture);
Begin
    FImgNSel.Assign(Pic);

{    FDrawImgNSel.Ass := FImgNSel.Bitmap;}
End;

Procedure TTButton.SetImgSel(Pic:TPicture);
Begin
    FImgSel.Assign(Pic);

      If (FDrawImgSel.Height <> Height) or
        (FDrawImgSel.Width <> Width) Then
            ImageResize;

{    FDrawImgSel := FImgSel.Bitmap;}
End;

procedure TTButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  invalidate;
{  Paint;}
end;

procedure TTButton.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
  m.Result := LRESULT(False);
end;


{
Function Pt(B : TBitmap) : Pointer;
Begin
  Pt := B.Scanline[(B.Height-1)]
End;
{
procedure TTButton.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 TTButton.Blend;
var
  r : integer;
  bmpT : TBitmap;
begin
    bmpT := TBitmap.Create;
    bmpT.Assign( FDrawImgSel );
  for r := 0 to 250 do
  begin
      Blendit(Pt(FDrawImgNSel),Pt(bmpT),Pt(FDrawImgSel),Width,Height,(r*$20 Div 250));
      Paint;
{      if FProcMsg = TRUE then
        Application.ProcessMessages;
}
{        if FFinish = TRUE then begin
          Complete;
          Exit;
        end;
}
{  end;

end;
 }


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


end.