dcoutbar.pas

XP风格的outbar.rar.有DELPHI,C++BULIDER的例子及源码

Procedure TCustomDCTranspScrollBar.SetPosition (Value : Integer) ;
Var OldPosition : Integer ;
Begin
  If (FPosition <> Value) AND (Value >= Min) AND (Value <= Max) Then
  Begin
    OldPosition := FPosition ;
    FPosition := Value ;
    If Assigned (FOnChange) Then
      FOnChange (Self) ;
    If NOT ((Position > Min) AND (OldPosition > Min) AND
       (Position < Max) AND (OldPosition < Max)) Then
      Invalidate ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.SetKind (Value : TScrollBarKind) ;
Begin
  If csLoading in ComponentState Then
  Begin
    FKind := Value ;
    Exit ;
  End ;
  If FKind <> Value Then
  Begin
    FKind := Value ;
    SetBounds (Left, Top, Height, Width) ;
    InitAutoSize ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.SetTransparent (Value : Boolean) ;
Begin
  If Transparent <> Value Then
  Begin
    If Value Then
      ControlStyle := ControlStyle - [csOpaque]
    Else
      ControlStyle := ControlStyle + [csOpaque] ;
    Invalidate;
    Update ;
  End ;
End ;

{-----------------------------------------------------------}

Function TCustomDCTranspScrollBar.GetTransparent : Boolean ;
Begin
  Result := NOT (csOpaque in ControlStyle) ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.SetFrequency(Value:Integer);
Begin
  If (FFrequency<>Value) And (Value>0) Then
    FFrequency:=Value;
End;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.SetShift (Value : Integer) ;
Begin
  If FShift <> Value Then
  Begin
    FShift := Value ;
    Invalidate ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.Paint ;
Var StateUp : Boolean ;
    StateDown : Boolean ;
Begin
  Canvas.Brush.Color := Color ;
  Canvas.Brush.Style := bsSolid;
  If NOT Transparent Then
    Canvas.FillRect (ClientRect) ;
  If csDesigning in ComponentState Then
  Begin
    DrawButton (TRUE, FALSE) ;
    DrawButton (FALSE, FALSE) ;
  End
  Else
  Begin
    StateUp := FALSE ;
    StateDOWN := FALSE ;
    If MouseCapture Then
    Begin
      If FButtonsDown Then
        StateUp := TRUE
      Else
        StateDown := TRUE ;
    End ;

    If Position > Min Then
      DrawButton (TRUE, StateUp) ;
    If Position < Max Then
      DrawButton (FALSE, StateDown) ;
  End ;
End ;

{-----------------------------------------------------------}

Function TCustomDCTranspScrollBar.GetButtonRect (Tip : Boolean) : TRect ;
Var Tmp : Integer ;

  Function CalcAddSize (Factor : Integer) : Integer ;
  Begin
    Dec (Factor, 2 * Shift) ;
    If Factor <= 0 Then
      Result := 0
    Else If 2 * FAddSize < Factor Then
      Result := FAddSize
    Else
      Result := Factor div 2 ;
    If Result > 0 Then
      Inc (Result, Shift) ;
  End ;

Begin
  If Kind = sbHorizontal Then
    Tmp := CalcAddSize (Width)
  Else
    Tmp := CalcAddSize (Height) ;

  If Tmp = 0 Then
  Begin
    SetRectEmpty (Result) ;
    Exit ;
  End ;

  If Tip Then
  Begin
    If Kind = sbHorizontal Then
      SetRect (Result, Shift, 0, Tmp, Height)
    Else
      SetRect (Result, 0, Shift, Width, Tmp) ;
  End
  Else
  Begin
    If Kind = sbHorizontal Then
      SetRect (Result, Width - Tmp, 0, Width - Shift, Height)
    Else
      SetRect (Result, 0, Height - Tmp, Width, Height - Shift) ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.DrawButton (Tip : Boolean ; State : Boolean) ;
Var Rect : TRect ;
    Tmp : Integer ;
Begin
  Rect := GetButtonRect (Tip) ;
  If Kind = sbHorizontal Then
  Begin
    If Tip Then
      Tmp := DFCS_SCROLLLEFT
    Else
      Tmp := DFCS_SCROLLRIGHT ;
  End
  Else
  Begin
    If Tip Then
      Tmp := DFCS_SCROLLUP
    Else
      Tmp := DFCS_SCROLLDOWN ;
  End ;
  If State Then
    Tmp := Tmp OR DFCS_PUSHED ;
  DrawFrameControl (Canvas.Handle, Rect, DFC_SCROLL, Tmp) ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.MouseDown (Button : TMouseButton ; Shift : TShiftState ; X, Y : Integer) ;
Var Point : TPoint ;
Begin
  Inherited ;
  Point.X := X ;
  Point.Y := Y ;
  If Button = mbLeft Then
  Begin
    If PtInRect (GetButtonRect (TRUE), Point) AND (Position > 0) Then
      FButtonsDown := TRUE
    Else If PtInRect (GetButtonRect (FALSE), Point) AND (Position < Max) Then
      FButtonsDown := FALSE
    Else
      Exit ;

    FActiveButtonDown := TRUE ;
    DrawButton (FButtonsDown, TRUE) ;
    FTimer.Interval := FFrequency ;
    FTimer.Enabled := TRUE ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.MouseMove (Shift : TShiftState ; X, Y : Integer) ;
Var Point : TPoint ;
Begin
  Inherited ;
  Point.X := X ;
  Point.Y := Y ;
  If MouseCapture Then
    If PtInRect (GetButtonRect (FButtonsDown), Point) <> FActiveButtonDown Then
    Begin
      FActiveButtonDown := NOT FActiveButtonDown ;
      If (Position > Min) AND (Position < Max) Then
        DrawButton (FButtonsDown, FActiveButtonDown) ;
    End
    Else
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.MouseUp (Button : TMouseButton ; Shift : TShiftState ; X, Y: Integer) ;
Var Point : TPoint ;
Begin
  Inherited ;
  If Button=mbLeft Then
  Begin
    FTimer.Enabled:=False;
    Point.X:=X;
    Point.Y:=Y;
    If PtInRect(GetButtonRect(FButtonsDown),Point) Then
      DoPosition;
    If (Position > Min) AND (Position < Max) Then
      DrawButton (FButtonsDown, FALSE) ;
  End;
End;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.OnTimer (Sender : TObject) ;
Var Point : TPoint ;
Begin
  Inherited ;
  GetCursorPos (Point) ;
  Point := ScreenToClient (Point) ;
  If PtInRect (GetButtonRect (FButtonsDown), Point) Then
    DoPosition ;
End ;

{-----------------------------------------------------------}

Function TCustomDCTranspScrollBar.DoPosition : Boolean ;
Begin
  Result := TRUE ;
  If FButtonsDown Then
  Begin
    If Position > Min Then
      Position := Position - 1
    Else
      Result := FALSE ;
  End
  Else If Position < Max Then
    Position := Position + 1
  Else
    Result := FALSE ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCTranspScrollBar.Loaded ;
Begin
  Inherited ;
  Kind := FKind ;
  AutoSize := FAutoSize ;
End ;

{***********************************************************}

Constructor TCustomDCScrollButton.Create (AOwner : TComponent) ;
Begin
  Inherited ;
  FTimer := TTimer.Create (Self) ;
  FTimer.Enabled := FALSE ;
  FTimer.OnTimer := OnTimer ;
  FButtonStyle := dcsbs_ScrollDown ;
  FFrequency := 100 ;
  AutoSize := TRUE ;
End ;

{-----------------------------------------------------------}

Destructor TCustomDCScrollButton.Destroy ;
Begin
  FTimer.Free ;
  Inherited ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCScrollButton.InternalSetAutoSize(Value:Boolean);
Begin
  FAutoSize := Value ;
  InitAutoSize ;
  Invalidate ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCScrollButton.SetButtonStyle (Value : TDCScrollButtonStyle) ;
Begin
  If FButtonStyle <> Value Then
  Begin
    FButtonStyle := Value ;
    Invalidate ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCScrollButton.SetFrequency (Value : Integer) ;
Begin
  If (FFrequency <> Value) AND (Value > 0) Then
    FFrequency := Value ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCScrollButton.WMEraseBkgnd (Var Message : TWmEraseBkgnd) ;
Begin
  Message.Result := -1;
End;

{-----------------------------------------------------------}

Procedure TCustomDCScrollButton.InitAutoSize ;
Var
    i : Integer ;
Begin
  If AutoSize Then
  Begin
    i := GetSystemMetrics (SM_CXVSCROLL) ;
    Height := i ;
    Width := i ;
  End ;
End ;

{-----------------------------------------------------------}

Procedure TCustomDCScrollButton.DrawButton (State : Boolean) ;
Var uType : UINT ;
    uState : UINT ;
Begin
  uType := 0 ;
  uState := 0 ;
  Case FButtonStyle of
    dcsbs_ScrollDown,
    dcsbs_ScrollLeft,
    dcsbs_ScrollRight,
    dcsbs_ScrollUp:
    Begin
      uType := DFC_SCROLL ;
      Case FButtonStyle of
        dcsbs_ScrollDown: uState := DFCS_SCROLLDOWN ;
        dcsbs_ScrollLeft: uState := DFCS_SCROLLLEFT ;
        dcsbs_ScrollRight: uState := DFCS_SCROLLRIGHT ;
        dcsbs_ScrollUp: uState := DFCS_SCROLLUP ;
      End ;
    End ;

    dcsbs_CaptionClose,
    dcsbs_CaptionHelp,
    dcsbs_CaptionMAX,
    dcsbs_CaptionMIN,
    dcsbs_CaptionRestore:
    Begin
      uType := DFC_CAPTION ;
      Case FButtonStyle of
        dcsbs_CaptionClose: uState := DFCS_CAPTIONCLOSE ;