fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Bildschirmschoner mit Mustergenerator

Uploader:	Sebastian
Datum/Zeit:	31.03.2008 15:17:14
'Bildschirmschoner:

' => Zufällige Muster basierend auf Langtons Ameise

'Basierend auf einem Programm von Skilltronic (07.03.2008),

' siehe http://forum.qbasic.at/viewtopic.php?t=5409

'Im Original als QB-Programm, hier als FreeBasic-Variante



#include "windows.bi"

dim shared as String Param



declare sub configurescreensaver

declare sub showscreensaver



CONST Durchgangslaenge = 60 'in Sekunden



if command(1) = "" then

    if messagebox(0, "Bildschirmschoner testen?", " ", mb_iconquestion or mb_yesno) = idyes then

    showscreensaver

    end if

    end

end if



param = Mid(Command(1), 2, 1)



select case UCASE(param)

case "S": showscreensaver

case "C": configurescreensaver

end select

end



'Unterprogramme:



sub configurescreensaver

    messagebox(0, "Es gibt nichts zu konfigurieren! ", " ", mb_iconinformation)

end sub



sub showscreensaver

    Dim As Integer WinBreite, WinHoehe

    dim as integer mxalt, myalt, mxneu, myneu

    DIM AS INTEGER a, r, x, y, nf, weg(15), c

    DIM AS STRING taste

    DIM AS SINGLE Laufzeit

    'Momentane Bildschirmauflösung feststellen und verwenden

    ScreenInfo WinBreite, WinHoehe

    ScreenRes WinBreite,WinHoehe,8,,1

    'Mauszeiger unsichtbar machen:

    setmouse ,,0

    randomize timer

    c=0

    DO

        CLS

        FOR a = 0 TO 15

            weg(a) = FIX(RND * 2) * 2 - 1

        NEXT

        x = Fix(WinBreite/2)-1

        y = Fix(WinHoehe/2)-1

        Laufzeit = TIMER

        DO

            r = r + weg(POINT(x, y))

            IF r = 4 THEN r = 0

            IF r = -1 THEN r = 3

            nf = POINT(x, y) + 1

            IF nf = 16 THEN nf = 0

            PSET (x, y), nf

            IF r = 0 THEN x = x + 1

            IF r = 1 THEN y = y + 1

            IF r = 2 THEN x = x - 1

            IF r = 3 THEN y = y - 1

            IF x = WinBreite THEN x = 0

            IF x = -1 THEN x = WinBreite-1

            IF y = WinHoehe THEN y = 0

            IF y = -1 THEN y = WinHoehe-1

            c += 1

            IF c = 750 THEN

                'Prozessorauslastung senken:

                'Alle 750 Schleifendurchgänge kurz ans System übergeben

                SLEEP 1

                c = 0

            END IF

            getmouse mxneu, myneu

            taste = Inkey

            IF taste <> "" THEN

                SELECT CASE taste

                    CASE CHR(32): EXIT DO

                    CASE ELSE: EXIT SUB

                END SELECT

            END IF

            IF mxalt = 0 THEN

                mxalt = mxneu

                myalt = myneu

            ELSE

                if mxneu<>mxalt or myneu<>myalt then exit sub

            END IF

        LOOP UNTIL TIMER > (Laufzeit+Durchgangslaenge)

    LOOP

end sub