Keskustelu: Koodit: VB6: Pilailuohjelma

Option Explicit
' Koneen sammutus - epävakaa riippuen alustasta.
' Mieti tosissaan haluatko oikeasti käyttää vaikka
' se onkin juuri sopivan ärsyttävä toiminto.
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Const EWX_SHUTDOWN = 1   ' Sammuttaa koneen
Public Const EWX_LOGOFF = 0     ' Loggaa käyttäjän ulos

' Messagebox API:n kautta - vähän turha, koska
' voitaisiin käyttää tavallista MsgBoxia, mutta
' tässä sitä käytetään ihan opetuksellisessa
' tarkoituksessa'
Public Declare Function MessageBoxEx Lib "user32" Alias "MessageBoxExA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long) As Long
Public Const MB_YESNO = &H4&            ' Kyllä/Ei painikkeet
Public Const MB_ICONEXCLAMATION = &H30& ' Huutomerkki ikoni
Public Const MB_ICONHAND = &H10&        ' Käsi-ikoni

' CD-Rom laitteen käsittelyn mahdollistava API-funktio
Private Declare Function mciSendString Lib "WINMM.DLL" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

' Hiiren painikkeiden vaihto
Private Declare Function SwapMouseButton Lib "user32" (ByVal bSwap As Long) As Long

' Piip-ääni
Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

' Timeri funktion API-kutsut
' - Luominen, jälleenkäyttäminen ja asettaminen
' Lisäksi löytyy myös peruuttaminen, jota ei tässä käytetä
Private Declare Function CreateWaitableTimer Lib "kernel32" _
    Alias "CreateWaitableTimerA" ( _
    ByVal lpSemaphoreAttributes As Long, _
    ByVal bManualReset As Long, _
    ByVal lpName As String) As Long

'CreateWaitableTimer'in palauttama virhe, jos luotava ajastin on jo olemassa
Private Const ERROR_ALREADY_EXISTS = 183&

Private Declare Function OpenWaitableTimer Lib "kernel32" _
    Alias "OpenWaitableTimerA" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal lpName As String) As Long

Private Declare Function SetWaitableTimer Lib "kernel32" ( _
    ByVal hTimer As Long, _
    lpDueTime As FILETIME, _
    ByVal lPeriod As Long, _
    ByVal pfnCompletionRoutine As Long, _
    ByVal lpArgToCompletionRoutine As Long, _
    ByVal fResume As Long) As Long

Private Declare Function CancelWaitableTimer Lib "kernel32" ( _
    ByVal hTimer As Long)

' Luodun hanskan sulkeminen
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

' Säikeistetty "odottaja" ja sen konstantit
' Kaikkia konstantteja ei käytetä, mutta olkoon ne nyt
' tässä opetusmielessä. Mikäli alatte leikkimään funktiolla
' kehoitan vakavasti lukemaan aiheesta, sillä muutoin saatatte
' aiheuttaa "deadlock":in...
Private Declare Function MsgWaitForMultipleObjects Lib "user32" ( _
    ByVal nCount As Long, _
    pHandles As Long, _
    ByVal fWaitAll As Long, _
    ByVal dwMilliseconds As Long, _
    ByVal dwWakeMask As Long) As Long

Private Const WAIT_ABANDONED& = &H80&
Private Const WAIT_ABANDONED_0& = &H80&
Private Const WAIT_FAILED& = -1&
Private Const WAIT_IO_COMPLETION& = &HC0&
Private Const WAIT_OBJECT_0& = 0
Private Const WAIT_OBJECT_1& = 1
Private Const WAIT_TIMEOUT& = &H102&

Private Const INFINITE = &HFFFF ' Mikä on ajastimen timeout? - Ikuinen

' Ajastimen keskeytyssyy konstantit ja keskeytys asetukset
' Tällä voidaan asettaa ohjelma päättymään jos jotain tehdään -
' painetaan nappia tai jotain.
Private Const QS_HOTKEY& = &H80
Private Const QS_KEY& = &H1
Private Const QS_MOUSEBUTTON& = &H4
Private Const QS_MOUSEMOVE& = &H2
Private Const QS_PAINT& = &H20
Private Const QS_POSTMESSAGE& = &H8
Private Const QS_SENDMESSAGE& = &H40
Private Const QS_TIMER& = &H10
Private Const QS_MOUSE& = (QS_MOUSEMOVE _
                            Or QS_MOUSEBUTTON)
Private Const QS_INPUT& = (QS_MOUSE _
                            Or QS_KEY)
Private Const QS_ALLEVENTS& = (QS_INPUT _
                            Or QS_POSTMESSAGE _
                            Or QS_TIMER _
                            Or QS_PAINT _
                            Or QS_HOTKEY)
Private Const QS_ALLINPUT& = (QS_SENDMESSAGE _
                            Or QS_PAINT _
                            Or QS_TIMER _
                            Or QS_POSTMESSAGE _
                            Or QS_MOUSEBUTTON _
                            Or QS_MOUSEMOVE _
                            Or QS_HOTKEY _
                            Or QS_KEY)

' Ajastimen aika strukti
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private hTimer As Long  ' Ajastimen hanska julkisena
Private bOn As Boolean          ' Muuttuja, joka pitää ohjelman rullaamassa
'*******************************************************************************
'   MAIN - VB ohjelman käynnistävä ja ylläpitävä funktio
'*******************************************************************************
Sub Main()

    Dim iValitsin As Integer    ' Satunnaisluvusta luotava toiminnon valitsin
    Dim iRet As Integer         ' Yleinen jälleenkäytettävä paluuarvo muuttuja
    Dim iCounter As Integer     ' Yleinen jälleenkäytettävä laskurimuuttuja
    Dim ltime As Long           ' Odotettava aika sekunneissa - arvotaan satunnaisluvulla, jotain välillä 1-1000 sekuntia
    Dim strReturn As Long       ' mciSendString'in parametri muuttuja
    Dim lngReturn As Long       ' mciSendString'in paluuarvo muuttuja

    On Error Resume Next

    ' pidetään ohjelma käynnissä toistaiseksi
    bOn = True

    ' piilotetaan ohjelma
    App.TaskVisible = False

    ' Alustetaan satunnaisluku generaattori
    Randomize

    Do While bOn = True
        iValitsin = Int(Rnd(Now) * 7) + 1   ' Arvotaan satunnainen toiminto 1-8
        ltime = Int(Rnd(Now) * 999) + 1        ' Arvotaan satunnainen odotusaika 1-1000 sekuntia

        Select Case iValitsin
        Case 1
            ' Palauttaa tekstiboxin joka pyytää kahvia ja avaa cd-rommin kahvitelineeksi
            iRet = MessageBoxEx(0, "System needs a cup of coffee.", "Important notification!", MB_ICONHAND, 0)
            mciSendString "set CDAudio door open", vbNullString, 0, 0
            iRet = MessageBoxEx(0, "Free coffee cup holder contributed by Bill G!", "Important notification!", MB_ICONHAND, 0)
            Wait ltime
        Case 2
            ' Palauttaa herjan liian tahmeista sormista
            iRet = MessageBoxEx(0, "Error -4565: Too sticky fingers!", "Windows alert", MB_ICONHAND, 0)
            Wait ltime
        Case 3
            ' Palauttaa herjan järjestelmän kuumenemisesta ja avaa 3 kertaa cd-rommin luukkua ja kiittää.
            iRet = MessageBoxEx(0, "Error -77445: System heating! Cooling down - wait!", "Important!", MB_ICONHAND, 0)
            iCounter = 0
            Do While iCounter < 3
                DoEvents
                lngReturn = mciSendString("set CDAudio door open", strReturn, 127, 0)
                lngReturn = mciSendString("set CDAudio door closed", strReturn, 127, 0)
                iCounter = iCounter + 1
            Loop
            iRet = MessageBoxEx(0, "Thanks!", "Important!", MB_ICONHAND, 0)
            Wait ltime

        Case 4
            ' Soittaa nousevan ja laskevan piippiip melodian ja runoilee päälle.
            Beep 1000, 300
            Beep 1200, 300
            Beep 1400, 300
            Beep 1600, 300
            Beep 1800, 300
            Beep 2000, 600
            Beep 1800, 300
            Beep 1600, 300
            Beep 1400, 300
            Beep 1200, 300
            Beep 1000, 300
            iRet = MessageBoxEx(0, "Kello löi jo viisi, bugit kerätkää, Johan nyt on hiisi, onnistu ei tää...", "Tärkeä huomio!", MB_ICONHAND, 0)
            Wait ltime

        Case 5
            ' Väittää käyttäjän olevan homo ja jos käyttäjä sen myöntää yrittää sammuttaa koneen
            iRet = MessageBoxEx(0, "Malfunction in System user: Homosexual activity Suspected. Confirm?", "Notification", MB_YESNO, 0)
            If iRet = 6 Then
                iRet = MessageBoxEx(0, "Error in System user: Homosexual enviroment detected. Exiting...", "Notification", MB_ICONHAND, 0)
                bOn = False
                ExitWindowsEx EWX_LOGOFF, 0
            Else
                Wait ltime
            End If

        Case 6
            ' Avaa itsekseen teksturin
            Shell "notepad", vbNormalFocus
            Wait ltime

        Case 7
            ' Avaa explorer ikkunan (mikä se nyt onkaan suomeksi?)
            Shell "explorer", vbNormalFocus
            Wait ltime
        Case 8
            ' Vaihtaa hiiren painikkeita satunnaisesti 1-50 sekunnin välein
            ' Hermostuttaa käyttäjän varmasti ja aiheuttaa harmaita hiuksia tekniselle tuelle
            SwapMouseButton 1
            ltime = Int(Rnd(Now) * 50)
            Wait ltime
            SwapMouseButton 0
            ltime = Int(Rnd(Now) * 500)
            Wait ltime
            SwapMouseButton 1
            ltime = Int(Rnd(Now) * 50)
            Wait ltime
            SwapMouseButton 0
            ltime = Int(Rnd(Now) * 400)
            Wait ltime
            SwapMouseButton 1
            ltime = Int(Rnd(Now) * 50)
            Wait ltime
            SwapMouseButton 0
            ltime = Int(Rnd(Now) * 300)
            Wait ltime
            SwapMouseButton 1
            ltime = Int(Rnd(Now) * 50)
            Wait ltime
            SwapMouseButton 0
            ltime = Int(Rnd(Now) * 200)
            Wait ltime
            SwapMouseButton 1
            ltime = Int(Rnd(Now) * 50)
            Wait ltime
            SwapMouseButton 0
            ltime = Int(Rnd(Now) * 100)
            Wait ltime
            SwapMouseButton 1
            ltime = Int(Rnd(Now) * 50)
            Wait ltime
            SwapMouseButton 0
            ltime = Int(Rnd(Now) * 1000)
            Wait ltime
    End Select
    Loop

    CloseHandle hTimer  ' Suljetaan oikeaoppisesti ajastimen hanska

End Sub
'*****************************************************************
'   AJASTIN FUNKTIO
'   Kuvaus:         Odottava ajastin - ei syö prosessoriaikaa nimeksikään
'                   Oheinen koodi ei ole kokonaisuudessaan omaani vaan sama
'                   koodi löytyy useilta vinkki ja keskustelupalstoilta.
'
'                   Olen itse muokannut koodin sopivaksi tarkoitukseensa.
'                   Lisäksi olen kommentoinut koodin kunnolla ja kirjoittanut
'                   vaihtoehtoisia käyttötapoja koodiin. Lukekaa itse.
'
'   Käyttötapa:     Wait(Odotettava aika sekunneissa)
'*****************************************************************
Sub Wait(ByVal lNumberOfSeconds As Long)
    Dim ft As FILETIME          ' Aikastrukti
    Dim lBusy As Long           ' Muuttuja joka pitää odottavan ajastimen yllä odotusajan
    Dim lRet As Long            ' Yleisesti käytetty paluuarvo
    Dim dblDelay As Double
    Dim dblDelayLow As Double
    Dim dblUnits As Double

    ' Luodaan uusi ajastin - vähän ruma tapa -
    ' pitäisi mieluummin tutkia hanska ja sitten
    ' vasta yrittää luoda uusi. Tässä tapauksessa
    ' tutkitaan virhe ja sitten vasta avataan
    ' olemassa oleva ajastin.

    hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer")

    ' Tutkitaan virhe
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
        ' Jos ajastin on jo olemassa ei ole haitaksi vaikka se avataan
        ' niin kauan kuin käyttäjällä, joka sen tekee on riittävät oikeudet
        ' Tämä on tässä tapauksessa periaatteessa tarpeeton koska funktio voisi
        ' sulkea luodun ajastimen aina odotus ajan päätteeksi.

        '- Tällöin hTimer tulee määritellä julkiseksi: so. esitellä modulin alussa tämän funktion ulkopuolella.
        '- Tähän lisätään seuraavat rivit:
        lRet = OpenWaitableTimer(0, hTimer, App.EXEName & "Timer")
    Else
        ' Ei virheitä - tai muita virheitä - niistä välittämättä alustetaan ajastin
        ft.dwLowDateTime = -1
        ft.dwHighDateTime = -1
        lRet = SetWaitableTimer(hTimer, ft, 0, 0, 0, 0)
    End If

    ' Konvertoidaanpa odotusaika API:n ymmärtämiksi nanosekunneiksi
    dblUnits = CDbl(&H10000) * CDbl(&H10000)
    dblDelay = CDbl(lNumberOfSeconds) * 1000 * 10000

    ' Asettamalla high/low aika negatiiviseksi pyydetään ohjelmaa
    ' käyttämään "offset" aikaa kovakoodatun ajan sijasta. Jos se
    ' olisi positiivinen ohjelma yrittäisi konvertoida sen GMT-ajaksi.

    ft.dwHighDateTime = -CLng(dblDelay / dblUnits) - 1
    dblDelayLow = -dblUnits * (dblDelay / dblUnits - Fix(dblDelay / dblUnits))

    ' Koska &H80000000 on MAX_LONG, varmistetaan ettei synny ylivuotoa
    ' kun sitä yritetään sjoittaa FILETIME struktiin

    If dblDelayLow < CDbl(&H80000000) Then
        dblDelayLow = dblUnits + dblDelayLow
    End If

    ft.dwLowDateTime = CLng(dblDelayLow)
    lRet = SetWaitableTimer(hTimer, ft, 0, 0, 0, False)

    Do
        ' QS_ALLINPUT tarkoittaa, että MsgWaitForMultipleObjects palauttaa
        ' joka kerran kun säie, jossa se pyörii saa "viestin".
        ' Voit tässä käsitellä "eventtejä", mutta kutsumalla DoEvents sallit
        ' DefWindowProgin suorittaa sen normaali windowsin viestien käsittely.
        lBusy = MsgWaitForMultipleObjects(1, hTimer, False, INFINITE, QS_ALLINPUT&)
        DoEvents
    Loop Until lBusy = WAIT_OBJECT_0

    ' Sulje ajastimen hanska, mikäli ajastinta ei tulla käyttämään uudelleen lähiaikoina.
    ' Kommentoitu pois koska samaa ajastinta pyritään käyttämään uudelleen.
    'CloseHandle hTimer
End Sub