Делаем свои часы в трее
Материал из DRKB
Делаем свои часы в трее[править | править код]
uses
windows, messages, ShellAPI;
const
ClassName = 'MyClockWndClass';
var
hTrayClock, Window: hWnd;
idTM: cardinal;
function SysDateToStr: string;
const
sDateFmt = 'dddd, d MMMM yyyy';
var
ST: TSystemTime;
begin
GetLocalTime(ST);
SetLength(Result, MAX_PATH);
GetDateFormat(LOCALE_USER_DEFAULT, 0, @ST, PChar(sDateFmt), @Result[1], MAX_PATH);
end;
function SysTimeToStr: string;
const
sTimeFmt = 'HH:mm';
var
ST: TSystemTime;
begin
GetLocalTime(ST);
SetLength(Result, 15);
GetTimeFormat(LOCALE_USER_DEFAULT, 0, @st, sTimeFmt, @Result[1], 15);
end;
procedure TimerProc(wnd: HWND; uMsg, idEvent, dwTime: UINT); stdcall;
begin
InvalidateRect(wnd, nil, True);
end;
procedure RecalcWndPos;
var
r: TRect;
X,Y: Integer;
begin
X := GetSystemMetrics(SM_CXDLGFRAME);
Y := GetSystemMetrics(SM_CYDLGFRAME);
GetWindowRect(hTrayClock, r);
SetWindowPos(Window, 0, r.Left+X, r.Top+Y, r.Right-r.Left, r.Bottom-r.Top-Y, 0);
end;
function AppWndProc(wnd: HWND; uMsg: DWORD; wParam: WPARAM; lParam: LPARAM): Longint; stdcall;
var
DC: HDC;
ps: TPaintStruct;
pt: TPoint;
r: TRect;
Cmd: LongBool;
hm: HMenu;
begin
Result := 0;
case uMsg of
WM_SETTINGCHANGE: if wParam=SPI_SETWORKAREA then RecalcWndPos;
WM_PAINT:
begin
DC := BeginPaint(wnd, ps);
GetClientRect(wnd, r);
SetBkMode(DC, TRANSPARENT);
SetTextColor(DC, RGB(255, 255, 0));
DrawText(DC, PChar(SysTimeToStr), -1, r, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
EndPaint(wnd, ps);
exit;
end;
WM_RBUTTONDOWN:
begin
hm := CreatePopupMenu;
pt.X := LOWORD(lParam);
pt.Y := HIWORD(lParam);
ClientToScreen(wnd, pt);
Insertmenu(hm, 0, MF_BYPOSITION or MF_STRING, $101, 'Exit');
Insertmenu(hm, 0, MF_BYPOSITION or MF_SEPARATOR, 0, nil);
Insertmenu(hm, 0, MF_BYPOSITION or MF_STRING, $102, 'Date/Time Settings');
Insertmenu(hm, 0, MF_BYPOSITION or MF_SEPARATOR, 0, nil);
Insertmenu(hm, 0, MF_BYPOSITION or MF_STRING, dword(-1), PChar(SysDateToStr));
SetMenuDefaultItem(hm, 0, 1);
Cmd := TrackPopupMenu(hM, TPM_LEFTALIGN or TPM_RIGHTBUTTON or TPM_RETURNCMD,
pt.X, pt.Y, 0, Window, nil);
case LongInt(Cmd) of
$101: SendMessage(wnd, wm_destroy, 0, 0);
$102: ShellExecute(0, nil, 'control.exe', 'date/time', nil, SW_SHOW);
end;
DestroyMenu(hm);
end;
WM_DESTROY:
begin
PostQuitMessage(wparam);
KillTimer(wnd, idTM);
end
end;
Result := DefWindowProc(wnd, uMsg, wParam, lParam);
end;
procedure InitInstance;
var
AppWinClass: TWndClass;
begin
with AppWinClass do
begin
style := CS_VREDRAW or CS_HREDRAW;
lpfnWndProc := @AppWndProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := hInstance;
hIcon := LoadIcon(0, IDI_APPLICATION);
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := GetStockObject(BLACK_BRUSH);
lpszMenuName := nil;
lpszClassName := ClassName;
end;
if RegisterClass(AppWinClass) = 0 then Halt(1);
end;
procedure InitApplication;
begin
hTrayClock := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil);
Window := CreateWindow(ClassName, nil, WS_POPUP or WS_DLGFRAME, 0, 0, 0, 0, hTrayClock, 0, HInstance, nil);
if Window = 0 then halt(1);
RecalcWndPos;
end;
procedure InitWindow;
begin
idTM := SetTimer(Window, 1, 1000, @TimerProc);
ShowWindow(Window, SW_SHOWNORMAL);
UpdateWindow(Window);
InvalidateRect(Window, nil, True)
end;
procedure MsgLoop;
var
Message: TMsg;
begin
while GetMessage(Message, 0, 0, 0) do
begin
TranslateMessage(Message);
DispatchMessage(Message);
end;
Halt(Message.wParam)
end;
begin
InitInstance;
InitApplication;
InitWindow;
MsgLoop
end.
но правильнее было бы внедриться в Explorer и сабклассировать TrayClockWClass
Author: Krid
Source: Взято из http://forum.sources.ru
ID: 01766