[分享] 可在 Free Pascal 編譯過的 win32 小時鐘
// 這是小時鐘程式
// 用的compiler 為 FPC 2.6.4 程式庫為 win32
{
Copyright (c) 1996 by Charlie Calvert
Modifications by Florian Klaempfl
Hello world by Free Pascal
Modifications by yaurtusn
single cell by Free Pascal
Standard Windows API application written in Object Pascal.
No VCL code included. This is all done on the Windows API
level.
}
{$APPTYPE GUI}
{$MODE DELPHI}
//program WinHello;
program LittleClock;
uses sysutils,math, strings,strutils,
Windows;
const
AppName = 'Little Clock';
var logFont:TLOGFONT ;
hFont:thandle ;
hWindow: HWnd;
edt1:HWnd;
timera,time_hh,time_mm,time_ss:integer;
function WindowProc(Window: HWnd; AMessage: UINT; WParam : WPARAM;
LParam: LPARAM): LRESULT; stdcall; export;
var
dc : hdc;
ps : paintstruct;
r : rect;
p :ppoint;
lx,ly:integer;
sin_ly,cos_lx:extended;
pen:hpen;
str1:pchar;
begin
WindowProc := 0;
case AMessage of
wm_timer:
begin
str1:=pchar(datetostr(date())+' '+timetostr(time()));
setwindowtext(edt1,str1);
invalidaterect(edt1,nil,true);
invalidaterect(window,nil,true);
exit;
end;
wm_paint:
begin
time_hh:=strtoint(copy(timetostr(time()),1,2));
if time_hh>12 then time_hh:=time_hh-12;
time_mm:=strtoint(copy(timetostr(time()),4,2));
time_ss:=strtoint(copy(timetostr(time()),7,2));
p:=new(ppoint);
dc:=BeginPaint(Window,@ps);
GetClientRect(Window,@r);
hFont := CreateFontIndirect(&logFont);
SelectObject(dc,hFont);
textout(dc,5,r.bottom-18,'test',4);
pen:=createpen( PS_SOLID,13 ,rgb( 0 ,255,255));
SelectObject(dc,pen);
lx:=ceil((r.Right-r.left) div 2); ly:=ceil((r.bottom-r.top) div 2);
movetoex(dc,lx,ly,p);
sincos(degtorad(90+time_hh*30),sin_ly,cos_lx);
ly:=ly-ceil(ly * sin_ly);
lx:=ceil(r.Right div 2)-ceil(lx * cos_lx);
lineto(dc,lx,ly);
DeleteObject(pen);
pen:=createpen( PS_SOLID, 5 ,rgb( 0 ,0,255));
SelectObject(dc,pen);
lx:=ceil((r.Right-r.left) div 2); ly:=ceil((r.bottom-r.top) div 2);
movetoex(dc,lx,ly,p);
sincos(degtorad(90+time_mm*6),sin_ly,cos_lx);
ly:=ly-ceil(ly * sin_ly);
lx:=ceil(r.Right div 2)-ceil(lx * cos_lx);
lineto(dc,lx,ly);
DeleteObject(pen);
pen:=createpen( PS_SOLID, 1 ,rgb(255 ,0,0));
SelectObject(dc,pen);
lx:=ceil((r.Right-r.left) div 2); ly:=ceil((r.bottom-r.top) div 2);
movetoex(dc,lx,ly,p);
sincos(degtorad(90+time_ss*6),sin_ly,cos_lx);
ly:=ly-ceil(ly * sin_ly);
lx:=ceil(r.Right div 2)-ceil(lx * cos_lx);
lineto(dc,lx,ly);
DeleteObject(pen);
DeleteObject(hFont);
DeleteObject(pen);
EndPaint(Window,ps);
dispose(p);
Exit;
end;
wm_Destroy:
begin
killtimer(window,timera);
PostQuitMessage(0);
Exit;
end;
end;
WindowProc := DefWindowProc(Window, AMessage, WParam, LParam);
end;
{ Register the Window Class }
function WinRegister0: Boolean;
var
WindowClass: WndClass;
begin
WindowClass.Style := cs_hRedraw or cs_vRedraw;
WindowClass.lpfnWndProc := WndProc(@WindowProc);
WindowClass.cbClsExtra := 0;
WindowClass.cbWndExtra := 0;
WindowClass.hInstance := system.MainInstance;
WindowClass.hIcon := LoadIcon(0, idi_Application);
WindowClass.hCursor := LoadCursor(0, idc_Arrow);
WindowClass.hbrBackground := GetStockObject(WHITE_BRUSH);
WindowClass.lpszMenuName := nil;
WindowClass.lpszClassName := AppName;
Result := RegisterClass(WindowClass) <> 0;
end;
{ Create the Window Class }
function WinCreate: HWnd;
var
hWindow: HWnd;
str1:pchar;
begin
hWindow := CreateWindow(AppName, 'single cell windows program',
ws_OverlappedWindow, cw_UseDefault, cw_UseDefault,
cw_UseDefault, cw_UseDefault, 0, 0, system.MainInstance, nil);
str1:=pchar(datetostr(date())+' '+timetostr(time()));
edt1:= CreateWindow('edit', str1,
ws_child, 400, 200,
300, 30, hWindow,0, system.MainInstance, nil);
if hWindow <> 0 then begin
ShowWindow(hWindow, CmdShow);
ShowWindow(hWindow, SW_SHOW);
enablewindow(edt1,true);
UpdateWindow(hWindow);
end;
Result := hWindow;
end;
var
AMessage: Msg;
begin
if not WinRegister0 then begin
MessageBox(0, 'Register 0 failed', nil, mb_Ok);
Exit;
end;
hWindow := WinCreate;
timera:=2002;
settimer(hwindow,timera,1000,nil);
if longint(hWindow) = 0 then begin
MessageBox(0, 'WinCreate failed', nil, mb_Ok);
Exit;
end;
if edt1 <> 0 then
begin
ShowWindow(edt1, CmdShow);
UpdateWindow(edt1);
end
else
begin
MessageBox(0, 'edt Create failed', nil, mb_Ok);
exit
end;
while GetMessage(@AMessage, 0, 0, 0) do begin
TranslateMessage(AMessage);
DispatchMessage(AMessage);
end;
Halt(AMessage.wParam);
end.
--
※ 發信站: 批踢踢實業坊(ptt.cc), 來自: 211.21.123.66
※ 文章網址: https://www.ptt.cc/bbs/Programming/M.1446973761.A.36C.html
Programming 近期熱門文章
PTT數位生活區 即時熱門文章
