delphi – TDateTimePicker的样式属性

查看此示例App

unit Unit15;

interface

uses
  Winapi.Windows,Winapi.Messages,System.SysUtils,System.Variants,System.Classes,Vcl.Graphics,Vcl.Controls,Vcl.Forms,Vcl.Dialogs,Vcl.ImgList,Vcl.StdCtrls,Vcl.ComCtrls;

type
  TForm15 = class(TForm)
    DateTimePicker1: TDateTimePicker;
    procedure DateTimePicker1DropDown(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form15: TForm15;

implementation


{$R *.dfm}

uses
  Winapi.CommCtrl,Vcl.Styles,Vcl.Themes,uxTheme;

Procedure SetVclStylesColorsCalendar( DateTimePicker: TDateTimePicker);
Var
  LTextColor,LBackColor : TColor;
begin
   uxTheme.SetWindowTheme(DateTimePicker.Handle,'','');//disable themes in the calendar
   //get the vcl styles colors
   LTextColor:=StyleServices.GetSystemColor(clWindowText);
   LBackColor:=StyleServices.GetSystemColor(clWindow);

   DateTimePicker.Color:=LBackColor;
   //set the colors of the calendar
   DateTimePicker.CalColors.BackColor:=LBackColor;
   DateTimePicker.CalColors.MonthBackColor:=LBackColor;
   DateTimePicker.CalColors.TextColor:=LTextColor;
   DateTimePicker.CalColors.TitleBackColor:=LBackColor;
   DateTimePicker.CalColors.TitleTextColor:=LTextColor;
   DateTimePicker.CalColors.TrailingTextColor:=LTextColor;
end;


procedure TForm15.DateTimePicker1DropDown(Sender: TObject);
var
  hwnd: WinAPi.Windows.HWND;
begin
  hwnd := SendMessage(TDateTimePicker(Sender).Handle,DTM_GETMONTHCAL,0);
  uxTheme.SetWindowTheme(hwnd,'');//disable themes in the drop down window
end;

procedure TForm15.FormCreate(Sender: TObject);
begin
  SetVclStylesColorsCalendar( DateTimePicker1);
end;

end.

更新1

更改TDateTimePicker的“组合框”的背景颜色是由Windows本身限制的任务,因为在其他因素之间

>此控件没有所有者绘制的容量,
>并且如果您尝试使用SetBkColor功能在此控件中没有效果,因为此控件不处理WM_CTLCOLOREDIT消息.

因此,一种可能的解决方案是拦截WM_PAINT和WM_ERASEBKGND消息,并编写自己的代码来绘制控件.使用Vcl样式时,可以使用Style挂钩来处理这些消息.

检查此代码(仅作为概念证明)

uses
  Winapi.Windows,Vcl.ComCtrls;

type
  TForm15 = class(TForm)
    DateTimePicker1: TDateTimePicker;
    DateTimePicker2: TDateTimePicker;
    procedure DateTimePicker1DropDown(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  end;


var
  Form15: TForm15;

implementation


{$R *.dfm}

uses
  Winapi.CommCtrl,Winapi.uxTheme;

type
 TDateTimePickerStyleHookFix= class(TDateTimePickerStyleHook)
 private
    procedure WMPaint(var Message: TMessage); message WM_PAINT;
    procedure PaintBackground(Canvas: TCanvas); override;
 public
    constructor Create(AControl: TWinControl); override;
 end;

 TDateTimePickerStyleHookHelper = class helper for TDateTimePickerStyleHook
 public
    function GetButtonRect_: TRect;
 end;


Procedure SetVclStylesColorsCalendar( DateTimePicker: TDateTimePicker);
Var
  LTextColor,LBackColor : TColor;
begin
   Winapi.uxTheme.SetWindowTheme(DateTimePicker.Handle,0);
  Winapi.uxTheme.SetWindowTheme(hwnd,'');//disable themes in the drop down window
end;

procedure TForm15.FormCreate(Sender: TObject);
begin
  //set the colors for the TDateTimePicker
  SetVclStylesColorsCalendar( DateTimePicker1);
  SetVclStylesColorsCalendar( DateTimePicker2);
end;


{ TDateTimePickerStyleHookHelper }
function TDateTimePickerStyleHookHelper.GetButtonRect_: TRect;
begin
 Result:=Self.GetButtonRect;
end;

{ TDateTimePickerStyleHookFix }
constructor TDateTimePickerStyleHookFix.Create(AControl: TWinControl);
begin
  inherited;
  OverrideEraseBkgnd:=True;//this indicates which this style hook will call the PaintBackground method when the WM_ERASEBKGND message is sent.
end;

procedure TDateTimePickerStyleHookFix.PaintBackground(Canvas: TCanvas);
begin
  //use the proper style color to paint the background
  Canvas.Brush.Color := StyleServices.GetStyleColor(scEdit);
  Canvas.FillRect(Control.ClientRect);
end;

procedure TDateTimePickerStyleHookFix.WMPaint(var Message: TMessage);
var
  DC: HDC;
  LCanvas: TCanvas;
  LPaintStruct: TPaintStruct;
  LRect: TRect;
  LDetails: TThemedElementDetails;
  sDateTime  : string;
begin
  DC := Message.WParam;
  LCanvas := TCanvas.Create;
  try
    if DC <> 0 then
      LCanvas.Handle := DC
    else
      LCanvas.Handle := BeginPaint(Control.Handle,LPaintStruct);
    if TStyleManager.SystemStyle.Enabled then
    begin
      PaintNC(LCanvas);
      Paint(LCanvas);
    end;
    if DateMode = dmUpDown then
      LRect := Rect(2,2,Control.Width - 2,Control.Height - 2)
    else
      LRect := Rect(2,GetButtonRect_.Left,Control.Height - 2);
    if ShowCheckBox then LRect.Left := LRect.Height + 2;
    IntersectClipRect(LCanvas.Handle,LRect.Left,LRect.Top,LRect.Right,LRect.Bottom);
    Message.wParam := WPARAM(LCanvas.Handle);

    //only works for DateFormat = dfShort
    case TDateTimePicker(Control).Kind of
     dtkDate : sDateTime:=DateToStr(TDateTimePicker(Control).DateTime);
     dtkTime : sDateTime:=TimeToStr(TDateTimePicker(Control).DateTime);
    end;

    //draw the current date/time value
    LDetails := StyleServices.GetElementDetails(teEditTextNormal);
    DrawControlText(LCanvas,LDetails,sDateTime,LRect,DT_VCENTER or DT_LEFT);

    if not TStyleManager.SystemStyle.Enabled then
      Paint(LCanvas);
    Message.WParam := DC;
    if DC = 0 then
      EndPaint(Control.Handle,LPaintStruct);
  finally
    LCanvas.Handle := 0;
    LCanvas.Free;
  end;
  Handled := True;
end;


initialization
  TStyleManager.Engine.RegisterStyleHook(TDateTimePicker,TDateTimePickerStyleHookFix);

end.

注意：此样式挂钩不会在TDateTimePicker的内部文本控件(组合框)中绘制聚焦(选定)元素,我让这个任务给你.

更新2

我刚刚编写了一个vcl样式钩子,它包含了将vcl样式正确应用于TDateTimePicker组件的所有逻辑,而不使用OnDropDown事件或表单的OnCreate事件.你可以找到vcl样式钩子here(作为vcl styles utils项目的一部分)

要使用它,您必须将Vcl.Styles.DateTimePickers单元添加到项目中并以这种方式注册钩子.

TStyleManager.Engine.RegisterStyleHook(TDateTimePicker,TDateTimePickerStyleHookFix);