分享:可在 Free Pascal 編譯過的 win32 小時鐘

[yaurtusn ()]

// 這是小時鐘程式
// 用的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