flatbars.pas

相信大家已经找很长时间了

    FPosition := Value;
    Invalidate;
  end;
end;

procedure TFlatProgressBar.SetStep (Value: Integer);
begin
  if FStep <> Value then
  begin
    FStep := Value;
    Invalidate;
  end;
end;

procedure TFlatProgressBar.StepIt;
begin
  if (FPosition + FStep) > FMax then
    FPosition := FMax
  else
    FPosition := FPosition + FStep;
  DrawElements;
end;

procedure TFlatProgressBar.StepBy (Delta: Integer);
begin
  if (FPosition + Delta) > FMax then
    FPosition := FMax
  else
    FPosition := FPosition + Delta;
  DrawElements;
end;

procedure TFlatProgressBar.SetColors (Index: Integer; Value: TColor);
begin
  case Index of
    0: FElementColor := Value;
    1: FBorderColor := Value;
  end;
  Invalidate;
end;

procedure TFlatProgressBar.CalcAdvColors;
begin
  if FUseAdvColors then
  begin
    FBorderColor := CalcAdvancedColor(Color, FBorderColor, FAdvColorBorder, darken);
  end;
end;

procedure TFlatProgressBar.SetAdvColors (Index: Integer; Value: TAdvColors);
begin
  case Index of
    0: FAdvColorBorder := Value;
  end;
  CalcAdvColors;
  Invalidate;
end;

procedure TFlatProgressBar.SetUseAdvColors (Value: Boolean);
begin
  if Value <> FUseAdvColors then
  begin
    FUseAdvColors := Value;
    ParentColor := Value;
    CalcAdvColors;
    Invalidate;
  end;
end;

procedure TFlatProgressBar.CMSysColorChange (var Message: TMessage);
begin
  if FUseAdvColors then
  begin
    ParentColor := True;
    CalcAdvColors;
  end;
  Invalidate;
end;

procedure TFlatProgressBar.CMParentColorChanged (var Message: TWMNoParams);
begin
  inherited;
  if FUseAdvColors then
  begin
    ParentColor := True;
    CalcAdvColors;
  end;
  Invalidate;
end;

procedure TFlatProgressBar.SetSmooth(Value: Boolean);
begin
  if Value <> FSmooth then
  begin
    FSmooth := Value;
    Invalidate;
  end;
end;

procedure TFlatProgressBar.SetTransparent(const Value: Boolean);
begin
  FTransparent := Value;
  Invalidate;
end;

{$IFDEF DFS_COMPILER_4_UP}
procedure TFlatProgressBar.SetBiDiMode(Value: TBiDiMode);
begin
  inherited;
  Invalidate;
end;
{$ENDIF}

procedure TFlatProgressBar.CheckBounds;
var
  maxboxes: Word;
begin
  if FOrientation = pbHorizontal then
  begin
    maxboxes := (Width - 3) div (FElementWidth + 1);
    if Width < 12 then
      Width := 12
    else
      Width := maxboxes * (FElementWidth + 1) + 3;
  end
  else
  begin
    maxboxes := (Height - 3) div (FElementWidth + 1);
    if Height < 12 then
      Height := 12
    else
      Height := maxboxes * (FElementWidth + 1) + 3;
  end;
end;

procedure TFlatProgressBar.Paint;
var
  PaintRect: TRect;
begin
  if not Smooth then
    CheckBounds;
  PaintRect := ClientRect;
  
  // Background
  if not FTransparent then begin
    canvas.Brush.Color := Self.Color;
    canvas.Brush.Style := bsSolid;
    canvas.FillRect(PaintRect);
  end;

  // Border
  canvas.Brush.Color := FBorderColor;
  Canvas.FrameRect(PaintRect);

  // Elements
  DrawElements;
end;

procedure TFlatProgressBar.DrawElements;
var
  NumElements, NumToPaint: LongInt;
  Painted: Byte;
  ElementRect: TRect;
begin
  with canvas do
  begin
    if not Smooth then begin
      if FOrientation = pbHorizontal then
      begin
        NumElements := Trunc((ClientWidth - 3) div (FElementWidth + 1));
        NumToPaint := Trunc((FPosition - FMin) / ((FMax - FMin) / NumElements) + 0.00000001);

        if NumToPaint > NumElements then
          NumToPaint := NumElements;

        {$IFDEF DFS_COMPILER_4_UP}
        if BidiMode = bdRightToLeft then
          ElementRect := Rect(ClientRect.Right - 2 - FElementWidth, ClientRect.Top + 2, ClientRect.Right - 2, ClientRect.Bottom - 2)
        else
          ElementRect := Rect(ClientRect.Left + 2, ClientRect.Top + 2, ClientRect.Left + 2 + FElementWidth, ClientRect.Bottom - 2);
        {$ELSE}
        ElementRect := Rect(ClientRect.Left + 2, ClientRect.Top + 2, ClientRect.Left + 2 + FElementWidth, ClientRect.Bottom - 2);
        {$ENDIF}

        if NumToPaint > 0 then
        begin
          Brush.Color := FElementColor;
          Brush.Style := bsSolid;
          for Painted := 1 to NumToPaint do
          begin
            Canvas.FillRect(ElementRect);
            {$IFDEF DFS_COMPILER_4_UP}
            if BidiMode = bdRightToLeft then
            begin
              ElementRect.Left := ElementRect.Left - FElementWidth - 1;
              ElementRect.Right := ElementRect.Right - FElementWidth - 1;
            end
            else
            begin
             ElementRect.Left := ElementRect.Left + FElementWidth + 1;
             ElementRect.Right := ElementRect.Right + FElementWidth + 1;
            end;
            {$ELSE}
            ElementRect.Left := ElementRect.Left + FElementWidth + 1;
            ElementRect.Right := ElementRect.Right + FElementWidth + 1;
            {$ENDIF}
          end;
        end;
      end
      else
      begin
        NumElements := Trunc((ClientHeight - 3) div (FElementWidth + 1));
        NumToPaint := Trunc((FPosition - FMin) / ((FMax - FMin) / NumElements) + 0.00000001);

        if NumToPaint > NumElements then
          NumToPaint := NumElements;
        ElementRect := Rect(ClientRect.Left + 2, ClientRect.Bottom - FElementWidth - 2, ClientRect.Right - 2, ClientRect.Bottom - 2);


        if NumToPaint > 0 then
        begin
          Brush.Color := FElementColor;
          Brush.Style := bsSolid;
          for Painted := 1 to NumToPaint do
          begin
            Canvas.FillRect(ElementRect);
            ElementRect.Top := ElementRect.Top - (FElementWidth + 1);
            ElementRect.Bottom := ElementRect.Bottom - (FElementWidth + 1);
          end;
        end;
      end;
    end
    else
    begin
      if (FOrientation = pbHorizontal) and (FPosition > 0) then
      begin
        Brush.Color := FElementColor;
        Canvas.FillRect(Rect(2, 2, ClientRect.Left + 2 + ((FPosition * (ClientWidth - 4)) div (FMax - FMin)), ClientRect.Bottom - 2));
      end
      else
      begin
        Brush.Color := FElementColor;
        Canvas.FillRect(Rect(2, ClientRect.Bottom - 2 - ((FPosition * (ClientHeight - 4)) div (FMax - FMin)), ClientRect.Right - 2, ClientRect.Bottom - 2));
      end;
    end;
  end;
end;
{ TFlatTitlebar }
constructor TFlatTitlebar.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 Width := 100;
 Height := 19;
 ControlStyle := ControlStyle + [csAcceptsControls];
 TitlebarColor := ecCaptionBackground;
 ActiveTextColor := ecActiveCaption;
 InactiveTextColor := ecInactiveCaption;
  if csDesigning in ComponentState then
   begin
    FActive := True;
   end;
end;

destructor TFlatTitlebar.Destroy;
begin
 inherited Destroy;
end;

procedure TFlatTitlebar.Loaded;
var
 Wnd: HWND;
begin
 inherited Loaded;
  if not (csDesigning in ComponentState) and (FForm <> nil) then
   begin
    if FForm <> nil then
     begin
      Wnd := FForm.Handle;
      FWndProcInstance := MakeObjectInstance(FormWndProc);
      FDefProc := SetWindowLong(Wnd,GWL_WNDPROC,LongInt(FWndProcInstance));
     end;
  end;
end;

procedure TFlatTitlebar.FormWndProc(var Message: TMessage);
begin
 case Message.Msg of
  WM_ACTIVATE: DoActivateMessage(TWMActivate(Message));
 end;
 Message.Result := CallWindowProc(Pointer(FDefProc),FForm.Handle,Message.Msg,Message.WParam, Message.LParam);
end;

procedure TFlatTitlebar.DoActivateMessage(var Message: TWMActivate);
begin
 case Message.Active of
  WA_ACTIVE: DoActivation;
  WA_CLICKACTIVE: DoActivation;
  WA_INACTIVE: DoDeactivation;
 end;
end;

procedure TFlatTitlebar.DoActivation;
begin
 FActive := True;
 Invalidate;
 if Assigned(FOnActivate) then FOnActivate(Self);
end;

procedure TFlatTitlebar.DoDeactivation;
begin
 FActive := False;
 Invalidate;
 if Assigned(FOnDeactivate) then FOnDeactivate(Self);
end;

procedure TFlatTitlebar.Paint;
var
 iCaptionWidth, iCaptionHeight, iX, iY: Integer;
begin
 with Canvas do
  begin
   with ClientRect do
    begin
     Canvas.Font.Assign(Self.Font);
      case FActive of
       True: Canvas.Font.Color := FActiveTextColor;
       False: Canvas.Font.Color := FInactiveTextColor;
      end;
     iCaptionWidth := TextWidth(Caption);
     iCaptionHeight := TextHeight(Caption);
     Brush.Color := TitlebarColor;
     FillRect(ClientRect);
     iX := Width div 2 - iCaptionWidth div 2;
     iY := Height div 2 - iCaptionHeight div 2;
     TextOut(iX,iY,Caption);
    end;
  end;
end;

procedure TFlatTitlebar.MouseMove;
begin
 if FDown then
  begin
   TCustomForm(Owner).Left := TCustomForm(Owner).Left + X - FOldX;
   TCustomForm(Owner).Top := TCustomForm(Owner).Top + Y - FOldY;
  end;
end;

procedure TFlatTitlebar.MouseUp;
begin
 FDown := False;
end;

procedure TFlatTitlebar.MouseDown;
begin
 if (Button = mbleft) and not FDown then FDown := True;
 FOldX := X;
 FOldy := Y;
end;

procedure TFlatTitlebar.SetActiveTextColor(Value: TColor);
begin
 if Value <> FActiveTextColor then
  begin
   FActiveTextColor := Value;
   Invalidate;
  end;
end;

procedure TFlatTitlebar.SetInactiveTextColor(Value: TColor);
begin
 if Value <> FInactiveTextColor then
  begin
   FInactiveTextColor := Value;
   Invalidate;
  end;
end;

procedure TFlatTitlebar.SetTitlebarColor(Value: TColor);
begin
 if Value <> FTitlebarColor then
  begin
   FTitlebarColor := Value;
   Invalidate;
  end;
end;

procedure TFlatTitlebar.SetParent(AParent: TWinControl);
begin
 if (AParent <> nil) and not(AParent is TCustomForm) then
  raise EInvalidOperation.Create(SParentForm);
 FForm := TCustomForm(AParent);
 inherited;
end;

procedure TFlatTitlebar.CMFontChanged (var Message: TMessage);
begin
 Invalidate;
end;

procedure TFlatTitlebar.CMTextChanged (var Message: TMessage);
begin
 Invalidate;
end;

{ TFlatScrollbarTrackThumb }

constructor TFlatScrollbarThumb.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

procedure TFlatScrollbarThumb.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  iTop: Integer;
begin
  if TFlatScrollbarTrack(Parent).Kind = sbVertical then
  begin
    FTopLimit := 0;
    FBottomLimit := TFlatScrollbarTrack(Parent).Height;
    if FDown = True then
    begin
      iTop := Top + Y - FOldY;
      if iTop < FTopLimit then
      begin
        iTop := FTopLimit;
      end;
      if (iTop > FBottomLimit) or ((iTop + Height) > FBottomLimit) then
      begin
        iTop := FBottomLimit - Height;
      end;
      Top := iTop;
    end;
  end
  else
  begin
    FTopLimit := 0;
    FBottomLimit := TFlatScrollbarTrack(Parent).Width;
    if FDown = True then
    begin
      iTop := Left + X - FOldX;
      if iTop < FTopLimit then
      begin
        iTop := FTopLimit;
      end;
      if (iTop > FBottomLimit) or ((iTop + Width) > FBottomLimit) then
      begin
        iTop := FBottomLimit - Width;
      end;
      Left := iTop;
    end;
  end;
  TFlatScrollbarTrack(Parent).FPosition := TFlatScrollbarTrack(Parent).PositionFromThumb;
  TFlatScrollbarTrack(Parent).DoPositionChange;
  inherited MouseMove(Shift,X,Y);
end;

procedure TFlatScrollbarThumb.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FDown := False;
  inherited MouseUp(Button,Shift,X,Y);
end;

procedure TFlatScrollbarThumb.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbleft) and not FDown then FDown := True;
  FOldX := X;
  FOldy := Y;
  inherited MouseDown(Button,Shift,X,Y);
end;

{ TFlatScrollbarTrack }

constructor TFlatScrollbarTrack.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);