Clock on Windows Console

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Clock on Windows Console

Post by dodicat »

Settles to 1% CPU usage.
Tested 32/64/gas64

Code: Select all

#include "windows.bi"
#include "vbcompat.bi"
#include "crt.bi"
Const xres=800
Const yres=600

Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
    SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style)) 
End Sub

Sub setfontcolours(h As hdc,text As Ulong,background As Ulong=0)
    SetTextColor(h,text) 
    SetBkColor(h,background)
End Sub

Sub text(h As hdc,x As Long,y As Long,s As String)
    Var l=Len(s)
    textouta(h,x,y,s,L)
End Sub

Sub ClearScreen(h As hdc,colour As Ulong)
    SetDCBrushColor(h,colour)
    SetDCPenColor(h,colour)
    rectangle(h,0,0,xres,yres)
End Sub

Sub hidecursor()
    Dim As handle consoleHandle
    Dim As CONSOLE_CURSOR_INFO info
    consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
    info.dwSize = 100
    info.bVisible = FALSE 
    SetConsoleCursorInfo(consoleHandle, @info)
End Sub

Sub circles(Memhdc As hdc,numballs As Long,OutsideRadius As Long,cx As Long,cy As Long,c As Ulong,n As Long,md As Long)
    Dim As Double r,bigr,num,x,y,k=OutsideRadius', pi=4*Atn(1)
    Const  pi=4*Atn(1)
    #define rad *pi/180  
    Dim As Long counter
    num= (45*(2*numballs-4)/numballs) rad
    num=Cos(num)
    r=num/(1+num)
    bigr=((1-r))*k  'radius to ring ball centres
    r=(r)*k         'radius of ring balls
    For z As Double=0 -pi/2 To 2*pi -pi/2 Step 2*pi/numballs
        counter+=1
        x=cx+bigr*Cos(z)
        y=cy+bigr*Sin(z)
        If counter>numballs Or counter>n+1  Then Exit For
        If (counter-1) Mod md=0 Then 
            SetDCBrushColor(Memhdc,bgr(150,50,200))
            SetDCPenColor(Memhdc,bgr(200,0,50))
        Else
            SetDCBrushColor(Memhdc,c)
            SetDCPenColor(Memhdc,bgr(200,0,50))
        End If
        ellipse(Memhdc,(x-r),(y-r),(x+r),(y+r))
        Var g=Right("0"+Str(counter-1),2)
        Var l=Len(Str((counter-1)))
        If counter>n Then
            Var h=Iif(Hour(Now)=12,12,counter-1)
            If md<>3 Then 
                text(Memhdc,x-8,y-10,g)
            Else
                text(Memhdc,x-4*Len(Str(h))*l,y-10,Str(h))
            End If
        End If
    Next z
End Sub

Function F(t As Long,Byref z As Long=0) As Long
    t=t Mod 12
    If t=12 Then t=1
    z=t
    If  z < 12 Then Return 12 Else Return 1   
End Function


Dim As hdc Memhdc,WorkingScreen
Dim As HBITMAP Membitmap
Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, 810, 640,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
Memhdc = CreateCompatibleDC(WorkingScreen)
Membitmap = CreateCompatibleBitmap(WorkingScreen, xres, yres)

SelectObject(Memhdc, Membitmap)
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))

'some console instructions
Var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND)    'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND)    'non resizable console
hidecursor()
SetBkMode (Memhdc, TRANSPARENT)
ShowScrollBar(p, SB_BOTH, FALSE)

setfontsize(Memhdc,20,"consolas")
setfontcolours(Memhdc,bgr(0,0,0))
Dim As Long z,lst,s
While true
    '======  using crt ========
    Dim As time_t  rawtime
    Dim As tm Ptr timeinfo
    time_(@rawtime)
    timeinfo = localtime( @rawtime )
    Var dt=Rtrim(*asctime(timeinfo),Chr(10)) 
    '=================  
    s=Second(Now)
    If lst<>s Then
        clearscreen(Memhdc,bgr(0,200,0))
        SetDCBrushColor(Memhdc,bgr(180,200,225))
        SetDCPenColor(Memhdc,bgr(0,200,0))
        ellipse(Memhdc,400-300,300-300,400+300,300+300)
        circles(Memhdc,60,290,400,300,bgr(255,150,0),Second(Now),5)
        circles(Memhdc,60,250,400,300,bgr(250,250,250),Minute(Now),5)
        circles(Memhdc,F(Hour(Now),z),190,400,300,bgr(0,150,200),z,3)
        text(Memhdc,400-4.5*Len(dt),294,dt)
        text(Memhdc,10,570,"Press <escape> to finish")
        BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
    End If
    lst=s
    Sleep 100
    If GetAsyncKeyState(&h1B) Then ' escape key
        DeleteObject(Membitmap)
        DeleteDC    (Memhdc)
        GetSystemMenu(p,true)'reset console
        End
    End If
Wend
 
Last edited by dodicat on May 16, 2022 9:53, edited 1 time in total.
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Clock on Windows Console

Post by srvaldez »

nice dodicat :)
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Clock on Windows Console

Post by UEZ »

Nice idea and implementation.

Image
Post Reply