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