MMButton.pas
上传用户:hylc_2004
上传日期:2014-01-23
资源大小:46800k
文件大小:35k
- {========================================================================}
- {= (c) 1995-98 SwiftSoft Ronald Dittrich =}
- {========================================================================}
- {= All Rights Reserved =}
- {========================================================================}
- {= D 01099 Dresden = Tel.: +0351-8012255 =}
- {= Loewenstr.7a = info@swiftsoft.de =}
- {========================================================================}
- {= Actual versions on http://www.swiftsoft.de/mmtools.html =}
- {========================================================================}
- {= This code is for reference purposes only and may not be copied or =}
- {= distributed in any format electronic or otherwise except one copy =}
- {= for backup purposes. =}
- {= =}
- {= No Delphi Component Kit or Component individually or in a collection=}
- {= subclassed or otherwise from the code in this unit, or associated =}
- {= .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed =}
- {= without express permission from SwiftSoft. =}
- {= =}
- {= For more licence informations please refer to the associated =}
- {= HelpFile. =}
- {========================================================================}
- {= $Date: 20.01.1998 - 18:00:00 $ =}
- {========================================================================}
- unit MMButton;
- {$C PRELOAD}
- {$I COMPILER.INC}
- interface
- uses
- {$IFDEF WIN32}
- Windows,
- {$ELSE}
- WinTypes,
- WinProcs,
- {$ENDIF}
- Messages,
- Classes,
- Controls,
- Forms,
- Graphics,
- StdCtrls,
- ExtCtrls,
- Buttons,
- MMObj,
- MMUtils;
- type
- TMMSpeedButton = class(TMMGraphicControl)
- private
- FGroupIndex: Integer;
- FGlyph : Pointer;
- FDown : Boolean;
- FAllowAllUp: Boolean;
- FLayout : TButtonLayout;
- FSpacing : Integer;
- FMargin : Integer;
- FBevel : TBevelStyle;
- FPattern : TBitmap;
- FDownColor : TColor;
- FBevelColor: TColor;
- procedure CreateBrushPattern;
- procedure GlyphChanged(Sender: TObject);
- procedure UpdateExclusive;
- function GetGlyph: TBitmap;
- procedure SetGlyph(Value: TBitmap);
- function GetNumGlyphs: TNumGlyphs;
- procedure SetNumGlyphs(Value: TNumGlyphs);
- procedure SetDown(Value: Boolean);
- procedure SetAllowAllUp(Value: Boolean);
- procedure SetGroupIndex(Value: Integer);
- procedure SetLayout(Value: TButtonLayout);
- procedure SetSpacing(Value: Integer);
- procedure SetMargin(Value: Integer);
- procedure SetBevel(Value: TBevelStyle);
- procedure SetDownColor(Value: TColor);
- procedure SetBevelColor(Value: TColor);
- procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
- procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
- procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
- {$IFDEF WIN32}
- procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
- {$ENDIF}
- procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
- procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
- procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
- procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
- function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
- BevelStyle: TBevelStyle; IsDown: Boolean): TRect;
- protected
- FState: TButtonState;
- FDragging: Boolean;
- function GetPalette: HPALETTE; override;
- procedure Paint; override;
- procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
- X, Y: Integer); override;
- procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
- procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
- X, Y: Integer); override;
- procedure DrawGlyph(Canvas: TCanvas; const Client: TRect);
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Click; override;
- published
- property OnClick;
- property OnDblClick;
- property OnMouseDown;
- property OnMouseMove;
- property OnMouseUp;
- property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
- property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
- { Ensure group index is declared before Down }
- property Down: Boolean read FDown write SetDown default False;
- property Caption;
- property Enabled;
- property Font;
- property Glyph: TBitmap read GetGlyph write SetGlyph;
- property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;
- property Margin: Integer read FMargin write SetMargin default -1;
- property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
- property ParentFont;
- property ParentShowHint;
- property ShowHint;
- property Spacing: Integer read FSpacing write SetSpacing default 4;
- property Visible;
- property Bevel: TBevelStyle read FBevel write SetBevel default bsRaised;
- property DownColor: TColor read FDownColor write SetDownColor default clWhite;
- property BevelColor: TColor read FBevelColor write SetBevelColor default clBlack;
- end;
- implementation
- uses Consts, SysUtils, MMString;
- {$IFNDEF WIN32}
- { TBitPool }
- const
- BitsPerInt = SizeOf(Integer) * 8;
- type
- TBitEnum = 0..BitsPerInt - 1;
- TBitSet = set of TBitEnum;
- TBitPool = class
- private
- FSize: Integer;
- FBits: Pointer;
- procedure SetSize(Value: Integer);
- procedure SetBit(Index: Integer; Value: Boolean);
- function GetBit(Index: Integer): Boolean;
- public
- destructor Destroy; override;
- function OpenBit: Integer;
- property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
- property Size: Integer read FSize write SetSize;
- end;
- {$ELSE}
- type
- TBitPool = class(TBits);
- {$ENDIF}
- type
- TGlyphList = class(TImageList)
- private
- Used: TBitPool;
- FCount: Integer;
- function AllocateIndex: Integer;
- public
- constructor Create(AWidth, AHeight: Integer);
- destructor Destroy; override;
- function Add(Image, Mask: TBitmap): Integer;
- function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
- procedure Delete(Index: Integer);
- property Count: Integer read FCount;
- end;
- TGlyphCache = class
- private
- GlyphLists: TList;
- public
- constructor Create;
- destructor Destroy; override;
- function GetList(AWidth, AHeight: Integer): TGlyphList;
- procedure ReturnList(List: TGlyphList);
- function Empty: Boolean;
- end;
- TButtonGlyph = class
- private
- FOriginal: TBitmap;
- FGlyphList: TGlyphList;
- FIndexs: array[TButtonState] of Integer;
- FTransparentColor: TColor;
- FNumGlyphs: TNumGlyphs;
- FOnChange: TNotifyEvent;
- procedure GlyphChanged(Sender: TObject);
- procedure SetGlyph(Value: TBitmap);
- procedure SetNumGlyphs(Value: TNumGlyphs);
- procedure Invalidate;
- function CreateButtonGlyph(State: TButtonState): Integer;
- procedure DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
- State: TButtonState);
- procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
- TextBounds: TRect; State: TButtonState);
- procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
- const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
- var GlyphPos: TPoint; var TextBounds: TRect);
- public
- constructor Create;
- destructor Destroy; override;
- { return the text rectangle }
- function Draw(Canvas: TCanvas; const Client: TRect;
- const Caption: string; Layout: TButtonLayout;
- Margin, Spacing: Integer; State: TButtonState): TRect;
- property Glyph: TBitmap read FOriginal write SetGlyph;
- property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
- property OnChange: TNotifyEvent read FOnChange write FOnChange;
- end;
- {$IFNDEF WIN32}
- type
- PBitArray = ^TBitArray;
- TBitArray = array[0..4096] of TBitSet;
- destructor TBitPool.Destroy;
- begin
- SetSize(0);
- inherited Destroy;
- end;
- procedure TBitPool.SetSize(Value: Integer);
- var
- NewMem: Pointer;
- NewMemSize: Integer;
- OldMemSize: Integer;
- function Min(X, Y: Integer): Integer;
- begin
- Result := X;
- if X > Y then Result := Y;
- end;
- begin
- if Value <> Size then
- begin
- NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
- OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
- if NewMemSize <> OldMemSize then
- begin
- NewMem := nil;
- if NewMemSize <> 0 then
- begin
- GetMem(NewMem, NewMemSize);
- FillChar(NewMem^, NewMemSize, 0);
- end
- else NewMem := nil;
- if OldMemSize <> 0 then
- begin
- if NewMem <> nil then
- Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize));
- FreeMem(FBits, OldMemSize);
- end;
- FBits := NewMem;
- end;
- FSize := Value;
- end;
- end;
- procedure TBitPool.SetBit(Index: Integer; Value: Boolean);
- begin
- if Value then
- Include(PBitArray(FBits)^[Index div BitsPerInt], Index mod BitsPerInt)
- else
- Exclude(PBitArray(FBits)^[Index div BitsPerInt], Index mod BitsPerInt);
- end;
- function TBitPool.GetBit(Index: Integer): Boolean;
- begin
- Result := Index mod BitsPerInt in PBitArray(FBits)^[Index div BitsPerInt];
- end;
- function TBitPool.OpenBit: Integer;
- var
- I: Integer;
- B: TBitSet;
- J: TBitEnum;
- E: Integer;
- begin
- E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
- for I := 0 to E do
- if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then
- begin
- B := PBitArray(FBits)^[I];
- for J := Low(J) to High(J) do
- begin
- if not (J in B) then
- begin
- Result := I * BitsPerInt + J;
- if Result >= Size then Result := Size;
- Exit;
- end;
- end;
- end;
- Result := Size;
- end;
- {$ENDIF}
- { TGlyphList }
- constructor TGlyphList.Create(AWidth, AHeight: Integer);
- begin
- {$IFDEF WIN32}
- inherited CreateSize(AWidth, AHeight);
- {$ELSE}
- inherited Create(AWidth, AHeight);
- {$ENDIF}
- Used := TBitPool.Create;
- end;
- destructor TGlyphList.Destroy;
- begin
- Used.Free;
- inherited Destroy;
- end;
- function TGlyphList.AllocateIndex: Integer;
- begin
- Result := Used.OpenBit;
- if Result >= Used.Size then
- begin
- Result := inherited Add(nil, nil);
- Used.Size := Result + 1;
- end;
- Used[Result] := True;
- end;
- function TGlyphList.Add(Image, Mask: TBitmap): Integer;
- begin
- Result := AllocateIndex;
- Replace(Result, Image, Mask);
- Inc(FCount);
- end;
- function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
- begin
- Result := AllocateIndex;
- ReplaceMasked(Result, Image, MaskColor);
- Inc(FCount);
- end;
- procedure TGlyphList.Delete(Index: Integer);
- begin
- if Used[Index] then
- begin
- Dec(FCount);
- Used[Index] := False;
- end;
- end;
- { TGlyphCache }
- constructor TGlyphCache.Create;
- begin
- inherited Create;
- GlyphLists := TList.Create;
- end;
- destructor TGlyphCache.Destroy;
- begin
- GlyphLists.Free;
- inherited Destroy;
- end;
- function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
- var
- I: Integer;
- begin
- for I := GlyphLists.Count - 1 downto 0 do
- begin
- Result := GlyphLists[I];
- with Result do
- if (AWidth = Width) and (AHeight = Height) then Exit;
- end;
- Result := TGlyphList.Create(AWidth, AHeight);
- GlyphLists.Add(Result);
- end;
- procedure TGlyphCache.ReturnList(List: TGlyphList);
- begin
- if List = nil then Exit;
- if List.Count = 0 then
- begin
- GlyphLists.Remove(List);
- List.Free;
- end;
- end;
- function TGlyphCache.Empty: Boolean;
- begin
- Result := GlyphLists.Count = 0;
- end;
- var
- GlyphCache: TGlyphCache;
- { TButtonGlyph }
- constructor TButtonGlyph.Create;
- var
- I: TButtonState;
- begin
- inherited Create;
- FOriginal := TBitmap.Create;
- FOriginal.OnChange := GlyphChanged;
- FTransparentColor := clOlive;
- FNumGlyphs := 1;
- for I := Low(I) to High(I) do
- FIndexs[I] := -1;
- if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
- end;
- destructor TButtonGlyph.Destroy;
- begin
- FOriginal.Free;
- Invalidate;
- if Assigned(GlyphCache) and GlyphCache.Empty then
- begin
- GlyphCache.Free;
- GlyphCache := nil;
- end;
- inherited Destroy;
- end;
- procedure TButtonGlyph.Invalidate;
- var
- I: TButtonState;
- begin
- for I := Low(I) to High(I) do
- begin
- if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
- FIndexs[I] := -1;
- end;
- GlyphCache.ReturnList(FGlyphList);
- FGlyphList := nil;
- end;
- procedure TButtonGlyph.GlyphChanged(Sender: TObject);
- begin
- if Sender = FOriginal then
- begin
- FTransparentColor := FOriginal.TransparentColor;
- Invalidate;
- if Assigned(FOnChange) then FOnChange(Self);
- end;
- end;
- procedure TButtonGlyph.SetGlyph(Value: TBitmap);
- var
- Glyphs: Integer;
- begin
- Invalidate;
- FOriginal.Assign(Value);
- if (Value <> nil) and (Value.Height > 0) then
- begin
- FTransparentColor := Value.TransparentColor;
- if Value.Width mod Value.Height = 0 then
- begin
- Glyphs := Value.Width div Value.Height;
- if Glyphs > 4 then Glyphs := 1;
- SetNumGlyphs(Glyphs);
- end;
- end;
- end;
- procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
- begin
- if (Value <> FNumGlyphs) and (Value > 0) then
- begin
- Invalidate;
- FNumGlyphs := Value;
- end;
- end;
- function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
- const
- ROP_DSPDxax = $00E20746;
- var
- TmpImage, MonoBmp: TBitmap;
- IWidth, IHeight: Integer;
- IRect, ORect: TRect;
- I: TButtonState;
- begin
- if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
- Result := FIndexs[State];
- if Result <> -1 then Exit;
- IWidth := FOriginal.Width div FNumGlyphs;
- IHeight := FOriginal.Height;
- if FGlyphList = nil then
- begin
- if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
- FGlyphList := GlyphCache.GetList(IWidth, IHeight);
- end;
- TmpImage := TBitmap.Create;
- try
- TmpImage.Width := IWidth;
- TmpImage.Height := IHeight;
- IRect := Rect(0, 0, IWidth, IHeight);
- TmpImage.Canvas.Brush.Color := clBtnFace;
- I := State;
- if Ord(I) >= NumGlyphs then I := bsUp;
- ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
- case State of
- bsUp, bsDown:
- begin
- TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
- FIndexs[State] := FGlyphList.Add(TmpImage, nil);
- end;
- bsExclusive:
- begin
- TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
- FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor);
- end;
- bsDisabled:
- if NumGlyphs > 1 then
- begin
- TmpImage.Canvas.BrushCopy(IRect, FOriginal, ORect, FTransparentColor);
- FIndexs[State] := FGlyphList.Add(TmpImage, nil);
- end
- else
- begin
- { Create a disabled version }
- MonoBmp := TBitmap.Create;
- try
- with MonoBmp do
- begin
- Assign(FOriginal);
- {$IFDEF DELPHI3}
- MonoBmp.HandleType := bmDDB;
- {$ENDIF}
- Canvas.Brush.Color := clBlack;
- Width := IWidth;
- if Monochrome then
- begin
- Canvas.Font.Color := clWhite;
- Monochrome := False;
- Canvas.Brush.Color := clWhite;
- end;
- Monochrome := True;
- end;
- with TmpImage.Canvas do
- begin
- Brush.Color := clBtnFace;
- FillRect(IRect);
- Brush.Color := clBlack;
- Font.Color := clWhite;
- CopyMode := MergePaint;
- Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
- CopyMode := SrcAnd;
- Draw(IRect.Left, IRect.Top, MonoBmp);
- Brush.Color := clBtnShadow;
- Font.Color := clBlack;
- CopyMode := SrcPaint;
- Draw(IRect.Left, IRect.Top, MonoBmp);
- CopyMode := SrcCopy;
- end;
- FIndexs[State] := FGlyphList.Add(TmpImage, nil);
- finally
- MonoBmp.Free;
- end;
- end;
- end;
- finally
- TmpImage.Free;
- end;
- Result := FIndexs[State];
- FOriginal.Dormant;
- end;
- procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;
- State: TButtonState);
- var
- Index: Integer;
- begin
- if FOriginal = nil then Exit;
- if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
- Index := CreateButtonGlyph(State);
- FGlyphList.Draw(Canvas, X, Y, Index);
- end;
- procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
- TextBounds: TRect; State: TButtonState);
- var
- CString: PChar;
- begin
- if Length(Caption) > 0 then
- begin
- CString := StrAlloc(Length(Caption)+1);
- try
- StrPCopy(CString, Caption);
- Canvas.Brush.Style := bsClear;
- if State = bsDisabled then
- begin
- with Canvas do
- begin
- OffsetRect(TextBounds, 1, 1);
- Font.Color := clWhite;
- DrawText(Handle, CString, Length(Caption), TextBounds, 0);
- OffsetRect(TextBounds, -1, -1);
- Font.Color := clDkGray;
- DrawText(Handle, CString, Length(Caption), TextBounds, 0);
- end;
- end
- else DrawText(Canvas.Handle, CString, -1, TextBounds,
- DT_CENTER or DT_VCENTER or DT_SINGLELINE);
- finally
- StrDispose(CString);
- end;
- end;
- end;
- procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
- const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
- var GlyphPos: TPoint; var TextBounds: TRect);
- var
- TextPos: TPoint;
- ClientSize, GlyphSize, TextSize: TPoint;
- TotalSize: TPoint;
- CString: PChar;
- begin
- CString := StrAlloc(Length(Caption)+2);
- StrPCopy(CString, Caption);
- try
- { calculate the item sizes }
- ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);
- if FOriginal <> nil then
- GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)
- else
- GlyphSize := Point(0, 0);
- if Length(Caption) > 0 then
- begin
- TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
- DrawText(Canvas.Handle, CString, -1, TextBounds, DT_CALCRECT);
- end
- else TextBounds := Rect(0, 0, 0, 0);
- TextSize := Point(TextBounds.Right - TextBounds.Left,
- TextBounds.Bottom -TextBounds.Top);
- { If the layout has the glyph on the right or the left, then both the
- text and the glyph are centered vertically. If the glyph is on the top
- or the bottom, then both the text and the glyph are centered horizontally.}
- if Layout in [blGlyphLeft, blGlyphRight] then
- begin
- GlyphPos.Y := (ClientSize.Y div 2) - (GlyphSize.Y div 2);
- TextPos.Y := (ClientSize.Y div 2) - (TextSize.Y div 2);
- end
- else
- begin
- GlyphPos.X := (ClientSize.X div 2) - (GlyphSize.X div 2);
- TextPos.X := (ClientSize.X div 2) - (TextSize.X div 2);
- end;
- { if there is no text or no bitmap, then Spacing is irrelevant }
- if (TextSize.X = 0) or (GlyphSize.X = 0) then Spacing := 0;
- { adjust Margin and Spacing }
- if Margin = -1 then
- begin
- if Spacing = -1 then
- begin
- TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
- if Layout in [blGlyphLeft, blGlyphRight] then
- Margin := (ClientSize.X - TotalSize.X) div 3
- else
- Margin := (ClientSize.Y - TotalSize.Y) div 3;
- Spacing := Margin;
- end
- else
- begin
- TotalSize := Point(GlyphSize.X + Spacing + TextSize.X,
- GlyphSize.Y + Spacing + TextSize.Y);
- if Layout in [blGlyphLeft, blGlyphRight] then
- Margin := (ClientSize.X div 2) - (TotalSize.X div 2)
- else
- Margin := (ClientSize.Y div 2) - (TotalSize.Y div 2);
- end;
- end
- else
- begin
- if Spacing = -1 then
- begin
- TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X),
- ClientSize.Y - (Margin + GlyphSize.Y));
- if Layout in [blGlyphLeft, blGlyphRight] then
- Spacing := (TotalSize.X div 2) - (TextSize.X div 2)
- else
- Spacing := (TotalSize.Y div 2) - (TextSize.Y div 2);
- end;
- end;
- case Layout of
- blGlyphLeft:
- begin
- GlyphPos.X := Margin;
- TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
- end;
- blGlyphRight:
- begin
- GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
- TextPos.X := GlyphPos.X - Spacing - TextSize.X;
- end;
- blGlyphTop:
- begin
- GlyphPos.Y := Margin;
- TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
- end;
- blGlyphBottom:
- begin
- GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
- TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
- end;
- end;
- { fixup the result variables }
- Inc(GlyphPos.X, Client.Left);
- Inc(GlyphPos.Y, Client.Top);
- OffsetRect(TextBounds, TextPos.X + Client.Left, TextPos.Y + Client.Top);
- finally
- StrDispose(CString);
- end;
- end;
- function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
- const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
- State: TButtonState): TRect;
- var
- GlyphPos: TPoint;
- TextBounds: TRect;
- begin
- CalcButtonLayout(Canvas, Client, Caption, Layout, Margin, Spacing,
- GlyphPos, TextBounds);
- DrawButtonGlyph(Canvas, GlyphPos.X, GlyphPos.Y, State);
- DrawButtonText(Canvas, Caption, TextBounds, State);
- Result := TextBounds;
- end;
- {== TMMSpeedButton ======================================================}
- constructor TMMSpeedButton.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FPattern := nil;
-
- SetBounds(0, 0, 25, 25);
- ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
- FGlyph := TButtonGlyph.Create;
- TButtonGlyph(FGlyph).OnChange := GlyphChanged;
- ParentFont := True;
- FSpacing := 4;
- FMargin := -1;
- FLayout := blGlyphLeft;
- FBevel := bsRaised;
- FDownColor := clWhite;
- FBevelColor := clBlack;
- ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
- if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- destructor TMMSpeedButton.Destroy;
- begin
- TButtonGlyph(FGlyph).Free;
- if FPattern <> nil then FPattern.Free;
- inherited Destroy;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CreateBrushPattern;
- var
- X, Y: Integer;
- begin
- if FPattern <> nil then FPattern.Free;
- FPattern := TBitmap.Create;
- FPattern.Width := 8;
- FPattern.Height := 8;
- with FPattern.Canvas do
- begin
- Brush.Style := bsSolid;
- Brush.Color := clBtnFace;
- FillRect(Rect(0, 0, FPattern.Width, FPattern.Height));
- for Y := 0 to 7 do
- for X := 0 to 7 do
- if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }
- Pixels[X, Y] := FDownColor; { on even/odd rows }
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.DrawGlyph(Canvas: TCanvas; const Client: TRect);
- begin
- TButtonGlyph(FGlyph).Draw(Canvas,Client,Caption,FLayout,FMargin,
- FSpacing,FState);
- end;
- { DrawButtonFace - returns the remaining usable area inside the Client rect.}
- {-- TMMSpeedButton ------------------------------------------------------}
- function TMMSpeedButton.DrawButtonFace(Canvas: TCanvas; const Client: TRect;
- BevelStyle: TBevelStyle; IsDown: Boolean): TRect;
- var
- R: TRect;
- begin
- R := Client;
- with Canvas do
- begin
- Brush.Color := clBtnFace;
- Brush.Style := bsSolid;
- FillRect(R);
- if IsDown then
- begin
- Frame3D(Canvas, R, BevelColor, clBtnHighlight, 1);
- Frame3D(Canvas, R, clBtnShadow, clBtnFace, 1);
- end
- else
- begin
- if BevelStyle = bsRaised then
- begin
- Frame3D(Canvas, R, clBtnHighLight, BevelColor, 1);
- Frame3D(Canvas, R, clBtnFace, clBtnShadow, 1);
- end
- else
- begin
- Pen.Color := BevelColor;
- Rectangle(R.Left, R.Top, R.Right-1, R.Bottom-1);
- Pen.Color := clBtnHighLight;
- PolyLine([Point(R.Left+1, R.Bottom), Point(R.Left+1, R.Top+1),
- Point(R.Right-2, R.Top+1)]);
- PolyLine([Point(R.Right-1, R.Top), Point(R.Right-1, R.Bottom-1),
- Point(R.Left+1, R.Bottom-1)]);
- end;
- end;
- end;
- Result := Rect(Client.Left, Client.Top,
- Client.Right - 1, Client.Bottom - 1);
- if IsDown then OffsetRect(Result, 1, 1);
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.Paint;
- var
- PaintRect: TRect;
- begin
- if not Enabled and not (csDesigning in ComponentState) then
- begin
- FState := bsDisabled;
- FDragging := False;
- end
- else if FState = bsDisabled then FState := bsUp;
- Canvas.Font := Self.Font;
- PaintRect := DrawButtonFace(Canvas, Rect(0, 0, Width, Height), FBevel,
- FState in [bsDown, bsExclusive]);
- if FState = bsExclusive then
- begin
- CreateBrushPattern;
- Canvas.Brush.Bitmap := FPattern;
- dec(PaintRect.Right);
- dec(PaintRect.Bottom);
- Canvas.FillRect(PaintRect);
- Canvas.Brush.Bitmap := nil;
- FPattern.Free;
- FPattern := nil;
- end;
- DrawGlyph(Canvas,PaintRect);
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetBevel(Value: TBevelStyle);
- begin
- if (Value <> FBevel) then
- begin
- FBevel := Value;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetDownColor(Value: TColor);
- begin
- if (Value <> FDownColor) then
- begin
- FDownColor := Value;
- FPattern.Free;
- FPattern := nil;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetBevelColor(Value: TColor);
- begin
- if (Value <> FBevelColor) then
- begin
- FBevelColor := Value;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
- X, Y: Integer);
- begin
- inherited MouseDown(Button, Shift, X, Y);
- if (Button = mbLeft) and Enabled then
- begin
- if not FDown then
- begin
- FState := bsDown;
- Repaint;
- end;
- FDragging := True;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);
- var
- NewState: TButtonState;
- begin
- inherited MouseMove(Shift, X, Y);
- if FDragging then
- begin
- if not FDown then NewState := bsUp
- else NewState := bsExclusive;
- if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
- if FDown then NewState := bsExclusive else NewState := bsDown;
- if NewState <> FState then
- begin
- FState := NewState;
- Repaint;
- end;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
- X, Y: Integer);
- var
- DoClick: Boolean;
- begin
- inherited MouseUp(Button, Shift, X, Y);
- if FDragging then
- begin
- FDragging := False;
- DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
- FState := bsUp;
- if FGroupIndex = 0 then
- Repaint
- else
- if DoClick then SetDown(not FDown)
- else
- begin
- if FDown then FState := bsExclusive;
- Repaint;
- end;
- if DoClick then Click;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.Click;
- begin
- inherited Click;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- function TMMSpeedButton.GetPalette: HPALETTE;
- begin
- Result := Glyph.Palette;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- function TMMSpeedButton.GetGlyph: TBitmap;
- begin
- Result := TButtonGlyph(FGlyph).Glyph;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetGlyph(Value: TBitmap);
- begin
- TButtonGlyph(FGlyph).Glyph := Value;
- Invalidate;
- {$IFDEF WIN32}
- {$IFDEF TRIAL}
- {$DEFINE _HACK2}
- {$I MMHACK.INC}
- {$ENDIF}
- {$ENDIF}
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- function TMMSpeedButton.GetNumGlyphs: TNumGlyphs;
- begin
- Result := TButtonGlyph(FGlyph).NumGlyphs;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetNumGlyphs(Value: TNumGlyphs);
- begin
- {$IFDEF WIN32}
- {$IFDEF TRIAL}
- {$DEFINE _HACK3}
- {$I MMHACK.INC}
- {$ENDIF}
- {$ENDIF}
- if Value < 0 then Value := 1
- else if Value > 4 then Value := 4;
- if Value <> TButtonGlyph(FGlyph).NumGlyphs then
- begin
- TButtonGlyph(FGlyph).NumGlyphs := Value;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.GlyphChanged(Sender: TObject);
- begin
- Invalidate;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.UpdateExclusive;
- var
- Msg: TMessage;
- begin
- if (FGroupIndex <> 0) and (Parent <> nil) then
- begin
- Msg.Msg := CM_BUTTONPRESSED;
- Msg.WParam := FGroupIndex;
- Msg.LParam := Longint(Self);
- Msg.Result := 0;
- Parent.Broadcast(Msg);
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetDown(Value: Boolean);
- begin
- if FGroupIndex = 0 then Value := False;
- if Value <> FDown then
- begin
- if FDown and (not FAllowAllUp) then Exit;
- FDown := Value;
- if Value then FState := bsExclusive
- else FState := bsUp;
- Invalidate;
- if Value then UpdateExclusive;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetGroupIndex(Value: Integer);
- begin
- if FGroupIndex <> Value then
- begin
- FGroupIndex := Value;
- UpdateExclusive;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetLayout(Value: TButtonLayout);
- begin
- if FLayout <> Value then
- begin
- FLayout := Value;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetMargin(Value: Integer);
- begin
- if (Value <> FMargin) and (Value >= -1) then
- begin
- FMargin := Value;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetSpacing(Value: Integer);
- begin
- if Value <> FSpacing then
- begin
- FSpacing := Value;
- Invalidate;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.SetAllowAllUp(Value: Boolean);
- begin
- if FAllowAllUp <> Value then
- begin
- FAllowAllUp := Value;
- UpdateExclusive;
- end;
- {$IFDEF WIN32}
- {$IFDEF TRIAL}
- {$DEFINE _HACK1}
- {$I MMHACK.INC}
- {$ENDIF}
- {$ENDIF}
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.WMLButtonDblClk(var Message: TWMLButtonDown);
- begin
- inherited;
- if FDown then DblClick;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMEnabledChanged(var Message: TMessage);
- begin
- Invalidate;
- end;
- {$IFDEF WIN32}
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMHintShow(var Message: TMessage);
- begin
- Message.Result := Ord(not Enabled);
- end;
- {$ENDIF}
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMButtonPressed(var Message: TMessage);
- var
- Sender: TMMSpeedButton;
- begin
- if Message.WParam = FGroupIndex then
- begin
- Sender := TMMSpeedButton(Message.LParam);
- if Sender <> Self then
- begin
- if Sender.Down and FDown then
- begin
- FDown := False;
- FState := bsUp;
- Invalidate;
- end;
- FAllowAllUp := Sender.AllowAllUp;
- end;
- end;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMDialogChar(var Message: TCMDialogChar);
- begin
- with Message do
- if IsAccel(CharCode, Caption) and Enabled then
- begin
- Click;
- Result := 1;
- end
- else inherited;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMFontChanged(var Message: TMessage);
- begin
- Invalidate;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMTextChanged(var Message: TMessage);
- begin
- Invalidate;
- end;
- {-- TMMSpeedButton ------------------------------------------------------}
- procedure TMMSpeedButton.CMSysColorChange(var Message: TMessage);
- begin
- TButtonGlyph(FGlyph).Invalidate;
- end;
- end.