DateTimePicker - immer eine Übersicht der Monate aufklappen

[NoGAD]

Ihr zwei seid Klasse!

Uwe, Deinen Code habe ich in meine abgeleitete Klasse des DateTimePickers gepackt und es funktioniert perfekt.


Hier mein TTRM_DateTimePicker als installierbare unit.

LG Mathias

Code:

unit TRM_DateTimePicker;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Controls,
  Forms,
  ComCtrls,
  Dialogs,
  ExtCtrls,
  CommCtrl;

type
  TTRM_DateTimePicker = class( TDateTimePicker )
    private
      { Private declarations }
      FOnMouseLeave : TNotifyEvent;
      FOnMouseEnter : TNotifyEvent;

      FExtraSpaceX : Integer;
      FExtraSpaceY : Integer;

      procedure CMMouseEnter( var msg : TMessage ); message CM_MOUSEENTER;
      procedure CMMouseLeave( var msg : TMessage ); message CM_MOUSELEAVE;

      procedure CNNotify( var Message : TWMNotify ); message CN_NOTIFY;
    protected
      { Protected declarations }
      procedure DoMouseEnter; dynamic;
      procedure DoMouseLeave; dynamic;
      procedure DoDropDown;
    public
      { Public declarations }
      Constructor Create( AOwner : tComponent ); Override;
      procedure ShowMonthCalendar;
    published
      { Published declarations }
      property OnMouseEnter : TNotifyEvent
        read FOnMouseEnter
        write FOnMouseEnter;
      property OnMouseLeave : TNotifyEvent
        read FOnMouseLeave
        write FOnMouseLeave;

      property WeekNumbers;
      property WeekExtraSpaceX : Integer
        Read FExtraSpaceX
        write FExtraSpaceX;
      property WeekExtraSpaceY : Integer
        Read FExtraSpaceY
        write FExtraSpaceY;

  end;

procedure Register;

implementation

procedure Register;
  begin
    RegisterComponents( 'TRM', [ TTRM_DateTimePicker ] );
  end;

{ TRM_DateTimePicker }

Constructor TTRM_DateTimePicker.Create( AOwner : tComponent );
  begin

    Inherited Create( AOwner );
    FExtraSpaceX := 12;
    FExtraSpaceY := 12;
    WeekNumbers := True;
    Self.Date := StrToDate( '15.06.1998' );

  end;

procedure TTRM_DateTimePicker.ShowMonthCalendar;
begin
  MonthCal_SetCurrentView(CalendarHandle, MCMV_YEAR);
end;

procedure TTRM_DateTimePicker.CMMouseEnter( var msg : TMessage );
  begin
    DoMouseEnter;
  end;

procedure TTRM_DateTimePicker.CMMouseLeave( var msg : TMessage );
  begin
    DoMouseLeave;
  end;

procedure TTRM_DateTimePicker.CNNotify( var Message : TWMNotify );
  begin
    if Message.NMHdr.code = DTN_DROPDOWN then
    begin
      if Self.WeekNumbers then
        DoDropDown;
    end;
    inherited;
  end;

procedure TTRM_DateTimePicker.DoMouseEnter;
  begin
    if Assigned( FOnMouseEnter ) then
      FOnMouseEnter( Self );
  end;

procedure TTRM_DateTimePicker.DoMouseLeave;
  begin
    if Assigned( FOnMouseLeave ) then
      FOnMouseLeave( Self );
  end;

procedure TTRM_DateTimePicker.DoDropDown;
  const
    MCM_GETMAXTODAYWIDTH = MCM_FIRST + 21;
  var
    Style : LongInt;
    hDTP : THandle;
    r : TRect;
    intTodayWidth : Integer;

    cname : array [ 0 .. 256 ] of Char;
  begin

    inherited;

    // to get a handle of calendar
    hDTP := DateTime_GetMonthCal( Self.Handle );

    // change a style
    Style := GetWindowLong( hDTP, GWL_STYLE );
    SetWindowLong( hDTP, GWL_STYLE, Style or MCS_WEEKNUMBERS );

    // now we must change the width for calendar because week numbers shifted all strings
    // 1. to get the required rect
    r := Rect( 0, 0, 0, 0 );
    SendMessage( hDTP, MCM_GETMINREQRECT, 0, LongInt( @r ) );

    // 2. to get the maximum width of the "today" string
    intTodayWidth := SendMessage( hDTP, MCM_GETMAXTODAYWIDTH, 0, 0 );

    // 3. adjust rect width to fit the "today" string
    if intTodayWidth > r.Right then
      r.Right := intTodayWidth;

    // For Win7, the window (class=SysMonthCal32) is automatically inside
    // a parent-window (class=DropDown). Check this. If so, take the parent window.
    // If not so (class=TMainForm), take this window (for XP and lower)
    GetClassName( GetParent( hDTP ), cname, sizeof( cname ) );
    if AnsiSameText( cname, 'DropDown' ) then
    begin
      hDTP := GetParent( hDTP );

      // To get it perfect (on my machines) is adding this code:
      inc( r.Right, WeekExtraSpaceX );
      inc( r.Bottom, WeekExtraSpaceY );
    end;

    // 4. to set new the height and width
    MoveWindow( hDTP, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, True );

  end;

end.