XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Uhr: Analoge Uhr mit Fensterregionen
Bitte auch mal Rechtsklick auf die Uhr ...
Def GetTextExtentPoint32A(4) !GDI32,GetTextExtentPoint32A
Def GetDC(1) !USER32,GetDC
Def ReleaseDC(2) !USER32,ReleaseDC
Def Setwindowlong(3) !USER32,SetWindowLongA
Def Getwindowlong(2) !USER32,GetWindowLongA
Def Setlayeredwindowattributes(4) !USER32,SetLayeredWindowAttributes
Def Choosecolor(1) !COMDLG32,ChooseColorA
Def Home(0) Translate$(Upper$(Par$(0)),Upper$(FindFirst$(Par$(0))),)
Def Int2Hex(1) ($ + Hex$(@%(1)))

Proc Preparehdl4alpha

    Parameters Hdl&
    Declare Style&
    Style& = -20
    Setwindowlong(Hdl&, Hex$(Style&), @Or(Getwindowlong(Hdl&,Hex$(Style&)),$80000));

Endproc

Proc Alpha

    Parameters Hdl&,Aval&
    Setlayeredwindowattributes(Hdl&, 0, Hex$(Aval&), $2);

Endproc

Declare Text#, Ergebnis#
Def GetWindowPos(2) ! USER32, GetWindowRect
Def CreateEllipticRgn(4) !GDI32,CreateEllipticRgn
DEF CreateRectRgn(4) !GDI32,CreateRectRgn
Def DeleteObject(1) !GDI32,DeleteObject
Def InvertRgn(2) !GDI32,InvertRgn
Def PaintRgn(2) !GDI32,PaintRgn
Def SetWindowRgn(3) !USER32,SetWindowRgn
Def ReleaseCapture(0) !USER32,ReleaseCapture
DEF CombineRgn(4) !GDI32,CombineRgn
Def GetSysColor(1) !USER32,GetSysColor
Declare mx% , my% , xi% , yi% , offset% , ss%
Declare ende%,ziel&,rgn&[2],x%,y%,sx%,sy%,move%,wp%,DateVisible%
Declare WallPaper$
Declare rect#,xpos&,ypos&,xRpos&,yRpos&
Declare ZBlatt&,ZBRand&,Punkte&,Ring&,Ziffern&,SMZeiger&,ZeigerShadow&,SZeiger&,BG&,BGRand&,Schrift&,DarkSchrift&,LightSchrift&
Declare r%,g%,b%,SetupWindow&
Declare Button&[10] , Vorschau& , Transparenz%
Declare Choosecolor#,Customcolors#,Colors&[16],Ok&
Declare IniFile$
SetTrueColor 1
mx% = 150%MaxY/5150
Case %MaxX > 800:mx% = %MaxY/5
my% = mx%
wp% = -2
OffSet% = mx% + 40
WindowStyle 80 + 1024
Window %MaxX,0-0,0mx%,my%*2
WindowTitle Runde Uhr
IniFile$ = Upper$(Translate$((Home() + Clock.ini), ,/))
IniFile$ = Upper$(Home() + Clock.cfg)

proc WriteValues

    ifnot len(@FindFirst$(IniFile$))

        Assign #1,IniFile$
        Rewrite #1
        Print #1,[Colors]
        Print #1,ZBlatt =
        Print #1,SMZeiger =
        Print #1,SZeiger =
        Print #1,BG =
        Print #1,Schrift =
        Print #1,Ring =
        Print #1,[Programm]
        Print #1,Pfad = ,IniFile$
        Print #1,Move = 1
        Print #1,Alpha = 255
        Print #1,XPos = 0
        Print #1,YPos = 0
        Print #1,DateVisible = 1
        Close #1

    EndIf

    Decimals 0
    WriteIni IniFile$ , Colors , ZBlatt = ($+hex$(ZBlatt&))
    WriteIni IniFile$, Colors , SMZeiger = ($+hex$(SMZeiger&))
    WriteIni IniFile$, Colors , SZeiger = ($+Hex$(SZeiger&))
    WriteIni IniFile$, Colors , BG = ($+Hex$(BG&))
    WriteIni IniFile$, Colors , Schrift = ($+Hex$(Schrift&))
    WriteIni IniFile$, Colors , Ring = ($+Hex$(Ring&))
    WriteIni IniFile$, Programm , Move = Str$(move%)
    WriteIni IniFile$, Programm , Alpha = Str$(Transparenz%)
    WriteIni IniFile$, Programm , XPos = Str$(x%)
    WriteIni IniFile$, Programm , YPos = Str$(y%)
    WriteIni IniFile$, Programm , DateVisible = Str$(DateVisible%)

EndProc

Proc ReadValues

    Decimals 0

    Ifnot len(FindFirst$(IniFile$))

        ZBlatt&=rgb(255,255,255)
        SMZeiger&=rgb(0,0,255)
        SZeiger&=rgb(255,0,0)
        BG&=rgb(150,0,150)
        Schrift&=rgb(255,255,0)
        Ring&=rgb(255,255,0)
        move% = 0
        Transparenz% = 255
        DateVisible% = 1
        x% = (%MaxX/2)-75
        y% = (%MaxY/2)-75
        WriteValues

    Else

        ZBlatt& = val(ReadIni$(IniFile$,Colors,ZBlatt))
        SMZeiger& = val(ReadIni$(IniFile$,Colors,SMZeiger))
        SZeiger& = val(ReadIni$(IniFile$,Colors,SZeiger))
        BG& = val(ReadIni$(IniFile$,Colors,BG))
        Schrift& = val(ReadIni$(IniFile$,Colors,Schrift))
        Ring& = val(ReadIni$(IniFile$,Colors,Ring))
        move%  = val(ReadIni$(IniFile$,Programm , Move))
        Transparenz% = val(ReadIni$(IniFile$,Programm , Alpha))
        x% = val(ReadIni$(IniFile$,Programm , Xpos))
        y% = val(ReadIni$(IniFile$,Programm , YPos))
        DateVisible% = val(ReadIni$(IniFile$,Programm , DateVisible))

    EndIf

EndProc

Proc Colordialog

    Parameters Color&
    Declare I%,Result&
    Dim Choosecolor#,36
    Dim Customcolors#,64
    Settruecolor 1
    Colors&[0] = rgb(255,0,0)
    Colors&[1] = rgb(0,255,0)
    Colors&[2] = rgb(0,0,255)
    Colors&[3] = rgb(255,255,0)
    Colors&[4] = rgb(255,0,255)
    Colors&[5] = rgb(0,255,255)
    Colors&[6] = rgb(255,255,255)

    While Lt(I%,16)

        Long Customcolors#,Mul(I%,4)= Colors&[I%]
        Inc I%

    Wend

    Long Choosecolor#,0=36
    Long Choosecolor#,4=Getactivewindow()
    Long Choosecolor#,8=0
    Long Choosecolor#,12=Color&Rgb(192,192,192)
    Long Choosecolor#,16=Customcolors#
    Long Choosecolor#,20=3CC_RGBINIT(1) + CC_FULLOPEN(2)
    Long Choosecolor#,24=0
    Long Choosecolor#,28=0
    Let Name$=GetText$(Getactivewindow())
    Long Choosecolor#,32=0
    Let Ok&=@Choosecolor(Choosecolor#)

    If Ok&

        Let I%=0

        While Lt(I%,16)

            Let Colors&[I%]=Long(Customcolors#,Mul(I%,4))
            Inc I%

        Wend

    Endif

    Let Result&=@Long(Choosecolor#,12)
    Dispose Choosecolor#
    Dispose Customcolors#
    Return Result&

Endproc

Proc GetTextExtent

    Parameters r$, Flag%Bei Flag = 0 Stringhöhe zurückgeben, sonst Stringlänge
    DECLARE Rückgabewert&, DeviceContext&
    DIM Text#, @Add(Len(r$), 1)
    DIM Ergebnis#, 8
    String Text#, 0 = r$
    DeviceContext& = %HDCGetDC(@GetActiveWindow())
    DeviceContext& = &PDC
    GetTextExtentPoint32A(DeviceContext&, Text#, @Len(r$), Ergebnis#)
    Rückgabewert& = @Long(Ergebnis#, 4)Breite
    Case Flag% : Rückgabewert& = @Long(Ergebnis#, 0)Höhe
    Aufräumen:
    ReleaseDC(@GetActiveWindow(), DeviceContext&)
    ReleaseDC(%HDC, DeviceContext&)
    Dispose Text#
    Dispose Ergebnis#
    Return Rückgabewert&

EndProc

Proc GetStringHeight

    Parameters r$
    GetTextExtent r$, 0
    Return &(0)

EndProc

Proc GetStringWidth

    Parameters r$
    GetTextExtent r$, 1
    Return &(0)

EndProc

Proc DrawTextCenterVH

    Parameters x1%, y%, txt$
    GetStringHeight
    y% = y% - ( &(0) / 2 )
    GetStringWidth txt$
    DrawText x1% - ( &(0) / 2 ) , y%, txt$
    EndProcDrawTextCenterVH

    proc GetwindowPos

        Parameters hndl&
        case equ(%pcount,0):let hndl&=@getactiveWindow()
        DIM rect#,16
        GetWindowPos(hndl&,rect#)
        let xpos&=@long(rect#,0)links oben
        let ypos&=@long(rect#,4)
        let xRpos&=@long(rect#,8)rechts unten
        let yRpos&=@long(rect#,12)
        Clear rect#
        Dispose rect#

    endproc

    Proc Rechnen

        Parameters Winkel! , Laenge%
        Declare x!,y!
        Winkel! = Winkel! - (@PI()/2)Winkel um 90 Grad zurück
        x! = @COS(Winkel!)
        y! = @SIN(Winkel!)
        x! = x! * Laenge%(@Width(%hwnd) / 2)   Radius korrigieren
        y! = y! * Laenge%(@Height(%hwnd) / 2)
        x! = x! + (mx%/2)auf Fenstermittelpunkt setzen
        y! = y! + (my%/2)
        xi%= @INT(x!)Nur Ganzzahlen
        yi%= @INT(y!)

    EndProc

    Proc DrawTime

        Declare H%,M%,S%
        StartPaint -1
        H% = val(Left$(Time$(0),2))
        M% = val(Right$(Time$(0),2))
        S% = val(Left$(Time$(1),2))
        CaseNot S%:WriteValues

        If or(H% = 0 , H% > 12)

            copybmp mx%*3,0-mx%,OffSet%>0,0;0
            falsch

        ElseIf and(H% = 12 , M% + S% > 0)

            copybmp mx%*3,0-mx%,OffSet%>0,0;0

        Else

            copybmp mx%*2,0-mx%,OffSet%>0,0;0

        EndIf

        TextColor SMZeiger&,-1
        DrawTextCenterVH mx%/2 , (my%/2)-10,Time$(0) + : + Left$(Time$(1),2)
        case H%>12:H%=H%-12
        H% = ( H% * 60) + M%
        Rechnen (2* @PI()/720)*H%  , (mx%/2)*0.65
        usepen 0,6,ZeigerShadow&
        line xi%,yi% - (mx%/2),(my%/2)
        usepen 0,2,SMZeiger&
        line xi%,yi% - (mx%/2),(my%/2)
        Rechnen (2* @PI()/60)*M%  , (mx%/2)*0.8
        usepen 0,4,ZeigerShadow&
        line xi%,yi% - (mx%/2),(my%/2)
        usepen 0,1,SMZeiger&
        line xi%,yi% - (mx%/2),(my%/2)
        Rechnen (2* @PI()/60)*S%  , (mx%/2)*0.9
        usepen 0,2,SZeiger&
        line xi%,yi% - (mx%/2),(my%/2)
        usepen 0,1,SZeiger&
        line xi%,yi% - (mx%/2),(my%/2)

        If DateVisible%

            TextColor DarkSchrift&,-1
            DrawTextCenterVH (mx%/2)+1,my%+11,Date$(1)
            DrawTextCenterVH (mx%/2)+1,my%+31,substr$(Date$(2),1,,)
            TextColor Schrift&,-1
            DrawTextCenterVH mx%/2,my%+10,Date$(1)
            DrawTextCenterVH (mx%/2),my%+30,substr$(Date$(2),1,,)

        EndIf

        Endpaint
        MCopyBmp 0,0-mx%,my%+(DateVisible%*40)>0,0;0

    EndProc

    sx%=1
    sy%=1
    ziel&=CreateRectRgn(0,0,0,0)
    rgn&[0]=CreateRectRgn(0,mx%,mx%,mx%+40)
    rgn&[0]=CreateEllipticRgn(0,mx%,mx%,mx%+20)
    rgn&[1]=CreateEllipticRgn(0,0,mx%,my%)
    Combinergn(ziel&,rgn&[0],rgn&[1],3)
    SetWindowRgn(%hwnd,ziel&,1)
    UseIcon A
    DateVisible% = 1
    SetWindowPos %hwnd=x%,y%-mx%,my%+(DateVisible% * 40);wp%
    mcls mx%*4,OFFSET%
    WindowStyle 512 + 1024
    SetupWindow& = @CreateDialog(%HWND,Farben einstellen,%MaxX + 3,0,mx% + 250,OffSet% +70)
    Vorschau& = @CreateGroupBox(SetupWindow&,Vorschau,10,10,mx%,OffSet%+15)
    Button&[0] = @CreateButton(SetupWindow&,Zifferblatt,mx%+30,10,200,20)
    Button&[1] = @CreateButton(SetupWindow&,Ring,mx%+30,35,200,20)
    Button&[2] = @CreateButton(SetupWindow&,Stunden/Minuten Zeiger,mx%+30,60,200,20)
    Button&[3] = @CreateButton(SetupWindow&,Sekunden Zeiger,mx%+30,85,200,20)
    Button&[4] = @CreateButton(SetupWindow&,Datum Hintergrund,mx%+30,110,200,20)
    Button&[5] = @CreateButton(SetupWindow&,Datum Schriftfarbe,mx%+30,135,200,20)
    Button&[6] = @CreateButton(SetupWindow&,Speichern,mx%+30,OffSet%,95,20)
    Button&[7] = @CreateButton(SetupWindow&,abbrechen,mx%+135,OffSet%,95,20)
    Button&[8] = @CreateText(SetupWindow&,Transparenz,mx%+30,165,95,20)
    Button&[9] = @CreateHScroll(SetupWindow&,,mx%+135,165,100,20)
    SetScrollRange Button&[9],20,255

    Proc InitUhr

        Startpaint -1
        Usepen 0,1,ZBlatt&
        usebrush 1,ZBlatt&
        rectangle 0,my%-mx%*3,my%+40
        usepen 0,1,ZBRand&
        usebrush 1,ZBlatt&
        Ellipse 1,1 - (mx%-2),(my%-2)
        usepen 0,3,Ring&
        usebrush 1,Ring&
        Ellipse 10,10 - (mx%-10),(my%-10)
        usebrush 1,ZBlatt&
        Ellipse 35,35 - (mx%-35),(my%-35)
        usepen 0,2,BGRand&
        UseBrush 1,BG&
        rectangle (mx%*2)+1,mx%+1 - mx%*3,offset%
        rectangle (mx%*3)+1,mx%+1 - mx%*4,offset%

        WhileLoop 0,59

            Rechnen (2* @PI()/60)*&LOOP  , (mx%/2)*0.9
            SetPixel xi%,yi%,Punkte&

        Wend

        Usepen 0,1,Ziffern&Punkte&
        usebrush 1,Ziffern&Punkte&

        WhileLoop 1,12

            Rechnen (2* @PI()/720)*(&LOOP*60)  , (mx%/2)*0.9
            Ellipse (xi%-3),(yi%-3)-(xi%+3),(yi%+3)

        Wend

        copybmp 0,0-mx%,my%>mx%*3,0;0
        TextColor Ziffern&,-1

        WhileLoop 1,12

            Rechnen (2* @PI()/720)*(&LOOP*60)  , (mx%/2)*0.7
            DrawTextCenterVH xi%,yi%,Str$(&LOOP)

        Wend

        copybmp 0,0-mx%,my%>mx%*2,0;0
        copybmp mx%*3,0-mx%,my%>0,0;0

        WhileLoop 1,12

            Rechnen (2* @PI()/720)*(&LOOP*60)  , (mx%/2)*0.7

            If &LOOP > 11

                DrawTextCenterVH xi%,yi%,0

            Else

                DrawTextCenterVH xi%,yi%,Str$(&LOOP+12)

            EndIf

        Wend

        copybmp 0,0-mx%,my%>mx%*3,0;0
        Endpaint

    EndProc

    Proc initColor

        --------------------------
        ZBRand&=rgb(255-GetRValue(ZBlatt&),255-GetGValue(ZBlatt&),255-GetBValue(ZBlatt&))
        Punkte&=ZBRand&
        -----------------------
        Ziffern&=rgb(255-GetRValue(Ring&),255-GetGValue(Ring&),255-GetBValue(Ring&))
        ---------------------------
        ZeigerShadow&=rgb(GetRValue(SMZeiger&)/2,GetGValue(SMZeiger&)/2,GetBValue(SMZeiger&)/2)
        BGRand&=Schrift&
        DarkSchrift&=rgb(GetRValue(Schrift&)/2,GetGValue(Schrift&)/2,GetBValue(Schrift&)/2)

    EndProc

    Proc RestoreINI

        Declare Backup$
        Backup$ = Left$(IniFile$,len(IniFile$)-3) + bak
        COPY Backup$ > IniFile$

    EndProc

    Proc SaveINI

        Declare Backup$
        Backup$ = Left$(IniFile$,len(IniFile$)-3) + bak
        COPY INIFile$ > Backup$

    EndProc

    Proc Setup

        Declare e%
        SaveINI
        ShowWindow(SetupWindow&,1)
        SetWindowPos SetupWindow& = ( (%MaxX/2)-((mx% + 250)/2) )  , ((%MaxY/2)-((mx% + 250)/2)) - (mx% + 250) , (OffSet% +70);-1
        Clear e%
        SetFocus(Vorschau&)
        SetText SetupWindow& , Inhalt von  + FindFirst$(IniFile$)
        SetScrollPos Button&[9],Transparenz%

        Whilenot e%

            WaitInput
            ZifferBlatt

            If GetFocus(button&[0])

                SetText SetupWindow& , Farben einstellen für  + GetText$(Button&[0])
                Colordialog val(ReadIni$(IniFile$,Colors,ZBlatt))
                ZBlatt& = @&(0)
                SetFocus(Vorschau&)
                Ring

            ElseIf GetFocus(button&[1])

                SetText SetupWindow& , Farben einstellen für + GetText$(Button&[1])
                Colordialog val(ReadIni$(IniFile$,Colors,Ring))
                Ring& = @&(0)
                SetFocus(Vorschau&)
                Stunden/Minuten Zeiger

            ElseIf GetFocus(button&[2])

                SetText SetupWindow& , Farben einstellen für + GetText$(Button&[2])
                Colordialog val(ReadIni$(IniFile$,Colors,SMZeiger))
                SMZeiger& = @&(0)
                SetFocus(Vorschau&)
                Sekundenzeiger

            ElseIf GetFocus(button&[3])

                SetText SetupWindow& , Farben einstellen für + GetText$(Button&[3])
                Colordialog val(ReadIni$(IniFile$,Colors,SZeiger))
                SZeiger&= @&(0)
                SetFocus(Vorschau&)
                Datum Hintergrund

            ElseIf GetFocus(button&[4])

                SetText SetupWindow& , Farben einstellen für + GetText$(Button&[4])
                Colordialog val(ReadIni$(IniFile$,Colors,BG))
                BG&= @&(0)
                SetFocus(Vorschau&)
                Datum Schrift

            ElseIf GetFocus(button&[5])

                SetText SetupWindow& , Farben einstellen für + GetText$(Button&[5])
                Colordialog val(ReadIni$(IniFile$,Colors,Schrift))
                Schrift&= @&(0)
                SetFocus(Vorschau&)

            ElseIf GetFocus(button&[6])

                e% = 1

            ElseIf GetFocus(button&[7])

                e% = 2

            ElseIf GetFocus(button&[9])

                Transparenz% = @GetScrollPos(button&[9])
                alpha %HWND,Transparenz%

            EndIf

            InitColor
            InitUhr
            DrawTime
            StartPaint Vorschau&
            MCopyBmp 0,0-mx%,my%+(DateVisible%*40)>0,15;0
            EndPaint

        Wend

        if e% = 1

            SaveINI
            WriteValues
            InitColor
            InitUhr

        Elseif e% = 2

            RestoreINI
            ReadValues
            InitColor
            InitUhr

        EndIf

        SetFocus(Vorschau&)
        ShowWindow(SetupWindow&,0)

    EndProc

    ReadValues
    InitColor
    InitUhr
    DrawTime
    StartPaint -1
    SaveBMP C:undeuhr.bmp,0,0-mx%,offset%
    EndPaint
    Preparehdl4alpha %HWND , (80 + 1024)
    case Transparenz% < 40:Transparenz%=40
    Alpha %HWND,Transparenz%
    SetTimer 80
    Usepen 0,1,0
    Hauptschleife
    SetWindowPos %hwnd=x%,y%-mx%,my%+(DateVisible% * 40);wp%

    WhileNot ende%

        If %wmTimer

            DrawTime

            If move%

                Case Gt(y%,%maxY-my%-(DateVisible% * 40)):y%=%maxY-my%-(DateVisible% * 40)
                SetWindowPos %hwnd=x%,y%-mx%,my%+(DateVisible% * 40);wp%
                Add x%,sx%
                Case Gt(x%,%maxX-mx%):Let sx%=sx%*-1
                Case Lt(x%,1):Let sx%=sx%*-1
                Add y%,sy%
                Case Gt(y%,%maxY-my%-(DateVisible% * 40)):Let sy%=sy%*-1
                Case Lt(y%,1):Let sy%=sy%*-1

            EndIf

        EndIf

        WaitInput

        If Equ(%message,$204)

            CreateMenu

            if wp% = -2

                AppendMenu 1, &Vordergrund

            Elseif wp% = -1

                AppendMenu 1, &Hintergrund

            Endif

            Separator

            IF move%

                AppendMenu 2,&Anhalten

            Else

                AppendMenu 2, B&ewegen

            EndIf

            Separator

            IF DateVisible%

                AppendMenu 3,&ohne Datum

            Else

                AppendMenu 3, &Datum anzeigen

            EndIf

            Separator
            AppendMenu 4,&Normal
            AppendMenu 5,&transparent
            AppendMenu 6,&Geisterstunde
            Separator
            AppendMenu 7,&Farben einstellen
            Separator
            AppendMenu 8,&Beenden
            TrackMenu %MouseX,%MouseY

            If MenuItem(1)

                if wp% = -1

                    wp% = -2

                Else

                    wp% = -1

                EndIf

            Elseif Menuitem(2)

                Let move%=Not(move%)

            Elseif Menuitem(3)

                Let DateVisible%=Not(DateVisible%)
                Case y% > %MaxY - my% - (DateVisible% * 40):y% = %MaxY - my% - (DateVisible% * 40)
                SetWindowPos %hwnd=x%,y%-mx%,my%+(DateVisible% * 40);wp%

            Elseif Menuitem(4)

                Transparenz% = 255
                alpha %HWND,Transparenz%

            Elseif Menuitem(5)

                Transparenz% = 180
                alpha %HWND,Transparenz%

            Elseif Menuitem(6)

                Transparenz% = 40
                alpha %HWND,Transparenz%

            Elseif Menuitem(7)

                Setup

            ElseIf MenuItem(8)

                Let ende%=1

            Endif

        Elseif Equ(%message,$201)

            UseCursor 5
            Sendmessage(%hwnd,$0112,$0F012,0);
            UseCursor 0
            ReleaseCapture()
            GetwindowPos  %HWND
            x% = xpos&
            case x% > %MaxX - mx%:x% = %MaxX - mx%
            case x% < 1:x% = 1
            y% = ypos&
            case y% > %MaxY - my%-(DateVisible% * 40):y% = %MaxY - my% - (DateVisible% * 40)
            case y% < 1:y% = 1

        Elseif Equ(%message,$100)

            IF %ScanKey = 45Minus

                Transparenz% = Transparenz% - 5
                Case Transparenz% < 40:Transparenz% = 40
                Alpha %HWND,Transparenz%
                DrawTextCenterVH mx%/2,My%/4,<

            ElseIf %ScanKey = 43Plus

                Transparenz% = Transparenz% + 5
                Case Transparenz% > 255:Transparenz% = 255
                Alpha %HWND,Transparenz%
                DrawTextCenterVH mx%/2,My%/4,>

            EndIf

        EndIf

    Wend

    KillTimer
    WriteValues
    SetWindowRgn(%hwnd,0,0)
    DeleteObject(rgn&[0])
    DeleteObject(rgn&[1])
    End