平滑SpeedButton |
|
conundrum
尊榮會員 發表:893 回覆:1272 積分:643 註冊:2004-01-06 發送簡訊給我 |
平滑SpeedButton http://dev.csdn.net/Develop/article//10/10974.shtm mysine [原作] unit TFlatSpeedButtonUnit; interface {$I Version.inc} uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls, ExtCtrls, CommCtrl, Buttons, FlatUtilitys; type TFlatSpeedButton = class(TGraphicControl) private FUseAdvColors: Boolean; FAdvColorFocused: TAdvColors; FAdvColorDown: TAdvColors; FAdvColorBorder: TAdvColors; TextBounds: TRect; GlyphPos: TPoint; FNumGlyphs: TNumGlyphs; FDownColor: TColor; FBorderColor: TColor; FColorHighlight: TColor; FColorShadow: TColor; FFocusedColor: TColor; FGroupIndex: Integer; FGlyph: TBitmap; FDown: Boolean; FDragging: Boolean; FAllowAllUp: Boolean; FLayout: TButtonLayout; FSpacing: Integer; FMargin: Integer; FMouseInControl: Boolean; FModalResult: TModalResult; procedure SetColors (Index: Integer; Value: TColor); procedure SetAdvColors (Index: Integer; Value: TAdvColors); procedure SetUseAdvColors (Value: Boolean); procedure UpdateExclusive; procedure SetGlyph (Value: TBitmap); 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 UpdateTracking; procedure WMLButtonDblClk (var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK; procedure CMEnabledChanged (var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMButtonPressed (var Message: TMessage); message CM_BUTTONPRESSED; 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; procedure CMParentColorChanged (var Message: TWMNoParams); message CM_PARENTCOLORCHANGED; procedure RemoveMouseTimer; procedure MouseTimerHandler (Sender: TObject); protected FState: TButtonState; function GetPalette: HPALETTE; override; procedure CalcAdvColors; procedure Loaded; 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 Paint; override; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure Click; override; procedure MouseEnter; procedure MouseLeave; published property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False; property Color default $00E1EAEB; property ColorFocused: TColor index 0 read FFocusedColor write SetColors default $00E1EAEB; property ColorDown: TColor index 1 read FDownColor write SetColors default $00C5D6D9; property ColorBorder: TColor index 2 read FBorderColor write SetColors default $008396A0; property ColorHighLight: TColor index 3 read FColorHighlight write SetColors default clWhite; property ColorShadow: TColor index 4 read FColorShadow write SetColors default clBlack; property AdvColorFocused: TAdvColors index 0 read FAdvColorFocused write SetAdvColors default 10; property AdvColorDown: TAdvColors index 1 read FAdvColorDown write SetAdvColors default 10; property AdvColorBorder: TAdvColors index 2 read FAdvColorBorder write SetAdvColors default 50; property UseAdvColors: Boolean read FUseAdvColors write SetUseAdvColors default false; property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0; property Down: Boolean read FDown write SetDown default False; property Caption; property Enabled; property Font; property Glyph: TBitmap read FGlyph write SetGlyph; property Layout: TButtonLayout read FLayout write SetLayout default blGlyphTop; property Margin: Integer read FMargin write SetMargin default -1; property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1; property ModalResult: TModalResult read FModalResult write FModalResult default 0; property ParentFont; property ParentColor; property ParentShowHint; property PopupMenu; property ShowHint; property Spacing: Integer read FSpacing write SetSpacing default 4; property Visible; property OnClick; property OnDblClick; property OnMouseDown; property OnMouseMove; property OnMouseUp; {$IFDEF D4CB4} property Anchors; property BiDiMode; property Constraints; property DragKind; property ParentBiDiMode; property OnEndDock; property OnStartDock; {$ENDIF} end; var MouseInControl: TFlatSpeedButton = nil; implementation var MouseTimer: TTimer = nil; ControlCounter: Integer = 0; constructor TFlatSpeedButton.Create (AOwner: TComponent); begin inherited Create(AOwner); if MouseTimer = nil then begin MouseTimer := TTimer.Create(nil); MouseTimer.Enabled := False; MouseTimer.Interval := 100; // 10 times a second end; SetBounds(0, 0, 25, 25); ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks]; FGlyph := TBitmap.Create; FNumGlyphs := 1; ParentFont := True; ParentColor := True; FFocusedColor := $00E1EAEB; FDownColor := $00C5D6D9; FBorderColor := $008396A0; FColorHighlight := clWhite; FColorShadow := clBlack; FSpacing := 4; FMargin := -1; FLayout := blGlyphTop; FUseAdvColors := false; FAdvColorFocused := 10; FAdvColorDown := 10; FAdvColorBorder := 50; FModalResult := mrNone; Inc(ControlCounter); end; destructor TFlatSpeedButton.Destroy; begin RemoveMouseTimer; FGlyph.Free; Dec(ControlCounter); if ControlCounter = 0 then begin MouseTimer.Free; MouseTimer := nil; end; inherited Destroy; end; procedure TFlatSpeedButton.Paint; var FTransColor: TColor; FImageList: TImageList; sourceRect, destRect: TRect; tempGlyph, memoryBitmap: TBitmap; buttonRect: TRect; Offset: TPoint; begin // get the transparent color FTransColor := FGlyph.Canvas.Pixels[0, FGlyph.Height - 1]; buttonRect := ClientRect; memoryBitmap := TBitmap.Create; // create memory-bitmap to draw flicker-free try memoryBitmap.Height := ClientRect.Bottom; memoryBitmap.Width := ClientRect.Right; memoryBitmap.Canvas.Font := Self.Font; if FState in [bsDown, bsExclusive] then Offset := Point(1, 1) else Offset := Point(0, 0); CalcButtonLayout(memoryBitmap.Canvas, ClientRect, Offset, FLayout, FSpacing, FMargin, FGlyph, FNumGlyphs, Caption, TextBounds, GlyphPos); if not Enabled then begin FState := bsDisabled; FDragging := False; end else if FState = bsDisabled then if FDown and (GroupIndex <> 0) then FState := bsExclusive else FState := bsUp; // DrawBorder case FState of bsUp: if FMouseInControl then Frame3D(memoryBitmap.canvas, buttonRect, FColorHighlight, FColorShadow, 1) else Frame3D(memoryBitmap.canvas, buttonRect, FBorderColor, FBorderColor, 1); bsDown, bsExclusive: Frame3D(memoryBitmap.canvas, buttonRect, FColorShadow, FColorHighlight, 1); bsDisabled: Frame3D(memoryBitmap.canvas, buttonRect, FBorderColor, FBorderColor, 1); end; // DrawBackground case FState of bsUp: if FMouseInControl then memoryBitmap.Canvas.Brush.Color := FFocusedColor else memoryBitmap.Canvas.Brush.Color := Self.Color; bsDown: memoryBitmap.Canvas.Brush.Color := FDownColor; bsExclusive: if FMouseInControl then memoryBitmap.Canvas.Brush.Color := FFocusedColor else memoryBitmap.Canvas.Brush.Color := FDownColor; bsDisabled: memoryBitmap.Canvas.Brush.Color := Self.Color; end; memoryBitmap.Canvas.FillRect(buttonRect); // DrawGlyph if not FGlyph.Empty then begin tempGlyph := TBitmap.Create; case FNumGlyphs of 1: case FState of bsUp: sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height); bsDisabled: sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height); bsDown: sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height); bsExclusive: sourceRect := Rect(0, 0, FGlyph.Width, FGlyph.Height); end; 2: case FState of bsUp: sourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height); bsDisabled: sourceRect := Rect(FGlyph.Width div FNumGlyphs, 0, FGlyph.Width, FGlyph.Height); bsDown: sourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height); bsExclusive: sourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height); end; 3: case FState of bsUp: SourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height); bsDisabled: SourceRect := Rect(FGlyph.width div FNumGlyphs, 0, (FGlyph.Width div FNumGlyphs) * 2, FGlyph.Height); bsDown: SourceRect := Rect((FGlyph.Width div FNumGlyphs) * 2, 0, FGlyph.Width, FGlyph.Height); bsExclusive: SourceRect := Rect((FGlyph.Width div FNumGlyphs) * 2, 0, FGlyph.Width, FGlyph.Height); end; 4: case FState of bsUp: SourceRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height); bsDisabled: SourceRect := Rect(FGlyph.width div FNumGlyphs, 0, (FGlyph.Width div FNumGlyphs) * 2, FGlyph.Height); bsDown: SourceRect := Rect((FGlyph.Width div FNumGlyphs) * 2, 0, (FGlyph.Width div FNumGlyphs) * 3, FGlyph.Height); bsExclusive: SourceRect := Rect((FGlyph.width div FNumGlyphs) * 3, 0, FGlyph.Width, FGlyph.Height); end; end; destRect := Rect(0, 0, FGlyph.Width div FNumGlyphs, FGlyph.Height); tempGlyph.Width := FGlyph.Width div FNumGlyphs; tempGlyph.Height := FGlyph.Height; tempGlyph.canvas.copyRect(destRect, FGlyph.canvas, sourcerect); if (FNumGlyphs = 1) and (FState = bsDisabled) then begin tempGlyph := CreateDisabledBitmap(tempGlyph, clBlack, clBtnFace, clBtnHighlight, clBtnShadow, True); FTransColor := tempGlyph.Canvas.Pixels[0, tempGlyph.Height - 1]; end; FImageList := TImageList.CreateSize(FGlyph.Width div FNumGlyphs, FGlyph.Height); try FImageList.AddMasked(tempGlyph, FTransColor); FImageList.Draw(memoryBitmap.canvas, glyphpos.x, glyphpos.y, 0); finally FImageList.Free; end; tempGlyph.free; end; // DrawText memoryBitmap.Canvas.Brush.Style := bsClear; if FState = bsDisabled then begin OffsetRect(TextBounds, 1, 1); memoryBitmap.Canvas.Font.Color := clBtnHighlight; DrawText(memoryBitmap.Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or DT_SINGLELINE); OffsetRect(TextBounds, -1, -1); memoryBitmap.Canvas.Font.Color := clBtnShadow; DrawText(memoryBitmap.Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or DT_SINGLELINE); end else DrawText(memoryBitmap.Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CENTER or DT_VCENTER or DT_SINGLELINE); // Copy memoryBitmap to screen canvas.CopyRect(ClientRect, memoryBitmap.canvas, ClientRect); finally memoryBitmap.free; // delete the bitmap end; end; procedure TFlatSpeedButton.UpdateTracking; var P: TPoint; begin if Enabled then begin GetCursorPos(P); FMouseInControl := not (FindDragTarget(P, True) = Self); if FMouseInControl then MouseLeave else MouseEnter; end; end; procedure TFlatSpeedButton.Loaded; begin inherited Loaded; Invalidate; end; procedure TFlatSpeedButton.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; Invalidate; end; FDragging := True; end; end; procedure TFlatSpeedButton.MouseMove (Shift: TShiftState; X, Y: Integer); var NewState: TButtonState; P: TPoint; begin inherited; // mouse is in control ? P := ClientToScreen(Point(X, Y)); if (MouseInControl <> Self) and (FindDragTarget(P, True) = Self) then begin if Assigned(MouseInControl) then MouseInControl.MouseLeave; // the application is active ? if (GetActiveWindow <> 0) then begin if MouseTimer.Enabled then MouseTimer.Enabled := False; MouseInControl := Self; MouseTimer.OnTimer := MouseTimerHandler; MouseTimer.Enabled := True; MouseEnter; end; end; 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; Invalidate; end; end; end; procedure TFlatSpeedButton.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); if FGroupIndex = 0 then begin // Redraw face in-case mouse is captured FState := bsUp; FMouseInControl := False; if DoClick and not (FState in [bsExclusive, bsDown]) then Invalidate; end else if DoClick then begin SetDown(not FDown); if FDown then Repaint; end else begin if FDown then FState := bsExclusive; Repaint; end; if DoClick then Click else MouseLeave; UpdateTracking; end; end; procedure TFlatSpeedButton.Click; begin if Parent <> nil then GetParentForm(self).ModalResult := FModalResult; inherited Click; end; function TFlatSpeedButton.GetPalette: HPALETTE; begin Result := FGlyph.Palette; end; procedure TFlatSpeedButton.SetColors (Index: Integer; Value: TColor); begin case Index of 0: FFocusedColor := Value; 1: FDownColor := Value; 2: FBorderColor := Value; 3: FColorHighlight := Value; 4: FColorShadow := Value; end; Invalidate; end; procedure TFlatSpeedButton.CalcAdvColors; begin if FUseAdvColors then begin FFocusedColor := CalcAdvancedColor(Color, FFocusedColor, FAdvColorFocused, lighten); FDownColor := CalcAdvancedColor(Color, FDownColor, FAdvColorDown, darken); FBorderColor := CalcAdvancedColor(Color, FBorderColor, FAdvColorBorder, darken); end; end; procedure TFlatSpeedButton.SetAdvColors (Index: Integer; Value: TAdvColors); begin case Index of 0: FAdvColorFocused := Value; 1: FAdvColorDown := Value; 2: FAdvColorBorder := Value; end; CalcAdvColors; Invalidate; end; procedure TFlatSpeedButton.SetUseAdvColors (Value: Boolean); begin if Value <> FUseAdvColors then begin FUseAdvColors := Value; ParentColor := Value; CalcAdvColors; Invalidate; end; end; procedure TFlatSpeedButton.SetGlyph (value: TBitmap); begin if value <> FGlyph then begin FGlyph.Assign(value); if not FGlyph.Empty then begin if FGlyph.Width mod FGlyph.Height = 0 then begin FNumGlyphs := FGlyph.Width div FGlyph.Height; if FNumGlyphs > 4 then FNumGlyphs := 1; end; end; Invalidate; end; end; procedure TFlatSpeedButton.SetNumGlyphs (value: TNumGlyphs); begin if value <> FNumGlyphs then begin FNumGlyphs := value; Invalidate; end; end; procedure TFlatSpeedButton.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; procedure TFlatSpeedButton.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 begin if FState = bsUp then Invalidate; FState := bsExclusive end else begin FState := bsUp; Repaint; end; if Value then UpdateExclusive; end; end; procedure TFlatSpeedButton.SetGroupIndex (Value: Integer); begin if FGroupIndex <> Value then begin FGroupIndex := Value; UpdateExclusive; end; end; procedure TFlatSpeedButton.SetLayout (Value: TButtonLayout); begin if FLayout <> Value then begin FLayout := Value; Invalidate; end; end; procedure TFlatSpeedButton.SetMargin (Value: Integer); begin if (Value <> FMargin) and (Value >= -1) then begin FMargin := Value; Invalidate; end; end; procedure TFlatSpeedButton.SetSpacing (Value: Integer); begin if Value <> FSpacing then begin FSpacing := Value; Invalidate; end; end; procedure TFlatSpeedButton.SetAllowAllUp (Value: Boolean); begin if FAllowAllUp <> Value then begin FAllowAllUp := Value; UpdateExclusive; end; end; procedure TFlatSpeedButton.WMLButtonDblClk (var Message: TWMLButtonDown); begin inherited; if FDown then DblClick; end; procedure TFlatSpeedButton.CMEnabledChanged (var Message: TMessage); begin inherited; if not Enabled then begin FMouseInControl := False; FState := bsDisabled; RemoveMouseTimer; end; UpdateTracking; Invalidate; end; procedure TFlatSpeedButton.CMButtonPressed (var Message: TMessage); var Sender: TFlatSpeedButton; begin if Message.WParam = FGroupIndex then begin Sender := TFlatSpeedButton(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; procedure TFlatSpeedButton.CMDialogChar (var Message: TCMDialogChar); begin with Message do if IsAccel(CharCode, Caption) and Enabled then begin Click; Result := 1; end else inherited; end; procedure TFlatSpeedButton.CMFontChanged (var Message: TMessage); begin Invalidate; end; procedure TFlatSpeedButton.CMTextChanged (var Message: TMessage); begin Invalidate; end; procedure TFlatSpeedButton.CMSysColorChange (var Message: TMessage); begin if FUseAdvColors then begin ParentColor := True; CalcAdvColors; end; Invalidate; end; procedure TFlatSpeedButton.CMParentColorChanged (var Message: TWMNoParams); begin inherited; if FUseAdvColors then begin ParentColor := True; CalcAdvColors; end; Invalidate; end; procedure TFlatSpeedButton.MouseEnter; begin if Enabled and not FMouseInControl then begin FMouseInControl := True; Repaint; end; end; procedure TFlatSpeedButton.MouseLeave; begin if Enabled and FMouseInControl and not FDragging then begin FMouseInControl := False; RemoveMouseTimer; Invalidate; end; end; procedure TFlatSpeedButton.MouseTimerHandler (Sender: TObject); var P: TPoint; begin GetCursorPos (P); if FindDragTarget(P, True) <> Self then MouseLeave; end; procedure TFlatSpeedButton.RemoveMouseTimer; begin if MouseInControl = Self then begin MouseTimer.Enabled := False; MouseInControl := nil; end; end; end. |
Diviner
初階會員 發表:36 回覆:112 積分:34 註冊:2002-03-13 發送簡訊給我 |
本站聲明 |
1. 本論壇為無營利行為之開放平台,所有文章都是由網友自行張貼,如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權,而損及您的利益,請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨,是藍是綠本站無權干涉,但這裡不是政治性論壇! |