Mega Code Archive
How to show week numbers in a tdatetimepicker
<![CDATA[
Ever wanted to know how to get week numbers to show on a TDateTimePicker component ?
I had originally found an excerpt of code, which I wanted to try out, but was in VB - I thought I would translate it, and use ideas from other excerpts of code I had found. It took a few days to get working, as I was getting some freaky results, until I came up with the following result.
Start a new project, drop a TDateTimePicker component onto the form, and change it's Name property to DTPicker1. (You can use any name you wish, but change the code accordingly). Add the code below, site back and enjoy !
unit cdShowWkNos;
interface
uses
Classes, Forms, Controls, ComCtrls, Types, SysUtils;
type
TForm1 = class(TForm)
DTPicker1: TDateTimePicker;
procedure DTPicker1DropDown(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
{ external declarations }
function GetWindowLong(hWnd: LongWord; nIndex: Integer): Longint; stdcall; external 'user32.dll' name 'GetWindowLongA';
function SetWindowLong(hWnd: LongWord; nIndex: Integer; dwNewLong: Longint): Longint; stdcall; external 'user32.dll' name 'SetWindowLongA';
function SendMessage(hWnd: LongWord; Msg: LongWord; wParam: LongInt; lParam: LongInt): LongInt; stdcall; external 'user32.dll' name 'SendMessageA';
function SetWindowPos(hWnd: LongWord; hWndInsertAfter: LongWord; X, Y, cx, cy: Integer; uFlags: LongWord): LongBool; stdcall; external 'user32.dll' name 'SetWindowPos';
const
{ DateTime Picker, and MonthCalendar specific constants. }
{ Requires comctl32.dll ver. 4.70 }
GWL_STYLE = (-16);
MCS_WEEKNUMBERS = $0004;
DTM_GETMONTHCAL = $1000 + 8;
MCM_GETMINREQRECT = $1000 + 9;
MCM_GETMAXTODAYWIDTH = $1000 + 21;
SWP_NOACTIVATE = $10;
SWP_NOZORDER = 4;
SWP_NOMOVE = 2;
var
Form1 : TForm1; // the main form
Style : LongInt; // style variable used for the calendar
hDTP : THandle; // handle variable of the form
r : TRect; // the Rect variable, used for the calendar "canvas"
MaxTodayWidth: Integer; // length of the "Today" text at bottom of calendar
Flags : Integer; // flags used in setting the new size of the calendar
implementation
{$R *.dfm}
procedure TForm1.DTPicker1DropDown(Sender: TObject);
begin
Flags := SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOZORDER;
{ get a handle of calendar}
hDTP := SendMessage(DTPicker1.Handle, DTM_GETMONTHCAL, 0, 0);
{ change a style }
Style := GetWindowLong(hDTP, GWL_STYLE);
SetWindowLong(hDTP, GWL_STYLE, Style or MCS_WEEKNUMBERS);
{ get the required rect }
r := Rect(0, 0, 0, 0);
SendMessage(hDTP, MCM_GETMINREQRECT, 0, Longint(@r));
{ adjust rect width to fit the "today" string }
if SendMessage(hDTP, MCM_GETMAXTODAYWIDTH, 0, 0) > r.Right then
r.Right := SendMessage(hDTP, MCM_GETMAXTODAYWIDTH, 0, 0);
{ set new the height and width of the calendar, to allow for week numbers moving }
SetWindowPos(hDTP, 0, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, Flags);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ adjusts calendar, to show today's date - this is optional }
DTPicker1.Date := Date;
end;
end.
]]>