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 !
1 unit cdShowWkNos;
2
3 interface
4
5 uses
6 Classes, Forms, Controls, ComCtrls, Types, SysUtils;
7
8 type
9 TForm1 = class(TForm)
10 DTPicker1: TDateTimePicker;
11 procedure DTPicker1DropDown(Sender: TObject);
12 procedure FormCreate(Sender: TObject);
13 private
14 { Private declarations }
15 public
16 { Public declarations }
17 end;
18
19 { external declarations }
20 function GetWindowLong(hWnd: LongWord; nIndex: Integer): Longint; stdcall;
21 external 'user32.dll' name 'GetWindowLongA';
22 function SetWindowLong(hWnd: LongWord; nIndex: Integer; dwNewLong: Longint):
23 Longint; stdcall; external 'user32.dll' name 'SetWindowLongA';
24 function SendMessage(hWnd: LongWord; Msg: LongWord; wParam: LongInt; lParam:
25 LongInt): LongInt; stdcall; external 'user32.dll' name 'SendMessageA';
26 function SetWindowPos(hWnd: LongWord; hWndInsertAfter: LongWord; X, Y, cx, cy:
27 Integer; uFlags: LongWord): LongBool; stdcall; external 'user32.dll' name
28 'SetWindowPos';
29
30 const
31 { DateTime Picker, and MonthCalendar specific constants. }
32 { Requires comctl32.dll ver. 4.70 }
33 GWL_STYLE = (-16);
34 MCS_WEEKNUMBERS = $0004;
35 DTM_GETMONTHCAL = $1000 + 8;
36 MCM_GETMINREQRECT = $1000 + 9;
37 MCM_GETMAXTODAYWIDTH = $1000 + 21;
38 SWP_NOACTIVATE = $10;
39 SWP_NOZORDER = 4;
40 SWP_NOMOVE = 2;
41
42 var
43 Form1 : TForm1; // the main form
44 Style : LongInt; // style variable used for the calendar
45 hDTP : THandle; // handle variable of the form
46 r : TRect; // the Rect variable, used for the calendar
47 "canvas"
48 MaxTodayWidth: Integer; // length of the "Today" text at bottom of
49 calendar
50 Flags : Integer; // flags used in setting the new size of the
51 calendar
52
53 implementation
54
55 {$R *.dfm}
56
57 procedure TForm1.DTPicker1DropDown(Sender: TObject);
58 begin
59 Flags := SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOZORDER;
60
61 { get a handle of calendar}
62 hDTP := SendMessage(DTPicker1.Handle, DTM_GETMONTHCAL, 0, 0);
63
64 { change a style }
65 Style := GetWindowLong(hDTP, GWL_STYLE);
66 SetWindowLong(hDTP, GWL_STYLE, Style or MCS_WEEKNUMBERS);
67
68 { get the required rect }
69 r := Rect(0, 0, 0, 0);
70 SendMessage(hDTP, MCM_GETMINREQRECT, 0, Longint(@r));
71
72 { adjust rect width to fit the "today" string }
73 if SendMessage(hDTP, MCM_GETMAXTODAYWIDTH, 0, 0) > r.Right then
74 r.Right := SendMessage(hDTP, MCM_GETMAXTODAYWIDTH, 0, 0);
75
76 { set new the height and width of the calendar, to allow for week numbers moving }
77 SetWindowPos(hDTP, 0, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, Flags);
78 end;
79
80 procedure TForm1.FormCreate(Sender: TObject);
81 begin
82 { adjusts calendar, to show today's date - this is optional }
83 DTPicker1.Date := Date;
84 end;
85
86 end.
|
