Hier noch eine kleine Analoguhr mit Schlagwerk. Beenden über das Optionsmenü (rechte Maustaste). Dort kann auch das Schlagwerk ein- und ausgeschalten und zwei verschiedene Töne ausgewählt werden. Zum Verschieben wird die Uhr am "Aufhänger" gezogen.
[Blockierte Grafik: http://s15.postimage.org/th1y05efb/Screen_08_03_2013_13_Uhr_56_09_Sek.jpg]
Code
' 4k-Wettbewerb @Volkmar 2013
$H WINDOWS.PH
$H MESSAGES.PH
Def DR(1) (Pi()*!(1))/180
Def ZW1(2) %(1)*Cos(DR(!(2)))
Def ZW2(2) %(1)*Sin(DR(!(2)))
Declare String Zeit,Anz,Dat,Tag,PM,AL
Declare Int Std,Min,Sek,K,WK,RF,R3,Ky
Declare Double SWk,MWk,SEWk
Var Int UR=200
Var Int UU=200
Var Int MX=(UR\2)
Var Int MY=(UU\2)
Var Int Bk=RGB(0,196,195)
Var Int CXB=~GetSystemMetrics(~sm_CXFixedFrame)
Var Int CYB=~GetSystemMetrics(~sm_CYFixedFRame)
Var Int CYC=~GetSystemMetrics(~sm_CYCaption)
Var Int T=1
Var Int SM=1
WindowTitle "Uhr"
WindowStyle 16
Window UR+(2*CXB),UU+CYC+(2*CXB)
MCLS 2*UR,UU,Bk
SWR
SetTimer 300
While 1
WaitInput
If GetActiveWindow()=%HWnd
Ky=%MouseKey
If Ky=2
Case Menu()=1:Break
EndIf
EndIf
Zeit=dt("GetTime",0)+":"+SubStr$(dt("GetTime",1),1,".")
Dat=dt("GetDate",2)
Tag=SubStr$(Dat,1,",")
Dat=Trim$(SubStr$(Dat,2,"der"))
If Zeit<>Anz
Anz=Zeit
Case Al=Zeit:WK=120
Std=Val(SubStr$(Anz,1,":"))
CaseNot Std:Std=24
If Std>12
PM="PM"
Std=Std-12
Else
PM="AM"
EndIf
Min=Val(SubStr$(Anz,2,":"))
Sek=Val(SubStr$(Anz,3,":"))
SeWk= 6*Sek
MWk=(6*Min)+(SeWk/60)
SWk=30*Std+(MWk/12)
StartPaint -1
UsePen 0,1,Bk
UseBrush 1,Bk
Rectangle 0,0-2*UR,UU
UsePen 0,1,0
ZBl
TextColor RGB(0,0,192), -1
UseFont "ARIAL",20,0,0,0,0
DrawText UR,MY+4,2*UR,MY+28,Dat,1
Case Tag="Sonntag":TextColor RGB(240,0,0),-1
DrawText UR,MY+29,2*UR,MY+48,Tag,1
UseBrush 0,0
UsePen 0,3,0
Zeig 48,SWk
UsePen 0,2,0
Zeig 10,MWk
UsePen 0,1,RGB(255,0,0)
Zeig 2,SeWk
TextColor RGB(0,0,64),-1
UseFont "ARIAL",18,0,1,0,0
DrawText UR,MY-48,2*UR,MY-32,PM,1
CopyBMP 0,0,UR,UU>UR,0;-1
EndPaint
MCopyBMP UR,0-(UR*2),UU>0,0;0
If WK
If (Sek & 3)=0
PExec("|WKSch")
Dec WK
EndIf
Else
If Sek=0
If Min=0
Case T:PExec("|SSch",Str$(Std),Str$(K))
ElseIf Min = 15
Case T:PExec("|VSch","1",Str$(K))
ElseIf Min = 30
Case T:PExec("|VSch","2",Str$(K))
ElseIf Min = 45
Case T:PExec("|VSch","3",Str$(K))
EndIf
EndIf
EndIf
EndIf
EndWhile
Case R3:DeleteObject R3
Proc Menu
Declare Int M
CreateMenu
AppendMenu 1,"Minimieren"
AppendMenu 2,"Immer im Vordergrund"
AppendMenu 3,"Ton"
Case SM:CheckMenu 2,1
Case T:CheckMenu 3,1
If T
If K
AppendMenu 4,"Gong"
Else
AppendMenu 4,"Kuckuck"
EndIf
EndIf
AppendMenu 5,"Wecker"
AppendMenu 6, "Fensteransicht"
Separator
AppendMenu 10,"Ende"
TrackMenu 16,16
If MenuItem(1)
ShowWindow(%HWnd,6)
ElseIf MenuItem(2)
SM=Not(SM)
SWP
ElseIf MenuItem(3)
T=Not(T)
ElseIf MenuItem(4)
K=Not(K)
ElseIf MenuItem(5)
If WK
WK=0
Else
AL=Input$("Weckzeit im 24-Stundenformat","Wecker",Left$(AL,5))
If AL<>""
Case Mid$(AL,2,1)=":":AL="0"+AL
AL=Left$(AL,5)+":00"
EndIf
EndIf
ElseIf MenuItem(6)
RF=Not(RF)
SWR
ElseIf MenuItem(10)
M=1
EndIf
Return M
EndProc
Proc SWP
~SetWindowPos(%HWnd,SM-2,0,0,0,0,$203)
EndProc
Proc SWR
If RF
DeleteObject R3
R3=0
Else
Var Int R1=~CreateEllipticRgn(CXB,CYB+CYC,UR+CXB,UU+CYB+CYC)
Var Int R2=~CreateEllipticRgn(MX+CYB-8,4,MX+12,CYB+CYC+3)
R3=~CreateRectRgn(0,0,UR+(2*CYB),UU+CYB+CYC)
~CombineRgn(R3,R1,R2,~rgn_xor)
DeleteObject R1
DeleteObject R2
EndIf
~SetWindowRgn(%HWnd,R3,0)
SWP
EndProc
Proc ZBl
Declare Int PX,PY,Z
WhileLoop 0,11
Case &Loop=11:UsePen 1,3,0
Z=(&Loop*30)-60
PX=ZW1(MY,Z)
PY=ZW2(MX,Z)
Line MX+UR,MY-MX+UR+PX,MY+PY
EndWhile
UsePen 0,1,Bk\2
UseBrush 1,RGB(188,250,250)
Ellipse UR+6,6-UR*2-6,UU-6
EndProc
Proc Zeig
Parameters Int L,Double W
Declare Int PX,PY
W=W+90
Case W>359:W=W-360
PX=ZW1(MX-L,W)*-1
PY=ZW2(MY-L,W)*-1
Line MX,MY-(MX+PX),MY+PY
EndProc
Proc VS
Parameters Int V,K
WhileLoop V
If K
Sound 800,100
Sound 680,130
Sleep 320
Else
Play 44;48,2,1
Sleep 200
EndIf
EndWhile
Sleep 160
EndProc
Proc SSch
Declare Int Z,K
Z=Val(Par$(2))
K=Val(Par$(3))
VS 4,K
WhileLoop Z
If K
Sound 540,140
Sound 420,160
Sleep 320
Else
Play 30;34;38,1,1
Sleep 300
EndIf
EndWhile
EndProc
Proc VSch
Declare Int Z,K
Z=Val(Par$(2))
K=Val(Par$(3))
VS Z,K
EndProc
Proc WKSch
Play 38;42;46,2,1
Play 44;48;52,2,1
EndProc
Alles anzeigen
Gruß Volkmar