MMButton.pas
上传用户:hylc_2004
上传日期:2014-01-23
资源大小:46800k
文件大小:35k
源码类别:

Delphi控件源码

开发平台:

Delphi

  1. {========================================================================}
  2. {=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
  3. {========================================================================}
  4. {=                          All Rights Reserved                         =}
  5. {========================================================================}
  6. {=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
  7. {=  Loewenstr.7a                = info@swiftsoft.de                     =}
  8. {========================================================================}
  9. {=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
  10. {========================================================================}
  11. {=  This code is for reference purposes only and may not be copied or   =}
  12. {=  distributed in any format electronic or otherwise except one copy   =}
  13. {=  for backup purposes.                                                =}
  14. {=                                                                      =}
  15. {=  No Delphi Component Kit or Component individually or in a collection=}
  16. {=  subclassed or otherwise from the code in this unit, or associated   =}
  17. {=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
  18. {=  without express permission from SwiftSoft.                          =}
  19. {=                                                                      =}
  20. {=  For more licence informations please refer to the associated        =}
  21. {=  HelpFile.                                                           =}
  22. {========================================================================}
  23. {=  $Date: 20.01.1998 - 18:00:00 $                                      =}
  24. {========================================================================}
  25. unit MMButton;
  26. {$C PRELOAD}
  27. {$I COMPILER.INC}
  28. interface
  29. uses
  30. {$IFDEF WIN32}
  31.     Windows,
  32. {$ELSE}
  33.     WinTypes,
  34.     WinProcs,
  35. {$ENDIF}
  36.     Messages,
  37.     Classes,
  38.     Controls,
  39.     Forms,
  40.     Graphics,
  41.     StdCtrls,
  42.     ExtCtrls,
  43.     Buttons,
  44.     MMObj,
  45.     MMUtils;
  46. type
  47.   TMMSpeedButton = class(TMMGraphicControl)
  48.   private
  49.     FGroupIndex: Integer;
  50.     FGlyph     : Pointer;
  51.     FDown      : Boolean;
  52.     FAllowAllUp: Boolean;
  53.     FLayout    : TButtonLayout;
  54.     FSpacing   : Integer;
  55.     FMargin    : Integer;
  56.     FBevel     : TBevelStyle;
  57.     FPattern   : TBitmap;
  58.     FDownColor : TColor;
  59.     FBevelColor: TColor;
  60.     procedure CreateBrushPattern;
  61.     procedure GlyphChanged(Sender: TObject);
  62.     procedure UpdateExclusive;
  63.     function  GetGlyph: TBitmap;
  64.     procedure SetGlyph(Value: TBitmap);
  65.     function  GetNumGlyphs: TNumGlyphs;
  66.     procedure SetNumGlyphs(Value: TNumGlyphs);
  67.     procedure SetDown(Value: Boolean);
  68.     procedure SetAllowAllUp(Value: Boolean);
  69.     procedure SetGroupIndex(Value: Integer);
  70.     procedure SetLayout(Value: TButtonLayout);
  71.     procedure SetSpacing(Value: Integer);
  72.     procedure SetMargin(Value: Integer);
  73.     procedure SetBevel(Value: TBevelStyle);
  74.     procedure SetDownColor(Value: TColor);
  75.     procedure SetBevelColor(Value: TColor);
  76.     procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
  77.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  78.     procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
  79.     {$IFDEF WIN32}
  80.     procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  81.     {$ENDIF}
  82.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  83.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  84.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  85.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  86.     function  DrawButtonFace(Canvas: TCanvas; const Client: TRect;
  87.                              BevelStyle: TBevelStyle; IsDown: Boolean): TRect;
  88.   protected
  89.     FState: TButtonState;
  90.     FDragging: Boolean;
  91.     function  GetPalette: HPALETTE; override;
  92.     procedure Paint; override;
  93.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  94.                         X, Y: Integer); override;
  95.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  96.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  97.                       X, Y: Integer); override;
  98.     procedure DrawGlyph(Canvas: TCanvas; const Client: TRect);
  99.   public
  100.     constructor Create(AOwner: TComponent); override;
  101.     destructor  Destroy; override;
  102.     procedure   Click; override;
  103.   published
  104.     property OnClick;
  105.     property OnDblClick;
  106.     property OnMouseDown;
  107.     property OnMouseMove;
  108.     property OnMouseUp;
  109.     property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
  110.     property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
  111.     { Ensure group index is declared before Down }
  112.     property Down: Boolean read FDown write SetDown default False;
  113.     property Caption;
  114.     property Enabled;
  115.     property Font;
  116.     property Glyph: TBitmap read GetGlyph write SetGlyph;
  117.     property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
  118.     property Margin: Integer read FMargin write SetMargin default -1;
  119.     property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
  120.     property ParentFont;
  121.     property ParentShowHint;
  122.     property ShowHint;
  123.     property Spacing: Integer read FSpacing write SetSpacing default 4;
  124.     property Visible;
  125.     property Bevel: TBevelStyle read FBevel write SetBevel default bsRaised;
  126.     property DownColor: TColor read FDownColor write SetDownColor default clWhite;
  127.     property BevelColor: TColor read FBevelColor write SetBevelColor default clBlack;
  128.   end;
  129. implementation
  130. uses Consts, SysUtils, MMString;
  131. {$IFNDEF WIN32}
  132. { TBitPool }
  133. const
  134.   BitsPerInt = SizeOf(Integer) * 8;
  135. type
  136.   TBitEnum = 0..BitsPerInt - 1;
  137.   TBitSet = set of TBitEnum;
  138.   TBitPool = class
  139.   private
  140.     FSize: Integer;
  141.     FBits: Pointer;
  142.     procedure SetSize(Value: Integer);
  143.     procedure SetBit(Index: Integer; Value: Boolean);
  144.     function GetBit(Index: Integer): Boolean;
  145.   public
  146.     destructor Destroy; override;
  147.     function OpenBit: Integer;
  148.     property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
  149.     property Size: Integer read FSize write SetSize;
  150.   end;
  151. {$ELSE}
  152. type
  153.   TBitPool = class(TBits);
  154. {$ENDIF}
  155. type
  156.   TGlyphList = class(TImageList)
  157.   private
  158.     Used: TBitPool;
  159.     FCount: Integer;
  160.     function AllocateIndex: Integer;
  161.   public
  162.     constructor Create(AWidth, AHeight: Integer);
  163.     destructor Destroy; override;
  164.     function Add(Image, Mask: TBitmap): Integer;
  165.     function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  166.     procedure Delete(Index: Integer);
  167.     property Count: Integer read FCount;
  168.   end;
  169.   TGlyphCache = class
  170.   private
  171.     GlyphLists: TList;
  172.   public
  173.     constructor Create;
  174.     destructor Destroy; override;
  175.     function GetList(AWidth, AHeight: Integer): TGlyphList;
  176.     procedure ReturnList(List: TGlyphList);
  177.     function Empty: Boolean;
  178.   end;
  179.   TButtonGlyph = class
  180.   private
  181.     FOriginal: TBitmap;
  182.     FGlyphList: TGlyphList;
  183.     FIndexs: array[TButtonState] of Integer;
  184.     FTransparentColor: TColor;
  185.     FNumGlyphs: TNumGlyphs;
  186.     FOnChange: TNotifyEvent;
  187.     procedure GlyphChanged(Sender: TObject);
  188.     procedure SetGlyph(Value: TBitmap);
  189.     procedure SetNumGlyphs(Value: TNumGlyphs);
  190.     procedure Invalidate;
  191.     function CreateButtonGlyph(State: TButtonState): Integer;
  192.     procedure DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
  193.       State: TButtonState);
  194.     procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
  195.       TextBounds: TRect; State: TButtonState);
  196.     procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  197.       const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  198.       var GlyphPos: TPoint; var TextBounds: TRect);
  199.   public
  200.     constructor Create;
  201.     destructor Destroy; override;
  202.     { return the text rectangle }
  203.     function Draw(Canvas: TCanvas; const Client: TRect;
  204.                   const Caption: string; Layout: TButtonLayout;
  205.                   Margin, Spacing: Integer; State: TButtonState): TRect;
  206.     property Glyph: TBitmap read FOriginal write SetGlyph;
  207.     property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
  208.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  209.   end;
  210. {$IFNDEF WIN32}
  211. type
  212.   PBitArray = ^TBitArray;
  213.   TBitArray = array[0..4096] of TBitSet;
  214. destructor TBitPool.Destroy;
  215. begin
  216.   SetSize(0);
  217.   inherited Destroy;
  218. end;
  219. procedure TBitPool.SetSize(Value: Integer);
  220. var
  221.   NewMem: Pointer;
  222.   NewMemSize: Integer;
  223.   OldMemSize: Integer;
  224.   function Min(X, Y: Integer): Integer;
  225.   begin
  226.     Result := X;
  227.     if X > Y then Result := Y;
  228.   end;
  229. begin
  230.   if Value <> Size then
  231.   begin
  232.     NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  233.     OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  234.     if NewMemSize <> OldMemSize then
  235.     begin
  236.       NewMem := nil;
  237.       if NewMemSize <> 0 then
  238.       begin
  239.         GetMem(NewMem, NewMemSize);
  240.         FillChar(NewMem^, NewMemSize, 0);
  241.       end
  242.       else NewMem := nil;
  243.       if OldMemSize <> 0 then
  244.       begin
  245.         if NewMem <> nil then
  246.           Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize));
  247.         FreeMem(FBits, OldMemSize);
  248.       end;
  249.       FBits := NewMem;
  250.     end;
  251.     FSize := Value;
  252.   end;
  253. end;
  254. procedure TBitPool.SetBit(Index: Integer; Value: Boolean);
  255. begin
  256.   if Value then
  257.     Include(PBitArray(FBits)^[Index div BitsPerInt], Index mod BitsPerInt)
  258.   else
  259.     Exclude(PBitArray(FBits)^[Index div BitsPerInt], Index mod BitsPerInt);
  260. end;
  261. function TBitPool.GetBit(Index: Integer): Boolean;
  262. begin
  263.   Result := Index mod BitsPerInt in PBitArray(FBits)^[Index div BitsPerInt];
  264. end;
  265. function TBitPool.OpenBit: Integer;
  266. var
  267.   I: Integer;
  268.   B: TBitSet;
  269.   J: TBitEnum;
  270.   E: Integer;
  271. begin
  272.   E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  273.   for I := 0 to E do
  274.     if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then
  275.     begin
  276.       B := PBitArray(FBits)^[I];
  277.       for J := Low(J) to High(J) do
  278.       begin
  279.         if not (J in B) then
  280.         begin
  281.           Result := I * BitsPerInt + J;
  282.           if Result >= Size then Result := Size;
  283.           Exit;
  284.         end;
  285.       end;
  286.     end;
  287.   Result := Size;
  288. end;
  289. {$ENDIF}
  290. { TGlyphList }
  291. constructor TGlyphList.Create(AWidth, AHeight: Integer);
  292. begin
  293. {$IFDEF WIN32}
  294.   inherited CreateSize(AWidth, AHeight);
  295. {$ELSE}
  296.   inherited Create(AWidth, AHeight);
  297. {$ENDIF}
  298.   Used := TBitPool.Create;
  299. end;
  300. destructor TGlyphList.Destroy;
  301. begin
  302.   Used.Free;
  303.   inherited Destroy;
  304. end;
  305. function TGlyphList.AllocateIndex: Integer;
  306. begin
  307.   Result := Used.OpenBit;
  308.   if Result >= Used.Size then
  309.   begin
  310.     Result := inherited Add(nil, nil);
  311.     Used.Size := Result + 1;
  312.   end;
  313.   Used[Result] := True;
  314. end;
  315. function TGlyphList.Add(Image, Mask: TBitmap): Integer;
  316. begin
  317.   Result := AllocateIndex;
  318.   Replace(Result, Image, Mask);
  319.   Inc(FCount);
  320. end;
  321. function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
  322. begin
  323.   Result := AllocateIndex;
  324.   ReplaceMasked(Result, Image, MaskColor);
  325.   Inc(FCount);
  326. end;
  327. procedure TGlyphList.Delete(Index: Integer);
  328. begin
  329.   if Used[Index] then
  330.   begin
  331.     Dec(FCount);
  332.     Used[Index] := False;
  333.   end;
  334. end;
  335. { TGlyphCache }
  336. constructor TGlyphCache.Create;
  337. begin
  338.   inherited Create;
  339.   GlyphLists := TList.Create;
  340. end;
  341. destructor TGlyphCache.Destroy;
  342. begin
  343.   GlyphLists.Free;
  344.   inherited Destroy;
  345. end;
  346. function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
  347. var
  348.   I: Integer;
  349. begin
  350.   for I := GlyphLists.Count - 1 downto 0 do
  351.   begin
  352.     Result := GlyphLists[I];
  353.     with Result do
  354.       if (AWidth = Width) and (AHeight = Height) then Exit;
  355.   end;
  356.   Result := TGlyphList.Create(AWidth, AHeight);
  357.   GlyphLists.Add(Result);
  358. end;
  359. procedure TGlyphCache.ReturnList(List: TGlyphList);
  360. begin
  361.   if List = nil then Exit;
  362.   if List.Count = 0 then
  363.   begin
  364.     GlyphLists.Remove(List);
  365.     List.Free;
  366.   end;
  367. end;
  368. function TGlyphCache.Empty: Boolean;
  369. begin
  370.   Result := GlyphLists.Count = 0;
  371. end;
  372. var
  373.   GlyphCache: TGlyphCache;
  374. { TButtonGlyph }
  375. constructor TButtonGlyph.Create;
  376. var
  377.   I: TButtonState;
  378. begin
  379.   inherited Create;
  380.   FOriginal := TBitmap.Create;
  381.   FOriginal.OnChange := GlyphChanged;
  382.   FTransparentColor := clOlive;
  383.   FNumGlyphs := 1;
  384.   for I := Low(I) to High(I) do
  385.     FIndexs[I] := -1;
  386.   if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
  387. end;
  388. destructor TButtonGlyph.Destroy;
  389. begin
  390.   FOriginal.Free;
  391.   Invalidate;
  392.   if Assigned(GlyphCache) and GlyphCache.Empty then
  393.   begin
  394.     GlyphCache.Free;
  395.     GlyphCache := nil;
  396.   end;
  397.   inherited Destroy;
  398. end;
  399. procedure TButtonGlyph.Invalidate;
  400. var
  401.   I: TButtonState;
  402. begin
  403.   for I := Low(I) to High(I) do
  404.   begin
  405.     if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
  406.     FIndexs[I] := -1;
  407.   end;
  408.   GlyphCache.ReturnList(FGlyphList);
  409.   FGlyphList := nil;
  410. end;
  411. procedure TButtonGlyph.GlyphChanged(Sender: TObject);
  412. begin
  413.   if Sender = FOriginal then
  414.   begin
  415.     FTransparentColor := FOriginal.TransparentColor;
  416.     Invalidate;
  417.     if Assigned(FOnChange) then FOnChange(Self);
  418.   end;
  419. end;
  420. procedure TButtonGlyph.SetGlyph(Value: TBitmap);
  421. var
  422.   Glyphs: Integer;
  423. begin
  424.   Invalidate;
  425.   FOriginal.Assign(Value);
  426.   if (Value <> nil) and (Value.Height > 0) then
  427.   begin
  428.     FTransparentColor := Value.TransparentColor;
  429.     if Value.Width mod Value.Height = 0 then
  430.     begin
  431.       Glyphs := Value.Width div Value.Height;
  432.       if Glyphs > 4 then Glyphs := 1;
  433.       SetNumGlyphs(Glyphs);
  434.     end;
  435.   end;
  436. end;
  437. procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
  438. begin
  439.   if (Value <> FNumGlyphs) and (Value > 0) then
  440.   begin
  441.     Invalidate;
  442.     FNumGlyphs := Value;
  443.   end;
  444. end;
  445. function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
  446. const
  447.   ROP_DSPDxax = $00E20746;
  448. var
  449.   TmpImage, MonoBmp: TBitmap;
  450.   IWidth, IHeight: Integer;
  451.   IRect, ORect: TRect;
  452.   I: TButtonState;
  453. begin
  454.   if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
  455.   Result := FIndexs[State];
  456.   if Result <> -1 then Exit;
  457.   IWidth := FOriginal.Width div FNumGlyphs;
  458.   IHeight := FOriginal.Height;
  459.   if FGlyphList = nil then
  460.   begin
  461.     if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
  462.     FGlyphList := GlyphCache.GetList(IWidth, IHeight);
  463.   end;
  464.   TmpImage := TBitmap.Create;
  465.   try
  466.     TmpImage.Width := IWidth;
  467.     TmpImage.Height := IHeight;
  468.     IRect := Rect(0, 0, IWidth, IHeight);
  469.     TmpImage.Canvas.Brush.Color := clBtnFace;
  470.     I := State;
  471.     if Ord(I) >= NumGlyphs then I := bsUp;
  472.     ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
  473.     case State of
  474.       bsUp, bsDown:
  475.         begin
  476.           TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
  477.           FIndexs[State] := FGlyphList.Add(TmpImage, nil);
  478.         end;
  479.       bsExclusive:
  480.         begin
  481.           TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
  482.           FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor);
  483.         end;
  484.       bsDisabled:
  485.         if NumGlyphs > 1 then
  486.         begin
  487.           TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
  488.           FIndexs[State] := FGlyphList.Add(TmpImage, nil);
  489.         end
  490.         else
  491.         begin
  492.           { Create a disabled version }
  493.           MonoBmp := TBitmap.Create;
  494.           try
  495.             with MonoBmp do
  496.             begin
  497.               Assign(FOriginal);
  498.               {$IFDEF DELPHI3}
  499.               MonoBmp.HandleType := bmDDB;
  500.               {$ENDIF}
  501.               Canvas.Brush.Color := clBlack;
  502.               Width := IWidth;
  503.               if Monochrome then
  504.               begin
  505.                 Canvas.Font.Color := clWhite;
  506.                 Monochrome := False;
  507.                 Canvas.Brush.Color := clWhite;
  508.               end;
  509.               Monochrome := True;
  510.             end;
  511.             with TmpImage.Canvas do
  512.             begin
  513.               Brush.Color := clBtnFace;
  514.               FillRect(IRect);
  515.               Brush.Color := clBlack;
  516.               Font.Color := clWhite;
  517.               CopyMode := MergePaint;
  518.               Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
  519.               CopyMode := SrcAnd;
  520.               Draw(IRect.Left, IRect.Top, MonoBmp);
  521.               Brush.Color := clBtnShadow;
  522.               Font.Color := clBlack;
  523.               CopyMode := SrcPaint;
  524.               Draw(IRect.Left, IRect.Top, MonoBmp);
  525.               CopyMode := SrcCopy;
  526.             end;
  527.             FIndexs[State] := FGlyphList.Add(TmpImage, nil);
  528.           finally
  529.             MonoBmp.Free;
  530.           end;
  531.        end;
  532.     end;
  533.   finally
  534.     TmpImage.Free;
  535.   end;
  536.   Result := FIndexs[State];
  537.   FOriginal.Dormant;
  538. end;
  539. procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
  540.   State: TButtonState);
  541. var
  542.   Index: Integer;
  543. begin
  544.   if FOriginal = nil then Exit;
  545.   if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
  546.   Index := CreateButtonGlyph(State);
  547.   FGlyphList.Draw(Canvas, X, Y, Index);
  548. end;
  549. procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
  550.   TextBounds: TRect; State: TButtonState);
  551. var
  552.   CString: PChar;
  553. begin
  554.    if Length(Caption) > 0 then
  555.    begin
  556.       CString := StrAlloc(Length(Caption)+1);
  557.       try
  558.          StrPCopy(CString, Caption);
  559.          Canvas.Brush.Style := bsClear;
  560.          if State = bsDisabled then
  561.          begin
  562.             with Canvas do
  563.             begin
  564.                OffsetRect(TextBounds, 1, 1);
  565.                Font.Color := clWhite;
  566.                DrawText(Handle, CString, Length(Caption), TextBounds, 0);
  567.                OffsetRect(TextBounds, -1, -1);
  568.                Font.Color := clDkGray;
  569.                DrawText(Handle, CString, Length(Caption), TextBounds, 0);
  570.             end;
  571.          end
  572.          else DrawText(Canvas.Handle, CString, -1, TextBounds,
  573.               DT_CENTER or DT_VCENTER or DT_SINGLELINE);
  574.       finally
  575.          StrDispose(CString);
  576.       end;
  577.    end;
  578. end;
  579. procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
  580.   const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  581.   var GlyphPos: TPoint; var TextBounds: TRect);
  582. var
  583.   TextPos: TPoint;
  584.   ClientSize, GlyphSize, TextSize: TPoint;
  585.   TotalSize: TPoint;
  586.   CString: PChar;
  587. begin
  588.    CString := StrAlloc(Length(Caption)+2);
  589.    StrPCopy(CString, Caption);
  590.    try
  591.       { calculate the item sizes }
  592.       ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);
  593.       if FOriginal <> nil then
  594.          GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)
  595.       else
  596.          GlyphSize := Point(0, 0);
  597.       if Length(Caption) > 0 then
  598.       begin
  599.          TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
  600.          DrawText(Canvas.Handle, CString, -1, TextBounds, DT_CALCRECT);
  601.       end
  602.       else TextBounds := Rect(0, 0, 0, 0);
  603.       TextSize := Point(TextBounds.Right - TextBounds.Left,
  604.                         TextBounds.Bottom -TextBounds.Top);
  605.       { If the layout has the glyph on the right or the left, then both the
  606.         text and the glyph are centered vertically.  If the glyph is on the top
  607.         or the bottom, then both the text and the glyph are centered horizontally.}
  608.       if Layout in [blGlyphLeft, blGlyphRight] then
  609.       begin
  610.          GlyphPos.Y := (ClientSize.Y div 2) - (GlyphSize.Y div 2);
  611.          TextPos.Y := (ClientSize.Y div 2) - (TextSize.Y div 2);
  612.       end
  613.       else
  614.       begin
  615.          GlyphPos.X := (ClientSize.X div 2) - (GlyphSize.X div 2);
  616.          TextPos.X := (ClientSize.X div 2) - (TextSize.X div 2);
  617.       end;
  618.       { if there is no text or no bitmap, then Spacing is irrelevant }
  619.       if (TextSize.X = 0) or (GlyphSize.X = 0) then Spacing := 0;
  620.       { adjust Margin and Spacing }
  621.       if Margin = -1 then
  622.       begin
  623.          if Spacing = -1 then
  624.          begin
  625.             TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
  626.             if Layout in [blGlyphLeft, blGlyphRight] then
  627.                Margin := (ClientSize.X - TotalSize.X) div 3
  628.             else
  629.                Margin := (ClientSize.Y - TotalSize.Y) div 3;
  630.             Spacing := Margin;
  631.          end
  632.          else
  633.          begin
  634.             TotalSize := Point(GlyphSize.X + Spacing + TextSize.X,
  635.                                GlyphSize.Y + Spacing + TextSize.Y);
  636.             if Layout in [blGlyphLeft, blGlyphRight] then
  637.                Margin := (ClientSize.X div 2) - (TotalSize.X div 2)
  638.             else
  639.                Margin := (ClientSize.Y div 2) - (TotalSize.Y div 2);
  640.          end;
  641.       end
  642.       else
  643.       begin
  644.          if Spacing = -1 then
  645.          begin
  646.             TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X),
  647.                                ClientSize.Y - (Margin + GlyphSize.Y));
  648.             if Layout in [blGlyphLeft, blGlyphRight] then
  649.                Spacing := (TotalSize.X div 2) - (TextSize.X div 2)
  650.             else
  651.                Spacing := (TotalSize.Y div 2) - (TextSize.Y div 2);
  652.          end;
  653.       end;
  654.       case Layout of
  655.          blGlyphLeft:
  656.          begin
  657.             GlyphPos.X := Margin;
  658.             TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
  659.          end;
  660.          blGlyphRight:
  661.          begin
  662.             GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
  663.             TextPos.X := GlyphPos.X - Spacing - TextSize.X;
  664.          end;
  665.          blGlyphTop:
  666.          begin
  667.             GlyphPos.Y := Margin;
  668.             TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
  669.          end;
  670.          blGlyphBottom:
  671.          begin
  672.             GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
  673.             TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
  674.          end;
  675.       end;
  676.       { fixup the result variables }
  677.       Inc(GlyphPos.X, Client.Left);
  678.       Inc(GlyphPos.Y, Client.Top);
  679.       OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top);
  680.    finally
  681.       StrDispose(CString);
  682.    end;
  683. end;
  684. function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
  685.   const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
  686.   State: TButtonState): TRect;
  687. var
  688.   GlyphPos: TPoint;
  689.   TextBounds: TRect;
  690. begin
  691.   CalcButtonLayout(Canvas, Client, Caption, Layout, Margin, Spacing,
  692.     GlyphPos, TextBounds);
  693.   DrawButtonGlyph(Canvas, GlyphPos.X, GlyphPos.Y, State);
  694.   DrawButtonText(Canvas, Caption, TextBounds, State);
  695.   Result := TextBounds;
  696. end;
  697. {== TMMSpeedButton ======================================================}
  698. constructor TMMSpeedButton.Create(AOwner: TComponent);
  699. begin
  700.   inherited Create(AOwner);
  701.   FPattern := nil;
  702.   
  703.   SetBounds(0, 0, 25, 25);
  704.   ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
  705.   FGlyph := TButtonGlyph.Create;
  706.   TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  707.   ParentFont := True;
  708.   FSpacing := 4;
  709.   FMargin := -1;
  710.   FLayout := blGlyphLeft;
  711.   FBevel := bsRaised;
  712.   FDownColor := clWhite;
  713.   FBevelColor := clBlack;
  714.   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  715.   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
  716. end;
  717. {-- TMMSpeedButton ------------------------------------------------------}
  718. destructor TMMSpeedButton.Destroy;
  719. begin
  720.   TButtonGlyph(FGlyph).Free;
  721.   if FPattern <> nil then FPattern.Free;
  722.   inherited Destroy;
  723. end;
  724. {-- TMMSpeedButton ------------------------------------------------------}
  725. procedure TMMSpeedButton.CreateBrushPattern;
  726. var
  727.   X, Y: Integer;
  728. begin
  729.   if FPattern <> nil then FPattern.Free;
  730.   FPattern := TBitmap.Create;
  731.   FPattern.Width := 8;
  732.   FPattern.Height := 8;
  733.   with FPattern.Canvas do
  734.   begin
  735.     Brush.Style := bsSolid;
  736.     Brush.Color := clBtnFace;
  737.     FillRect(Rect(0, 0, FPattern.Width, FPattern.Height));
  738.     for Y := 0 to 7 do
  739.       for X := 0 to 7 do
  740.         if (Y mod 2) = (X mod 2) then  { toggles between even/odd pixles }
  741.           Pixels[X, Y] := FDownColor;  { on even/odd rows }
  742.   end;
  743. end;
  744. {-- TMMSpeedButton ------------------------------------------------------}
  745. procedure TMMSpeedButton.DrawGlyph(Canvas: TCanvas; const Client: TRect);
  746. begin
  747.      TButtonGlyph(FGlyph).Draw(Canvas,Client,Caption,FLayout,FMargin,
  748.                                FSpacing,FState);
  749. end;
  750. { DrawButtonFace - returns the remaining usable area inside the Client rect.}
  751. {-- TMMSpeedButton ------------------------------------------------------}
  752. function TMMSpeedButton.DrawButtonFace(Canvas: TCanvas; const Client: TRect;
  753.          BevelStyle: TBevelStyle; IsDown: Boolean): TRect;
  754. var
  755.   R: TRect;
  756. begin
  757.   R := Client;
  758.   with Canvas do
  759.   begin
  760.      Brush.Color := clBtnFace;
  761.      Brush.Style := bsSolid;
  762.      FillRect(R);
  763.      if IsDown then
  764.      begin
  765.         Frame3D(Canvas, R, BevelColor, clBtnHighlight, 1);
  766.         Frame3D(Canvas, R, clBtnShadow, clBtnFace, 1);
  767.      end
  768.      else
  769.      begin
  770.         if BevelStyle = bsRaised then
  771.         begin
  772.            Frame3D(Canvas, R, clBtnHighLight, BevelColor, 1);
  773.            Frame3D(Canvas, R, clBtnFace, clBtnShadow, 1);
  774.         end
  775.         else
  776.         begin
  777.            Pen.Color := BevelColor;
  778.            Rectangle(R.Left, R.Top, R.Right-1, R.Bottom-1);
  779.            Pen.Color := clBtnHighLight;
  780.            PolyLine([Point(R.Left+1, R.Bottom), Point(R.Left+1, R.Top+1),
  781.                      Point(R.Right-2, R.Top+1)]);
  782.            PolyLine([Point(R.Right-1, R.Top), Point(R.Right-1, R.Bottom-1),
  783.                      Point(R.Left+1, R.Bottom-1)]);
  784.         end;
  785.      end;
  786.   end;
  787.   Result := Rect(Client.Left, Client.Top,
  788.                  Client.Right - 1, Client.Bottom - 1);
  789.   if IsDown then OffsetRect(Result, 1, 1);
  790. end;
  791. {-- TMMSpeedButton ------------------------------------------------------}
  792. procedure TMMSpeedButton.Paint;
  793. var
  794.   PaintRect: TRect;
  795. begin
  796.   if not Enabled and not (csDesigning in ComponentState) then
  797.   begin
  798.     FState := bsDisabled;
  799.     FDragging := False;
  800.   end
  801.   else if FState = bsDisabled then FState := bsUp;
  802.   Canvas.Font := Self.Font;
  803.   PaintRect := DrawButtonFace(Canvas, Rect(0, 0, Width, Height), FBevel,
  804.                FState in [bsDown, bsExclusive]);
  805.   if FState = bsExclusive then
  806.   begin
  807.     CreateBrushPattern;
  808.     Canvas.Brush.Bitmap := FPattern;
  809.     dec(PaintRect.Right);
  810.     dec(PaintRect.Bottom);
  811.     Canvas.FillRect(PaintRect);
  812.     Canvas.Brush.Bitmap := nil;
  813.     FPattern.Free;
  814.     FPattern := nil;
  815.   end;
  816.   DrawGlyph(Canvas,PaintRect);
  817. end;
  818. {-- TMMSpeedButton ------------------------------------------------------}
  819. procedure TMMSpeedButton.SetBevel(Value: TBevelStyle);
  820. begin
  821.    if (Value <> FBevel) then
  822.    begin
  823.       FBevel := Value;
  824.       Invalidate;
  825.    end;
  826. end;
  827. {-- TMMSpeedButton ------------------------------------------------------}
  828. procedure TMMSpeedButton.SetDownColor(Value: TColor);
  829. begin
  830.    if (Value <> FDownColor) then
  831.    begin
  832.       FDownColor := Value;
  833.       FPattern.Free;
  834.       FPattern := nil;
  835.       Invalidate;
  836.    end;
  837. end;
  838. {-- TMMSpeedButton ------------------------------------------------------}
  839. procedure TMMSpeedButton.SetBevelColor(Value: TColor);
  840. begin
  841.    if (Value <> FBevelColor) then
  842.    begin
  843.       FBevelColor := Value;
  844.       Invalidate;
  845.    end;
  846. end;
  847. {-- TMMSpeedButton ------------------------------------------------------}
  848. procedure TMMSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  849.                                    X, Y: Integer);
  850. begin
  851.   inherited MouseDown(Button, Shift, X, Y);
  852.   if (Button = mbLeft) and Enabled then
  853.   begin
  854.     if not FDown then
  855.     begin
  856.       FState := bsDown;
  857.       Repaint;
  858.     end;
  859.     FDragging := True;
  860.   end;
  861. end;
  862. {-- TMMSpeedButton ------------------------------------------------------}
  863. procedure TMMSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  864. var
  865.   NewState: TButtonState;
  866. begin
  867.   inherited MouseMove(Shift, X, Y);
  868.   if FDragging then
  869.   begin
  870.     if not FDown then NewState := bsUp
  871.     else NewState := bsExclusive;
  872.     if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
  873.       if FDown then NewState := bsExclusive else NewState := bsDown;
  874.     if NewState <> FState then
  875.     begin
  876.       FState := NewState;
  877.       Repaint;
  878.     end;
  879.   end;
  880. end;
  881. {-- TMMSpeedButton ------------------------------------------------------}
  882. procedure TMMSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  883.   X, Y: Integer);
  884. var
  885.   DoClick: Boolean;
  886. begin
  887.   inherited MouseUp(Button, Shift, X, Y);
  888.   if FDragging then
  889.   begin
  890.     FDragging := False;
  891.     DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  892.     FState := bsUp;
  893.     if FGroupIndex = 0 then
  894.       Repaint
  895.     else
  896.       if DoClick then SetDown(not FDown)
  897.       else
  898.       begin
  899.         if FDown then FState := bsExclusive;
  900.         Repaint;
  901.       end;
  902.     if DoClick then Click;
  903.   end;
  904. end;
  905. {-- TMMSpeedButton ------------------------------------------------------}
  906. procedure TMMSpeedButton.Click;
  907. begin
  908.   inherited Click;
  909. end;
  910. {-- TMMSpeedButton ------------------------------------------------------}
  911. function TMMSpeedButton.GetPalette: HPALETTE;
  912. begin
  913.   Result := Glyph.Palette;
  914. end;
  915. {-- TMMSpeedButton ------------------------------------------------------}
  916. function TMMSpeedButton.GetGlyph: TBitmap;
  917. begin
  918.   Result := TButtonGlyph(FGlyph).Glyph;
  919. end;
  920. {-- TMMSpeedButton ------------------------------------------------------}
  921. procedure TMMSpeedButton.SetGlyph(Value: TBitmap);
  922. begin
  923.   TButtonGlyph(FGlyph).Glyph := Value;
  924.   Invalidate;
  925.   {$IFDEF WIN32}
  926.   {$IFDEF TRIAL}
  927.   {$DEFINE _HACK2}
  928.   {$I MMHACK.INC}
  929.   {$ENDIF}
  930.   {$ENDIF}
  931. end;
  932. {-- TMMSpeedButton ------------------------------------------------------}
  933. function TMMSpeedButton.GetNumGlyphs: TNumGlyphs;
  934. begin
  935.   Result := TButtonGlyph(FGlyph).NumGlyphs;
  936. end;
  937. {-- TMMSpeedButton ------------------------------------------------------}
  938. procedure TMMSpeedButton.SetNumGlyphs(Value: TNumGlyphs);
  939. begin
  940.    {$IFDEF WIN32}
  941.    {$IFDEF TRIAL}
  942.    {$DEFINE _HACK3}
  943.    {$I MMHACK.INC}
  944.    {$ENDIF}
  945.    {$ENDIF}
  946.   if Value < 0 then Value := 1
  947.   else if Value > 4 then Value := 4;
  948.   if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  949.   begin
  950.     TButtonGlyph(FGlyph).NumGlyphs := Value;
  951.     Invalidate;
  952.   end;
  953. end;
  954. {-- TMMSpeedButton ------------------------------------------------------}
  955. procedure TMMSpeedButton.GlyphChanged(Sender: TObject);
  956. begin
  957.   Invalidate;
  958. end;
  959. {-- TMMSpeedButton ------------------------------------------------------}
  960. procedure TMMSpeedButton.UpdateExclusive;
  961. var
  962.   Msg: TMessage;
  963. begin
  964.   if (FGroupIndex <> 0) and (Parent <> nil) then
  965.   begin
  966.     Msg.Msg := CM_BUTTONPRESSED;
  967.     Msg.WParam := FGroupIndex;
  968.     Msg.LParam := Longint(Self);
  969.     Msg.Result := 0;
  970.     Parent.Broadcast(Msg);
  971.   end;
  972. end;
  973. {-- TMMSpeedButton ------------------------------------------------------}
  974. procedure TMMSpeedButton.SetDown(Value: Boolean);
  975. begin
  976.   if FGroupIndex = 0 then Value := False;
  977.   if Value <> FDown then
  978.   begin
  979.     if FDown and (not FAllowAllUp) then Exit;
  980.     FDown := Value;
  981.     if Value then FState := bsExclusive
  982.     else FState := bsUp;
  983.     Invalidate;
  984.     if Value then UpdateExclusive;
  985.   end;
  986. end;
  987. {-- TMMSpeedButton ------------------------------------------------------}
  988. procedure TMMSpeedButton.SetGroupIndex(Value: Integer);
  989. begin
  990.   if FGroupIndex <> Value then
  991.   begin
  992.     FGroupIndex := Value;
  993.     UpdateExclusive;
  994.   end;
  995. end;
  996. {-- TMMSpeedButton ------------------------------------------------------}
  997. procedure TMMSpeedButton.SetLayout(Value: TButtonLayout);
  998. begin
  999.   if FLayout <> Value then
  1000.   begin
  1001.     FLayout := Value;
  1002.     Invalidate;
  1003.   end;
  1004. end;
  1005. {-- TMMSpeedButton ------------------------------------------------------}
  1006. procedure TMMSpeedButton.SetMargin(Value: Integer);
  1007. begin
  1008.   if (Value <> FMargin) and (Value >= -1) then
  1009.   begin
  1010.     FMargin := Value;
  1011.     Invalidate;
  1012.   end;
  1013. end;
  1014. {-- TMMSpeedButton ------------------------------------------------------}
  1015. procedure TMMSpeedButton.SetSpacing(Value: Integer);
  1016. begin
  1017.   if Value <> FSpacing then
  1018.   begin
  1019.     FSpacing := Value;
  1020.     Invalidate;
  1021.   end;
  1022. end;
  1023. {-- TMMSpeedButton ------------------------------------------------------}
  1024. procedure TMMSpeedButton.SetAllowAllUp(Value: Boolean);
  1025. begin
  1026.   if FAllowAllUp <> Value then
  1027.   begin
  1028.     FAllowAllUp := Value;
  1029.     UpdateExclusive;
  1030.   end;
  1031.   {$IFDEF WIN32}
  1032.   {$IFDEF TRIAL}
  1033.   {$DEFINE _HACK1}
  1034.   {$I MMHACK.INC}
  1035.   {$ENDIF}
  1036.   {$ENDIF}
  1037. end;
  1038. {-- TMMSpeedButton ------------------------------------------------------}
  1039. procedure TMMSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
  1040. begin
  1041.   inherited;
  1042.   if FDown then DblClick;
  1043. end;
  1044. {-- TMMSpeedButton ------------------------------------------------------}
  1045. procedure TMMSpeedButton.CMEnabledChanged(var Message: TMessage);
  1046. begin
  1047.   Invalidate;
  1048. end;
  1049. {$IFDEF WIN32}
  1050. {-- TMMSpeedButton ------------------------------------------------------}
  1051. procedure TMMSpeedButton.CMHintShow(var Message: TMessage);
  1052. begin
  1053.   Message.Result := Ord(not Enabled);
  1054. end;
  1055. {$ENDIF}
  1056. {-- TMMSpeedButton ------------------------------------------------------}
  1057. procedure TMMSpeedButton.CMButtonPressed(var Message: TMessage);
  1058. var
  1059.   Sender: TMMSpeedButton;
  1060. begin
  1061.   if Message.WParam = FGroupIndex then
  1062.   begin
  1063.     Sender := TMMSpeedButton(Message.LParam);
  1064.     if Sender <> Self then
  1065.     begin
  1066.       if Sender.Down and FDown then
  1067.       begin
  1068.         FDown := False;
  1069.         FState := bsUp;
  1070.         Invalidate;
  1071.       end;
  1072.       FAllowAllUp := Sender.AllowAllUp;
  1073.     end;
  1074.   end;
  1075. end;
  1076. {-- TMMSpeedButton ------------------------------------------------------}
  1077. procedure TMMSpeedButton.CMDialogChar(var Message: TCMDialogChar);
  1078. begin
  1079.   with Message do
  1080.     if IsAccel(CharCode, Caption) and Enabled then
  1081.     begin
  1082.       Click;
  1083.       Result := 1;
  1084.     end
  1085.     else inherited;
  1086. end;
  1087. {-- TMMSpeedButton ------------------------------------------------------}
  1088. procedure TMMSpeedButton.CMFontChanged(var Message: TMessage);
  1089. begin
  1090.   Invalidate;
  1091. end;
  1092. {-- TMMSpeedButton ------------------------------------------------------}
  1093. procedure TMMSpeedButton.CMTextChanged(var Message: TMessage);
  1094. begin
  1095.   Invalidate;
  1096. end;
  1097. {-- TMMSpeedButton ------------------------------------------------------}
  1098. procedure TMMSpeedButton.CMSysColorChange(var Message: TMessage);
  1099. begin
  1100.   TButtonGlyph(FGlyph).Invalidate;
  1101. end;
  1102. end.