picbutton.~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;
    Ftransparent:boolean;//2002/12/27
    //FBeginCrl:Tcolor;
    //FEndCrl:Tcolor;
    //FGradientStyle:TGradientStyle;
    //FPopupMenu:TPopupMenu;
    FBitmapBG:Tcolor;///2002/12/29
    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);
    procedure SetTransparent(value:boolean);  //2002/12/27
    procedure SetBitmapColor(value:Tcolor);
  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  Transparent:boolean read Ftransparent  write SetTransparent;
    property  BitmapBg:Tcolor read FbitmapBG write SetBitmapColor;
    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;
}
///2002/12/27
procedure Tpicbutton.SetTransparent(value:boolean);
begin
   if Ftransparent<>value  then
   begin
      Ftransparent:=value;
      invalidate;
   end;
end;
//2002/12/29
procedure Tpicbutton.SetbitmapColor(value:Tcolor);
begin
   if FbitmapBg<>value  then
   begin
      FbitmapBg:=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;