tranbtn.pas

是一款针对啤酒行业的销售进销存管理系统,包括基本的进货,销售,库存

unit PicButton;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, StdCtrls, ExtCtrls;

type
  BStyle = (BSnone,BsNormal,BsIe,BsGrad);
  //TGradientStyle = (gsHorizontal, gsVertical, gsElliptic, gsRectangle,
  //                  gsVertCenter, gsHorizCenter);
  TPicButton = class(TGraphicControl)
  private
    FBitMap : TBitmap;
    FOver : Boolean;
    Pushed : boolean;
    Fborder : BStyle;
    BRect : Trect;
    FXAngle:integer;
    FYAngle:integer;
    //FBeginCrl:Tcolor;
    //FEndCrl:Tcolor;
    //FGradientStyle:TGradientStyle;
    //FPopupMenu:TPopupMenu;
    procedure SetBitMap(Value : TBitMap);
    procedure WMLButtonDown(var msg: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var msg: TWMLButtonUp); message WM_LBUTTONUP;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    function OnGlyphP(X, Y: integer): boolean;
    procedure mouseleave(var msg : tmessage); message cm_mouseleave;
    procedure mousein(var msg : tmessage); message cm_mouseenter;
    Procedure setborderstyle(value:Bstyle);
    Procedure SetRoundXAngle(Value:integer); //2002.12.02
    Procedure SetRoundYAngle(Value:integer); //2002.12.02
    //procedure SetBeginColor(Value:Tcolor);  //2002.12.18
    //procedure SetEndColor(Value:Tcolor);   //2002.12.18
    //procedure SetGradientStyle(Value:TGradientStyle);
    //function Muldv(a,b,c : integer) : longint; //2002.12.18 计算颜色
    ///procedure DoHorizCenter(fr, fg, fb, dr, dg, db : Integer);
  protected
    procedure Paint; override;
    // procedure Notification(AComponent: TComponent; Operation:TOperation);override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    procedure DrawTransparentBitmap (ahdc: HDC; Image: TBitmap; xStart, yStart: Word; TrCol : Tcolor);
    property BitMap : TBitMap read FBitMap write SetBitMap;
    Property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
   // property Popupmenu:TPopupMenu read FPopupMenu write FPopupMenu;
    property Visible;
    Property Hint;
    Property ShowHint;
    property PopUpMenu;
    Property Border : BStyle read fborder write SetBorderStyle;
    //new add Angle property and can change button shape
    property XAngle :integer read FXAngle write SetRoundXAngle;
    property YAngle :integer read FYAngle write SetRoundYAngle;
    //new add color
    //property GradientStyle:TGradientStyle read FGradientStyle write SetGradientStyle;
    //property BeginColor:Tcolor read FBeginCrl write SetBeginColor;
    //property EndColor:Tcolor read FEndCrl write SetEndColor;
    Property Caption;
    Property Font;
  end;

procedure Register;

implementation

constructor TPicButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 30;
Height := 30;
FBitMap := TBitMap.Create;
ControlStyle := ControlStyle - [csOpaque];
Pushed := false;
Font.name := 'Arial';
Font.size := 9;
Fborder := BsNormal;
end;

destructor TPicButton.Destroy;
begin
FBitMap.Free;
inherited Destroy;
end;
//new add calc color//
{function TMTranBtn.Muldv(a,b,c : integer) : longint;
ASM
  MOV EAX, a
  IMUL b
  IDIV c
end;
///设置开始颜色值//
procedure TMTranBtn.SetBeginColor(Value:Tcolor);
begin
   if FBeginCrl<>Value then
   begin
      FBeginCrl:=Value;
      Invalidate;
   end;
end;
//设置结束颜色值
procedure TMTranBtn.SetEndColor(Value:Tcolor);
begin
   if FEndCrl<>Value then
   begin
      FEndCrl:=Value;
      Invalidate;
   end;
end;
//设置梯度颜色模式//
procedure TMTranBtn.SetGradientStyle(Value:TGradientStyle);
begin
   if FGradientStyle<>Value then
   begin
      FGradientStyle:=Value;
      Invalidate;
   end;
end;
}
procedure TPicButton.SetBitMap(Value : TBitMap);
begin
 FBitMap.Assign(Value);
 invalidate;
end;
procedure TPicButton.SetRoundXAngle(Value:integer);
begin
   if FXAngle<>value then
   begin
      FXAngle:=value;
      invalidate;
   end;
end;
procedure TPicButton.SetRoundYAngle(Value:integer);
begin
   if FYAngle<>value then
   begin
      FYAngle:=value;
      invalidate;
   end;
end;
{this routine come from unit XparBmp of Michael Vincze ([e-mail]), I think it can be
optimized more. Will find time to check it again}
procedure TPicButton.DrawTransparentBitmap (ahdc: HDC; Image: TBitmap; xStart, yStart: Word; TrCol : Tcolor);
var
  TransparentColor: TColor;
  cColor          : TColorRef;
  bmAndBack,
  bmAndObject,
  bmAndMem,
  bmSave,
  bmBackOld,
  bmObjectOld,
  bmMemOld,
  bmSaveOld       : HBitmap;
  hdcMem,
  hdcBack,
  hdcObject,
  hdcTemp,
  hdcSave         : HDC;
  ptSize          : TPoint;
begin
TransparentColor := TrCol;
TransparentColor := TransparentColor or $02000000;

hdcTemp := CreateCompatibleDC (ahdc);
SelectObject (hdcTemp, Image.Handle); { select the bitmap }
ptSize.x := Image.Width;
ptSize.y := Image.Height;
DPtoLP (hdcTemp, ptSize, 1);  { convert from device logical points }
hdcBack   := CreateCompatibleDC(ahdc);
hdcObject := CreateCompatibleDC(ahdc);
hdcMem    := CreateCompatibleDC(ahdc);
hdcSave   := CreateCompatibleDC(ahdc);

bmAndBack   := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

bmAndMem    := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
bmSave      := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

bmBackOld   := SelectObject (hdcBack, bmAndBack);
bmObjectOld := SelectObject (hdcObject, bmAndObject);
bmMemOld    := SelectObject (hdcMem, bmAndMem);
bmSaveOld   := SelectObject (hdcSave, bmSave);

SetMapMode (hdcTemp, GetMapMode (ahdc));
BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);
cColor := SetBkColor (hdcTemp, TransparentColor);
BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

SetBkColor (hdcTemp, cColor);
BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT);
BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);
DeleteObject (SelectObject (hdcBack, bmBackOld));
DeleteObject (SelectObject (hdcObject, bmObjectOld));
DeleteObject (SelectObject (hdcMem, bmMemOld));
DeleteObject (SelectObject (hdcSave, bmSaveOld));
DeleteDC (hdcMem);
DeleteDC (hdcBack);
DeleteDC (hdcObject);
DeleteDC (hdcSave);
DeleteDC (hdcTemp);
end;

procedure TPicButton.setborderstyle(value:Bstyle);
begin
if Fborder <> value then
 begin
  Fborder := value;
  Invalidate;
 end;
end;

procedure TPicButton.Paint;
var
  ARect: TRect;
  Tmp : TBitMap;
  x,y : integer;
  text : array[0..40] of char;
  Fontheight : integer;
  ///new add variant
  //FromR, FromG, FromB : Integer; //These are the separate color values for RGB
  //DiffR, DiffG, DiffB : Integer; // of color values.
  //rct : TRect;                   //Rectangle used to draw frame around button
  //offset : Integer;              //Used for Caption location during Mouse Down
  //i: integer;

begin
ARect := Rect(0,0,Width,Height);
Canvas.font := font;
FontHeight := Canvas.TextHeight('W');
if not FBitMap.empty then
  begin
  x := (width - FBitMap.width) div 2;
  if caption <> '' then
    y := ((Height - FBitMap.Height- FontHeight) div 2)
  else
   y := ((Height - FBitMap.Height) div 2);
     BRect := rect(x, y, x + FBitMap.width, y + FBitMap.height);
     Tmp := TBitmap.Create;
     Tmp.Height := FBitMap.Height;
     Tmp.Width := FBitMap.Width;
     Tmp.Canvas.CopyRect(ARect, FBitmap.Canvas, ARect);
     if pushed then
      DrawTransparentBitmap( Canvas.Handle, Tmp, x +1, y+1, FBitmap.TransparentColor )
     else
      DrawTransparentBitmap( Canvas.Handle, Tmp, x, y, FBitmap.TransparentColor );
     Tmp.Free;
  end;

  if caption <> '' then
  with Canvas do
  begin
   Brush.Style := bsClear;
   with ARect do
    begin
     if Fbitmap.empty then
       Top := ((Bottom + Top) - FontHeight) shr 1
     else
       top := Brect. bottom;
      Bottom := Top + FontHeight;
      if pushed then
        begin
         top := top + 1;
         left := 2;
        end;
    end;
    StrPCopy(Text, Caption);
    DrawText(Handle, Text, StrLen(Text), ARect, (DT_EXPANDTABS or DT_center));
   end;

 ARect := getclientrect;
 case fborder of
 BsNormal : BEGIN
            if pushed then
                frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
            else
                frame3d(canvas, ARect ,clBtnHighlight,clBtnShadow, 1);
            END;
 BsIe :  Begin
         if pushed then
            frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
         else
          if Fover then
            frame3d(canvas, ARect ,clBtnHighlight,clBtnShadow, 1);
         end;
 BsGrad: begin
          if pushed then
                //frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
              begin
                  canvas.Brush.Style:=bsclear;
                  canvas.Pen.Color:=rgb(255,94,32);
                  canvas.RoundRect(Arect.left,Arect.top,Arect.right,Arect.bottom,FXAngle,FYAngle);
                  canvas.Brush.Style:=bsclear;
                  canvas.Pen.Color:=rgb(255,199,142);
                  canvas.RoundRect(Arect.left+1,Arect.top+1,Arect.right-1,Arect.bottom-1,FXAngle,FYAngle);
                  canvas.Brush.Style:=bsclear;
                  canvas.Pen.Color:=rgb(255,229,152);
                  canvas.RoundRect(Arect.left+1,Arect.top+1,Arect.right-1,Arect.bottom-1,FXAngle,FYAngle);
              end
            else

                  begin
                    canvas.Brush.Style:=bsclear;
                    //canvas.Pen.width:=2;
                    canvas.Pen.Color:=rgb(0,0,0);
                    canvas.RoundRect(Arect.left,Arect.top,Arect.right,Arect.bottom,FXAngle,FYAngle);
                    canvas.Brush.Style:=bsclear;
                    canvas.Pen.Color:=rgb(255,255,255);

                    canvas.RoundRect(Arect.left+1,Arect.top+1,Arect.right-1,Arect.bottom-1,FXAngle,FYAngle);
                  end;
            END;
         
 end; { case}
 ///new add  define
  //Fbitmap.Canvas.Font.Color := Font.Color; //Keep Bitmap in synch with settings.
  //Fbitmap.Canvas.Font := Font;     // Set the Bitmap font to match control font
  //Fbitmap.Width := Width;          //Set BMP dimensions to match control's
  //Fbitmap.Height := Height;
  {rct := Rect(0,0,Width,Height);  //Set rectangle size for later use
  FromR := FBeginCrl and $000000ff;  //Strip out separate RGB values
  FromG := (FBeginCrl  shr 8) and $000000ff;
  FromB := (FBeginCrl  shr 16) and $000000ff;
  DiffR := (FBeginCrl  and $000000ff) - FromR;   //Find the difference
  DiffG := ((FBeginCrl  shr 8) and $000000ff) - FromG;
  DiffB := ((FBeginCrl  shr 16) and $000000ff) - FromB;
  //Depending on gradient style selected, go draw it on the Bitmap canvas.
  case FGradientStyle of
    //gsHorizontal  : DoHorizontal(FromR, FromG, FromB, DiffR, DiffG, DiffB);
    //gsVertical    : DoVertical(FromR, FromG, FromB, DiffR, DiffG, DiffB);
    //gsElliptic    : DoElliptic(FromR, FromG, FromB, DiffR, DiffG, DiffB);
    //gsRectangle   : DoRectangle(FromR, FromG, FromB, DiffR, DiffG, DiffB);
    //gsVertCenter  : DoVertCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
    gsHorizCenter : DoHorizCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  end;
  }
end;
//new add func
{
procedure TMTranBtn.DoHorizCenter(fr, fg, fb, dr, dg, db : Integer);
var
  ColorRect: TRect;
  I: Integer;
  R, G, B : Byte;
  Haf : Integer;
begin
  Haf := Width Div 2;
  ColorRect.Top := 0;
  ColorRect.Bottom := Height;
  for I := 0 to Haf do begin
    ColorRect.Left := Muldv (I, Haf, Haf);
    ColorRect.Right := Muldv (I + 1, Haf, Haf);
    R := fr + Muldv(I, dr, Haf);
    G := fg + Muldv(I, dg, Haf);
    B := fb + Muldv(I, db, Haf);
    Canvas.Brush.Color := RGB(R, G, B);
    Canvas.FillRect(ColorRect);
    ColorRect.Left :=Width - (Muldv (I, Haf, Haf));
    ColorRect.Right :=Width - (Muldv (I + 1, Haf, Haf));
    Canvas.FillRect(ColorRect);
  end;
end;
}
function TPicButton.OnGlyphP(X, Y: integer): boolean;
begin
  Result := PtInRect({ClientRect} BRect, Point(X, Y)) and
            (FBitmap.Canvas.Pixels[X, Y] <> FBitmap.TransparentColor);
end;

procedure TPicButton.MouseMove(Shift: TShiftState; X, Y: Integer);

begin
  FOver := (fborder = bsnormal) or (fborder = bsie) or  OnGlyphP(X, Y) or  (Fborder=BsGrad);
  Inherited MouseMove(Shift, X, Y);
end;

procedure TPicButton.mouseleave(var msg : tmessage);
var  rc : Trect;
BEGIN
  FOver := false;
  rc := getclientrect;
  if (Fborder = bsie) or (Fborder=BsGrad) then
    INVALIDATE;
END;

procedure TPicButton.mousein(var msg : tmessage);
var  rc : Trect;
BEGIN
  FOver := true;
  rc := getclientrect;
  if (Fborder = bsie) then
    frame3d(canvas, rc ,clBtnHighlight,clBtnShadow, 1);
  if Fborder=BsGrad then
  begin
      canvas.Brush.Style:=bsclear;
      //canvas.pen.Width:=2;
      canvas.Pen.Color:=rgb(255,94,32);

      canvas.RoundRect(rc.left,rc.top,rc.right,rc.bottom,FXAngle,FYAngle);
      canvas.Brush.Style:=bsclear;
      canvas.Pen.Color:=rgb(255,199,142);
      canvas.RoundRect(rc.left+1,rc.top+1,rc.right-1,rc.bottom-1,FXAngle,FYAngle);
      canvas.Brush.Style:=bsclear;
      //canvas.pen.Width:=2;
      canvas.Pen.Color:=rgb(255,229,152);
      canvas.RoundRect(rc.left+1,rc.top+1,rc.right-1,rc.bottom-1,FXAngle,FYAngle);
  end;
END;

procedure TPicButton.WMLButtonDown;
{var
   tmp:Tpoint;
   msg:Tmsg;
   }
begin
  inherited;
  //tmp:=ClientToScreen(point(0,height));
  //FPopupMenu.popup(tmp.X,tmp.y);
  Pushed := (fborder = bsnormal) or (fborder = bsie) OR FOver or  (Fborder = bsgrad);
  if pushed then
     invalidate;
end;

procedure TPicButton.WMLButtonUp;
begin
 inherited;
 if (fborder = bsnormal) or (fborder = bsie) or FOver  or  (Fborder=bsGrad) then
    Pushed := false;
 if Pushed = false then
   invalidate;
end;
{procedure TMTranbtn.Notification(AComponent: TComponent; Operation:TOperation);
begin
	if (Operation = opRemove) and (AComponent = FPopUpMenu) then
		FPopUpMenu := nil ;
end;
}
procedure Register;
begin
  RegisterComponents('Mik', [TPicButton]);
end;

end.