Keskustelu: Koodit: VB6: Aktiivisen ikkunan päällä istuva "maskotti"

Option Explicit

'Vakiot
'RegisterClass
Private Const CS_HREDRAW As Long = &H2&
Private Const CS_VREDRAW As Long = &H1&

'CreateWindow
Private Const WS_POPUP As Long = &H80000000
Private Const WS_VISIBLE As Long = &H10000000

'CreateWindowEx
Private Const WS_EX_LAYERED As Long = &H80000
Private Const WS_EX_TOOLWINDOW As Long = &H80&
Private Const WS_EX_TOPMOST As Long = &H8&
Private Const WS_EX_TRANSPARENT As Long = &H20&

'Viestit
Private Const WM_PAINT As Long = &HF&

'LoadImage
Private Const IMAGE_BITMAP As Long = 0&
Private Const LR_LOADFROMFILE As Long = &H10&

'SetLayeredWindowAttributes
Private Const LWA_COLORKEY As Long = &H1

'Tyypit
Private Type WNDCLASSEX
    cbSize As Long
    style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
    hIconSm As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MSG
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOhFileBits As Long
End Type

'Declaret
Private Declare Function RegisterClassEx Lib "user32.dll" Alias "RegisterClassExA" (ByRef pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function UnregisterClass Lib "user32.dll" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long

Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long

Private Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" (ByRef lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32.dll" (ByRef lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" (ByRef lpMsg As MSG) As Long

Private Declare Function LoadImage Lib "user32.dll" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) As Long

Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef lpPoint As POINTAPI) As Long

'Muuttujat
Dim BitmapWidth As Long         'Bittikartan leveys
Dim BitmapHeight As Long        'Bittikartan korkeus
Dim BitmapFile As String        'Bittikartan tiedostonimi (& polku)
Dim MascotWindowHandle As Long  'Kahva luotuun ikkunaan
Dim MascotWindowDC As Long      'Ikkunan device context
Dim BitmapHandle As Long        'Kahva bittikarttaan
Dim MemoryDC As Long            'Device context bittikartalle
Dim WindowLocation As RECT      'Aktiivisen ikkunan sijainti

Private Sub Main()
    Dim Message As MSG
    Dim FileHeader As BITMAPFILEHEADER
    Dim InfoHeader As BITMAPINFOHEADER

    'Asetetaan bittikartan polku
    BitmapFile = App.Path & "\suzuna.bmp"

    'Luetaan bittikartan headerit, joista saadaan selville sen koko
    Open BitmapFile For Binary Access Read As #1
    Get #1, , FileHeader
    Get #1, , InfoHeader
    Close #1

    BitmapWidth = InfoHeader.biWidth
    BitmapHeight = InfoHeader.biHeight

    'Yritetään rekisteröidä ikkunan luokka
    If Not RegisterWindowClass Then
        MsgBox "Failed to register window class", vbCritical
        Terminate
    End If

    'Yritetään luoda ikkuna
    If Not CreateMascotWindow Then
        MsgBox "Failed to create the window", vbCritical
        Terminate
    End If

    'Tehdään magentasta (255, 0, 255) läpinäkyvä väri
    Call SetLayeredWindowAttributes(MascotWindowHandle, RGB(255, 0, 255), 255&, LWA_COLORKEY)

    'Otetaan selville vastaluodun ikkunan device context
    MascotWindowDC = GetWindowDC(MascotWindowHandle)

    'Yritetään ladata bittikartta
    If Not LoadBitmap Then
        MsgBox "Failed to load " & BitmapFile, vbCritical
        Terminate
    End If

    'Luodaan muistiin device context, johon bittikartta voidaan valita
    MemoryDC = CreateCompatibleDC(ByVal 0&)

    If SelectObject(MemoryDC, BitmapHandle) = 0 Then
        MsgBox "Failed to select bitmap to memory DC", vbCritical
        Terminate
    End If

    'Luodaan ajastin
    Call SetTimer(MascotWindowHandle, 1&, 75&, AddressOf TimerProc)

    'Message looppi pyörii niin kauan, kuin aiemmin luotu ikkuna on olemassa (=koko ohjelman päälläolon ajan)
    Do While 0 <> GetMessage(Message, 0&, 0&, 0&)
        Call TranslateMessage(Message)
        Call DispatchMessage(Message)
        DoEvents
    Loop

    End
End Sub

'Tuhoaa kaikken muistissa olevan tavaran ja sulkee ohjelman
Private Sub Terminate()
    'Tuhotaan muistissa oleva DC
    Call DeleteDC(MemoryDC)

    'Tuhotaan bittikartta
    Call DeleteObject(BitmapHandle)

    'Tuhotaan ajastin
    Call KillTimer(MascotWindowHandle, 1&)

    'Tuhotaan ikkuna
    Call DestroyWindow(MascotWindowHandle)

    'Poistetaan ikkunaluokan rekisteröinti
    Call UnregisterClass("mascotwindow", App.hInstance)

    'Lopetetaan ohjelma
    End
End Sub

'Rekisteröi luokan "mascotwindow"
Private Function RegisterWindowClass() As Boolean
    Dim ClsDescriptor As WNDCLASSEX

    'Täytetään structi
    With ClsDescriptor
        .cbSize = Len(ClsDescriptor)
        .style = CS_HREDRAW + CS_VREDRAW
        .hInstance = App.hInstance
        'VB ei hyväksy tähän suoraan tuota AddressOfia, vaan se pitää kierrättää funktion kautta
        .lpfnWndProc = ReturnParam(AddressOf WindowProc)
        .lpszClassName = "mascotwindow"
    End With

    'Suoritetaan rekisteröinti ja palautetaan true tai false
    RegisterWindowClass = (RegisterClassEx(ClsDescriptor) <> 0&)
End Function

'Luo ikkunan, jossa "maskotti" näytetään
Private Function CreateMascotWindow() As Boolean
    'Luodaan layeroitu, reunaton, otsikkopalkiton, läpinäkyvä ikkuna luokkaa "mascotwindow"
    'Kooksi laitetaan bittikartan koko ja ikkuna asetetaan piiloon ruudun ulkopuolelle
    MascotWindowHandle = CreateWindowEx(WS_EX_LAYERED Or WS_EX_TOOLWINDOW Or WS_EX_TOPMOST Or WS_EX_TRANSPARENT, "mascotwindow", "Mascot", WS_VISIBLE Or WS_POPUP, -BitmapWidth, -BitmapHeight, BitmapWidth, BitmapHeight, 0&, 0&, App.hInstance, ByVal 0&)
    'Palautetaan true tai false
    CreateMascotWindow = (MascotWindowHandle <> 0&)
End Function

'Lataa bittikartan muistiin
Private Function LoadBitmap() As Boolean
    BitmapHandle = LoadImage(ByVal 0&, BitmapFile, IMAGE_BITMAP, BitmapWidth, BitmapHeight, LR_LOADFROMFILE)
    LoadBitmap = (BitmapHandle <> 0&)
End Function

'Palauttaa parametriksi annetun arvon. Käytetään ohittamaan VB:n bugi (ks. yllä)
Private Function ReturnParam(Param As Long) As Long
    ReturnParam = Param
End Function

'WindowProc -callback funktio
'Windows kutsuu tätä aina, kun ikkunallemme tapahtuu jotain oleellista
Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'Otetaan selvää, minkä viestin Windows lähetti
    Select Case wMsg
        Case WM_PAINT
            'WM_PAINT käskee ikkunaa (uudelleen)piirtämään itsensä, joten teemme työtä käskettyä ja piirrämme bittikartan ikkunaan
            Call BitBlt(MascotWindowDC, 0&, 0&, BitmapWidth, BitmapHeight, MemoryDC, 0&, 0&, vbSrcCopy)
    End Select
    'Jotta kaikkia viestejä ei tarvitse itse käsitellä, ohjaamme käsittelyn oletusikkunaproseduurille
    WindowProc = DefWindowProc(ByVal hwnd, ByVal wMsg, ByVal wParam, ByVal lParam)
End Function

'TimerProc callback-funktio
'Sub Mainissa luomamme ajastin kutsuu tätä 75 millisekunnin välein
Public Function TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
    Dim CursorLocation As POINTAPI

    'Katsotaan, onko hiiren oikeaa nappia painettu viime kerran jälkeen
    If GetAsyncKeyState(vbKeyRButton) <> 0& Then
        'Jos on, niin katsomme, onko kursori ikkunamme kohdalla, ja mikäli näin on, kysymme, haluaako käyttäjä lopettaa ohjelman
        Call GetCursorPos(CursorLocation)
        If CursorLocation.x > WindowLocation.Left + CLng(0.9 * (WindowLocation.Right - WindowLocation.Left - BitmapWidth)) _
        And CursorLocation.x < WindowLocation.Left + CLng(0.9 * (WindowLocation.Right - WindowLocation.Left - BitmapWidth)) + BitmapWidth _
        And CursorLocation.y > WindowLocation.Top - BitmapHeight _
        And CursorLocation.y < WindowLocation.Top Then
            If MsgBox("Wanna quit?", vbQuestion + vbYesNo) = vbYes Then Terminate
        End If
    End If

    'Otetaan selville aktiivisen ikkunan paikka
    Call GetWindowRect(GetForegroundWindow, WindowLocation)
    'Siirretään maskotti-ikkunamme istumaan tuon aktiivisen ikkunan päälle
    Call MoveWindow(MascotWindowHandle, WindowLocation.Left + CLng(0.9 * (WindowLocation.Right - WindowLocation.Left - BitmapWidth)), WindowLocation.Top - BitmapHeight, BitmapWidth, BitmapHeight, True)
End Function