Word Clock

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
SARG
Posts: 1679
Joined: May 27, 2005 7:15
Location: FRANCE

Re: Word Clock

Post by SARG »

@srvaldez
With redim data is not kept, needs static (or redim shared).

Using 'Static As d2 XY(any,any)' the program works, however with some warnings when compiling.

I guess there is a problem somewhere.
dodicat
Posts: 7919
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Word Clock

Post by dodicat »

If I put the type d2 outside the sub, and let the type d2 further down just be this d2 then it is OK.
I think there was some work done recently with udt's inside subs
It works with 1.08.1 in the original state.
Thanks for testing.
Sorry for straying off topic.
Five Deck Maverick seems not on the same page as clocks.
neil
Posts: 338
Joined: Mar 17, 2022 23:26

Re: Word Clock

Post by neil »

Here's a very nice analog clock I found made with cairo graphics.
It must be swiss made.

Code: Select all

#include once "cairo/cairo.bi" 
#define _rd_ Cast(Ubyte Ptr,@colour)[2]/255
#define _gr_ Cast(Ubyte Ptr,@colour)[1]/255
#define _bl_ Cast(Ubyte Ptr,@colour)[0]/255
#define _al_ Cast(Ubyte Ptr,@colour)[3]/255

Dim Shared As cairo_font_extents_t _fonts  
Dim Shared As cairo_text_extents_t _text
Const pi=4*Atn(1)

Sub InitFonts(surf As cairo_t Ptr,fonttype As String="times new roman")
    If Len(fonttype) Then
        cairo_select_font_face (surf,fonttype, CAIRO_FONT_SLANT_NORMAL, CAIRO_FONT_WEIGHT_BOLD)
    End If
    cairo_font_extents (surf, @_fonts)
End Sub

Sub Cprint(surf As cairo_t Ptr,x As Long,y As Long,text As String,size As Single,colour As Ulong)
    cairo_set_font_size (surf,(size))
    cairo_move_to (surf, _ '                 lower left corner of text
    (x) - (_text.width / 2 + _text.x_bearing), _
    (y) + (_text.height / 2) - _fonts.descent)
    cairo_set_source_rgba surf,_rd_,_gr_,_bl_,_al_
    cairo_show_text(surf, text)
    cairo_stroke(surf)
End Sub
'rectangle unused
Sub Crectangle(surf As cairo_t Ptr,x As Long,y As Long,wide As Long,high As Long,thickness As Single,colour As Ulong)
    cairo_set_line_width(surf, (thickness))
    cairo_set_source_rgba surf,_rd_,_gr_,_bl_,_al_
    cairo_move_to(surf, (x), (y))
    cairo_rectangle(surf,(x),(y),(wide),(high))
    cairo_stroke(surf)
End Sub

Sub Ccircle(surf As cairo_t Ptr,cx As Long,cy As Long,radius As Long,start As Single,finish As Single,thickness As Single,colour As Ulong,Capoption As boolean)
    cairo_set_line_width(surf,(thickness))
    cairo_set_source_rgba surf,_rd_,_gr_,_bl_,_al_
    cairo_arc(surf,(cx),(cy),(radius),(start),(finish))
    If Capoption Then 
        cairo_set_line_cap(surf,CAIRO_LINE_CAP_ROUND)
    Else
        cairo_set_line_cap(surf,CAIRO_LINE_CAP_SQUARE)
    End If
    cairo_stroke(surf)
End Sub

Sub Cline(surf As cairo_t Ptr,x1 As Long,y1 As Long,x2 As Long,y2 As Long,thickness As Single,colour As Ulong,CapOption As boolean)
    cairo_set_line_width(surf, (thickness))
    cairo_set_source_rgba surf,_rd_,_gr_,_bl_,_al_
    cairo_move_to(surf, (x1), (y1))
    cairo_line_to(surf,(x2),(y2))
    If Capoption Then 
        cairo_set_line_cap(surf,CAIRO_LINE_CAP_ROUND)
    Else
        cairo_set_line_cap(surf,CAIRO_LINE_CAP_SQUARE)
    End If
    cairo_stroke(surf)
End Sub

Sub SetBackgroundColour(c As cairo_t Ptr,colour As Ulong)
    cairo_set_source_rgba c,_rd_,_gr_,_bl_,_al_
    cairo_paint(c)
End Sub

Function setscreen(xres As Integer,yres As Integer)  As cairo_t Ptr
    Screenres xres,yres,32
    Var surface = cairo_image_surface_create_for_data(Screenptr(), CAIRO_FORMAT_ARGB32,xres,yres,xres*4)
    Static As cairo_t Ptr res
    res= cairo_create(surface)
    Return res
End Function

Sub lineto(C As cairo_t Ptr,x1 As Long,y1 As Long,x2 As Long,y2 As Long,L As Single,t As Single,colour As Ulong)
    Dim As Long ox,oy
    Var dx=x2-x1,dy=y2-y1
    Var d=Sqr(dx*dx + dy*dy)
    ox=x1+L*dx/d:oy=y1+L*dy/d
    cline(C,x1,y1,ox,oy,t,colour,false)
End Sub

Sub drawline(C As cairo_t Ptr,x As Long,y As Long,angle As Single,length As Long,t As Single,colour As Ulong,Byref x2 As Long=0,Byref y2 As Long=0)
    angle=angle*.0174532925199433  '=4*atn(1)/180
    x2=x+length*Cos(angle)
    y2=y-length*Sin(angle)
    cline(C,x,y,x2,y2,t,colour,true)
End Sub

Sub dial(C As cairo_t Ptr)
    Dim As Long ctr,L  
    For z As Single=0 To 8*Atn(1)-.1 Step 8*Atn(1)/12
        ctr+=1
        L=Iif(Len(Str(ctr Mod 13))=2,8*2,0)
        cprint(C,400-L+230*Cos(z-2*Atn(1)*(2/3)),8+300+230*Sin(z-2*Atn(1)*(2/3)),Str(ctr Mod 13),40,Rgba(200,0,0,255))
    Next z
    ctr=0
    For z As Single=0 To 8*Atn(1)-.1 Step 8*Atn(1)/60
        lineto(C,410+200*Cos(z),300-10+200*Sin(z),400,300,10,2,Rgba(200,0,200,255))
        If ctr Mod 5=0 Then
            CCircle(C,410+200*Cos(z),300-10+200*Sin(z),3,0,2*pi,2,Rgba(0,200,0,255),false)
            lineto(C,410+200*Cos(z),300-10+200*Sin(z),400,300,20,2,Rgba(200,100,0,255))
        End If
        ctr+=1
    Next z
End Sub

Function start As Long
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c) 
    Dim  As  cairo_t Ptr C
    C=setscreen(800,600)
    Dim As String t,lt,s,m,h
    Dim As Single sa,ma,ha
    Dim As Double offset
    Do
        Screenlock
        Var t=Time 
        SetBackgroundColour(C,Rgba(0,50,50,255))
        InitFonts(C,"comic sans MS")
        dial(C)
        initfonts(C) 'default times new roman 
        cprint(C,375,200,"Smiths",25,Rgba(200,200,200,255))
        s=Mid(t,7,2):m=Mid(t,4,2):h=Mid(t,1,2)
        If lt<>t Then offset=Timer
        sa=map(0,60,(Vallng(s)+(Timer)-offset),360,0):ma=map(0,60,(Val(m)+Val(s)/60),360,0):ha=map(0,12,(Vallng(h)+Val(m)/60),360,0)
        drawline(C,410,300-10,ha+90,100,9,Rgba(0,200,0,255))
        drawline(C,410,300-10,ma+90,185,5,Rgba(0,200,200,255))
        drawline(C,410,300-10,sa+90,199,2,Rgba(200,200,0,255))
        drawline(C,410,300-10,sa+90+180,15,4,Rgba(200,200,0,255))
        lt=t
        Screenunlock
        Sleep 10,1
    Loop Until Len(Inkey)
    Return 0
End Function

End start
Sleep
fxm
Moderator
Posts: 11925
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Word Clock

Post by fxm »

dodicat wrote: May 30, 2023 20:00 If I put the type d2 outside the sub, and let the type d2 further down just be this d2 then it is OK.
I think there was some work done recently with udt's inside subs
It works with 1.08.1 in the original state.
Thanks for testing.
Sorry for straying off topic.
Five Deck Maverick seems not on the same page as clocks.

Jeff opened a bug report:
#982 Array descriptors emitted incorrectly in gcc backend
dodicat
Posts: 7919
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Word Clock

Post by dodicat »

neil wrote: May 31, 2023 5:55 Here's a very nice analog clock I found made with cairo graphics.
It must be swiss made.
I agree, very nice clock:
viewtopic.php?p=261788&hilit=dial#p261788
Not to blow my own trumpet of course.
But Smiths clocks are British made.
https://en.wikipedia.org/wiki/Smiths_Group
Cairo dll's
https://github.com/preshing/cairo-windows/releases
(Member srvaldez found these, only one dll needed to run cairo)
PS.
Thanks for the bug report fxm
UEZ
Posts: 919
Joined: May 05, 2017 19:59
Location: Germany

Re: Word Clock

Post by UEZ »

dodicat wrote: May 31, 2023 8:30
neil wrote: May 31, 2023 5:55 Here's a very nice analog clock I found made with cairo graphics.
It must be swiss made.
Indeed, very nice smooth anti-aliased clock.

Apropos Swiss made - here my Swiss clock: GDI+ Swiss Railway Clock v1.27 build 2019-07-04 [Windows only!]
neil
Posts: 338
Joined: Mar 17, 2022 23:26

Re: Word Clock

Post by neil »

@UEZ
Nice railway clock.
Why is it only for Windows?
UEZ
Posts: 919
Joined: May 05, 2017 19:59
Location: Germany

Re: Word Clock

Post by UEZ »

neil wrote: May 31, 2023 20:15 @UEZ
Nice railway clock.
Why is it only for Windows?
Thanks. :)
The reason for this is that the clock is drawn using the Windows API. The Windows API has a huge repertoire of graphical functions. :)
neil
Posts: 338
Joined: Mar 17, 2022 23:26

Re: Word Clock

Post by neil »

Here's an idea I had for a digital clock. Instead of just numbers maybe some some type of sliding bars with numbers.
Here's a demo with just numbers no fancy graphics with sliding bars. This is just a counter. It counts from 0 to 59.

Code: Select all

Screenres 180,400

Dim As UByte y1,y2,i,n,cnt,n2
y1 = 23:y2 = 23

Do
for i = 1 to 10

Locate 23,7:print ">":locate 23,13:print "<"
Color 15

Locate y1,11:PRINT "0"
Locate y1 + 2,11:PRINT "1"
Locate y1 + 4,11:PRINT "2"
Locate y1 + 6,11:PRINT "3"
Locate y1 + 8,11:PRINT "4"
Locate y1 + 10,11:PRINT "5"
Locate y1 + 12,11:PRINT "6"
Locate y1 + 14,11:PRINT "7"
Locate y1 + 16,11:PRINT "8"
Locate y1 + 18,11:PRINT "9"

y1 -= 2

Locate y2,9:PRINT "0"
Locate y2 + 2,9:PRINT "1"
Locate y2 + 4,9:PRINT "2"
Locate y2 + 6,9:PRINT "3"
Locate y2 + 8,9:PRINT "4"
Locate y2 + 10,9:PRINT "5"

sleep 1000,1
if i < 10 Then cls
if Multikey(&H01) Then exit do
next

y1 = 3
for i = 1 to 10
Locate 23,7:print ">":locate 23,13:print "<"
Color 15
Locate y1,11:PRINT "0"
Locate y1 + 2,11:PRINT "1"
Locate y1 + 4,11:PRINT "2"
Locate y1 + 6,11:PRINT "3"
Locate y1 + 8,11:PRINT "4"
Locate y1 + 10,11:PRINT "5"
Locate y1 + 12,11:PRINT "6"
Locate y1 + 14,11:PRINT "7"
Locate y1 + 16,11:PRINT "8"
Locate y1 + 18,11:PRINT "9"
y1 += 2
if i = 10 Then cls

sleep 10,1
if i = 10 Then y2 -= 2:cnt += 1
if cnt = 6 Then
y2 = 11
for n2 = 1 to 6
Locate y2,9:PRINT "0"
Locate y2 + 2,9:PRINT "1"
Locate y2 + 4,9:PRINT "2"
Locate y2 + 6,9:PRINT "3"
Locate y2 + 8,9:PRINT "4"
Locate y2 + 10,9:PRINT "5"
y2 += 2
sleep 10,1
cls
next
cnt = 0
End If

next
Loop
sleep
Last edited by neil on Jun 01, 2023 22:57, edited 1 time in total.
neil
Posts: 338
Joined: Mar 17, 2022 23:26

Re: Word Clock

Post by neil »

As a 24 hour clock it could be something like this.

Code: Select all

  Hrs      Min       Sec
> 0 0 <  > 0 0 <   > 0 0 <
  1 1      1 1       1 1
  2 2      2 2       2 2
    3      3 3       3 3
    4      4 4       4 4
    5      5 5       5 5
    6        6         6
    7        7         7
    8        8         8
    9        9         9
neil
Posts: 338
Joined: Mar 17, 2022 23:26

Re: Word Clock

Post by neil »

Something like this could be done by a FreeBasic graphics programmer.
Time Twister https://www.youtube.com/watch?v=4hC9oUYxssE
neil
Posts: 338
Joined: Mar 17, 2022 23:26

Re: Word Clock

Post by neil »

My 15 segment digital clock display.

Code: Select all

Screenres 360,120,32
Dim Shared As Any Ptr Box
Box = ImageCreate (20, 20, RGB(0, 0, 0))
Dim shared as UShort x,y
Dim As string t,hr1,hr2,mn1,mn2,sc1,sc2,key
Dim As UByte hrs1,hrs2,min1,min2,sec1,sec2
line Box,(10,10)-(20,20),rgb(0,255,0),bf
y = 20

Sub Zero()
Put (x,y),Box
put (x,y + 12),Box
put (x,y + 24),Box
put (x,y + 36),Box
put (x,y + 48),Box
put (x + 12,y),Box
put (x + 24,y),Box
put (x + 24, y + 12),Box
put (x + 24, y + 24),Box
put (x + 24, y + 36),Box
put (x + 24, y + 48),Box
put (x + 12,y + 48),Box
End Sub

Sub One()
Put (x + 24,y),Box
put (x + 24,y + 12),Box
put (x + 24,y + 24),Box
put (x + 24,y + 36),Box
put (x + 24,y + 48),Box
End Sub

Sub Two()
put (x,y),Box
put (x + 12,y),Box
put (x + 24, y),Box
put (x + 24, y + 12),Box
put (x + 24, y + 24),Box
put (x, y + 24),Box
put (x + 12,y + 24),Box
put (x,y + 36),Box
put (x,y + 48),Box
put (x + 12,y + 48),Box
put (x + 24,y + 48),Box
End Sub

Sub Three()
put (x,y),Box
put (x + 12,y),Box
put (x + 24, y),Box
put (x + 24, y + 12),Box
put (x + 24, y + 24),Box
put (x, y + 24),Box
put (x + 12,y + 24),Box
put (x + 24 ,y + 36),Box
put (x + 24,y + 48),Box
put ( x,y + 48),Box
put (x + 12,y + 48),Box
End Sub

Sub Four()
put (x,y),Box
put (x + 24, y),Box
put (x + 24, y + 12),Box
put (x,y + 12),Box
put (x + 24, y + 24),Box
put (x, y + 24),Box
put (x + 12,y + 24),Box
put (x + 24 ,y + 36),Box
put (x + 24 ,y + 48),Box
End Sub

Sub Five()
put (x,y),Box
put (x + 12, y),Box
put (x + 24, y),Box
put (x,y + 12),Box
put (x + 24, y + 24),Box
put (x, y + 24),Box
put (x + 12,y + 24),Box
put (x + 24 ,y + 36),Box
put (x + 24 ,y + 48),Box
put (x,y + 48),Box
put (x + 12, y + 48),Box
End Sub

Sub Six()
put (x,y),Box
put (x,y + 12),Box
put (x + 24, y + 24),Box
put (x, y + 24),Box
put (x + 12,y + 24),Box
put (x,y + 36),box
put (x + 24 ,y + 36),Box
put (x + 24 ,y + 48),Box
put (x,y + 48),Box
put (x + 12, y + 48),Box
End Sub

Sub Seven()
put (x,y),Box
put (x +12,y),Box
put (x + 24,y),Box
put (x + 24, y + 12),Box
put (x + 24,y + 24),Box
put (x + 24,y + 36),box
put (x + 24 ,y + 48),Box
End Sub

Sub Eight()
Put (x,y),Box
put (x + 12,y),Box
put (x,y + 12),Box
put (x + 12,y + 24),Box
put (x,y + 24),Box
put (x,y + 36),Box
put (x,y + 48),Box
put (x + 24,y),Box
put (x + 24, y + 12),Box
put (x + 24, y + 24),Box
put (x + 24, y + 36),Box
put (x + 24, y + 48),Box
put (x + 12,y + 48),Box
End Sub

Sub Nine()
Put (x,y),Box
put (x + 12,y),Box
put (x,y + 12),Box
put (x + 12,y + 24),Box
put (x,y + 24),Box
put (x + 24,y + 36),Box
put (x + 24,y + 48),Box
put (x + 24,y),Box
put (x + 24, y + 12),Box
put (x + 24, y + 24),Box
End Sub

Do
t = Time
hr1 = mid(t,1,1)
hr2 = mid(t,2,1)

mn1 = Mid(t, 4, 1)
mn2 = Mid(t, 5, 1)

sc1 = Mid(t,7,1)
sc2 = Mid(t,8,1)

hrs1 = val(hr1)
hrs2 = val(hr2)

min1 = val(mn1)
min2 = val(mn2)

sec1 = val(sc1)
sec2 = val(sc2)

Screenlock
Cls

'colons
x = 100
put (x, y + 12),Box
put (x, y + 36),Box
x = 210
put (x, y + 12),Box
put (x, y + 36),Box

''hours
x = 10
If hrs1 = 0 Then Zero
If hrs1 = 1 Then One
If hrs1 = 2 Then Two
If hrs1 = 3 Then Three
If hrs1 = 4 Then Four
If hrs1 = 5 Then Five
If hrs1 = 6 Then Six 
If hrs1 = 7 Then Seven
If hrs1 = 8 Then Eight
If hrs1 = 9 Then Nine
x = 55
If hrs2 = 0 Then Zero
If hrs2 = 1 Then One
If hrs2 = 2 Then Two
If hrs2 = 3 Then Three
If hrs2 = 4 Then Four
If hrs2 = 5 Then Five
If hrs2 = 6 Then Six 
If hrs2 = 7 Then Seven
If hrs2 = 8 Then Eight
If hrs2 = 9 Then Nine

'' minutes
x = 120
If min1 = 0 Then Zero
If min1 = 1 Then One
If min1 = 2 Then Two
If min1 = 3 Then Three
If min1 = 4 Then Four
If min1 = 5 Then Five
If min1 = 6 Then Six 
If min1 = 7 Then Seven
If min1 = 8 Then Eight
If min1 = 9 Then Nine
x = 165
If min2 = 0 Then Zero
If min2 = 1 Then One
If min2 = 2 Then Two
If min2 = 3 Then Three
If min2 = 4 Then Four
If min2 = 5 Then Five
If min2 = 6 Then Six 
If min2 = 7 Then Seven
If min2 = 8 Then Eight
If min2 = 9 Then Nine

'' seconds
x = 230
If sec1 = 0 Then Zero
If sec1 = 1 Then One
If sec1 = 2 Then Two
If sec1 = 3 Then Three
If sec1 = 4 Then Four
If sec1 = 5 Then Five
If sec1 = 6 Then Six 
If sec1 = 7 Then Seven
If sec1 = 8 Then Eight
If sec1 = 9 Then Nine
x = 275
If sec2 = 0 Then Zero
If sec2 = 1 Then One
If sec2 = 2 Then Two
If sec2 = 3 Then Three
If sec2 = 4 Then Four
If sec2 = 5 Then Five
If sec2 = 6 Then Six 
If sec2 = 7 Then Seven
If sec2 = 8 Then Eight
If sec2 = 9 Then Nine

Screenunlock
key = inkey
sleep 100,1
Loop Until (key = Chr(27)) Or (key = Chr(255) & "k")
ImageDestroy Box
Last edited by neil on Jun 04, 2023 21:08, edited 1 time in total.
dodicat
Posts: 7919
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Word Clock

Post by dodicat »

That's really nice neil.
I know you have Linux, but this is a test for the Win 11 console (UEZ Windows11-22H2 console applications thread), but I post it here as it is a clock.

Code: Select all

#include "windows.bi"
#include "vbcompat.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,150,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
shell "title Steiner Console clock"
While true
   
     var dt= Format( now, "dd-mmmm-yyyy" )

    s=Second(Now)
    If lst<>s Then
        clearscreen(Memhdc,bgr(0,150,255))
        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(150,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
  
UEZ
Posts: 919
Joined: May 05, 2017 19:59
Location: Germany

Re: Word Clock

Post by UEZ »

dodicat wrote: Jun 04, 2023 9:59 That's really nice neil.
I know you have Linux, but this is a test for the Win 11 console (UEZ Windows11-22H2 console applications thread), but I post it here as it is a clock.
Nice console clock dodicat. It doesn't work in a Terminal Windows.
dodicat
Posts: 7919
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Word Clock

Post by dodicat »

Thanks UEZ.
fb itself is a console compiler, like c/c++ and many others.
Can you run console applications straight off in fb now in Win 11?
Post Reply