Opasarkisto: Visual Basic: 2D:tä DirectX8:lla

Dim DX As DirectX8
Dim D3D As Direct3D8
Dim D3DX As D3DX8
Dim D3DDevice As Direct3DDevice8
Dim D3DSprite As D3DXSprite
Dim D3DCaps As D3DCAPS8
Dim D3DDispMode As D3DDISPLAYMODE
Dim D3DPP As D3DPRESENT_PARAMETERS

Private Function InitialisoiD3D(ByVal hWnd As Long, _
Optional ByVal Ikkunassa As Boolean) As Long
   Dim DevType As CONST_D3DDEVTYPE

   'Käsittelemme virheemme itse
   On Local Error Resume Next

   'Luodaan uusi DirectX8 -objekti
   Set DX = New DirectX8
   'Tarkistetaan, onnistuiko luominen
   If Err.Number Then
       'Palautetaan virhenumero ja lopetetaan
       InitialisoiD3D = Err.Number
       Exit Function
   End If

   'Luodaan uusi D3D -objekti
   Set D3D = DX.Direct3DCreate
   'Tarkistetaan jälleen, onnistuiko sen luominen
   If Err.Number Then
       InitialisoiD3D = Err.Number
       Exit Function
   End If

   'Aloitetaan laitteen luominen
   'Oletuksena sörkimme laitteistokiihdytettyä laitetta
   '(HAL = Hardware Acceleration Layer)
   DevType = D3DDEVTYPE_HAL

   'Selvitetään, mihin kivaan näytönohjain kykenee
   'Jätämme toissijaiset adapterit toistaiseksi rauhaan
   D3D.GetDeviceCaps D3DADAPTER_DEFAULT, DevType, D3DCaps

   'Jos virheitä ilmeni, näytönohjain ja/tai sen ajuri ei tue vähintään
   'DX7:ää
   If Err.Number Then
       Err.Clear
       'Koitetaan tutkiskella referenssilaitetta HAL:n sijasta
       DevType = D3DDEVTYPE_REF
       D3D.GetDeviceCaps D3DADAPTER_DEFAULT, DevType, D3DCaps

       If Err.Number Then
           'Jos GetDeviceCaps yhä palauttaa virheen, ei
           'laitteisto tue DirectX:ää ja ohjelman suorittaminen
           'ei voi jatkua
           'Palautetaan virhenumero ja poistutaan funktiosta
           InitialisoiD3D = Err.Number
           Exit Function
       End If
   End If

   'Tiedot on saatu, aloitetaan näyttötilan konfigurointi
   If Ikkunassa Then
       'Hankitaan tietoa tämänhetkisestä näyttötilasta
       D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, D3DDispMode
       'Lopetetaan, jos käytössä on 256 värin näyttötila
       If D3DDispMode.Format = D3DFMT_P8 Or D3DDispMode.Format = _
       D3DFMT_A8P8 Then
           InitialisoiD3D = D3DERR_INVALIDDEVICE
           Exit Function
       End If

       With D3DPP
           'Kerrotaan, että ohjelmaa ajetaan ikkunassa
           .Windowed = 1
           'Asetetaan takapuskurin muoto samaksi, kuin
           'näyttöpuskurin
           .BackBufferFormat = D3DDispMode.Format
           'Asetetaan takapuskurin koko
           'Koko on toki vapaasti valittavissa, esimerkissä
           'käytämme 640x480 kokoista ikkunaa
           .BackBufferWidth = 640
           .BackBufferHeight = 480
           'Kommentoi pois jälkimmäinen rivi,jos et halua VSynciä
           .SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
           '.SwapEffect = D3DSWAPEFFECT_DISCARD
       End With
   Else
       With D3DDispMode
           'Asetetaan näyttötilan koko
           .Width = 640
           .Height = 480
           'Asetetaan näyttötilan värisyvyys
           '32-bittinen tila kahdeksan bitin alfakanavalla
           .Format = D3DFMT_A8R8G8B8
           'Muita hyviä vaihtoehtoja ovat esim.
           'Sama ilman alfakanavaa
           '.Format = D3DFMT_R8G8B8
           '16-bittinen tila kahdeksan bitin alfalla
           '.Format = D3DFMT_A8R3G3B2
           '16-bittinen tila ilman alfaa
           '.Format = D3DFMT_R5G6B5
           'jne.
       End With
       With D3DPP
           'Kerrotaan, että ohjelmaa ajetaan kokonäytössä
           .Windowed = 0
           'Asetetaan takapuskurin muoto samaksi, kuin
           'näyttöpuskurin
           .BackBufferFormat = D3DDispMode.Format
           'Asetetaan takapuskurin koko
           .BackBufferWidth = D3DDispMode.Width
           .BackBufferHeight = D3DDispMode.Height
           'Takapuskureiden lukumäärä
           '1 = tuplapuskurointi, 2 = triplapuskurointi jne.
           .BackBufferCount = 1
           'Kerrotaan, mikä ikkuna kokonäyttöön venytetään
           .hDeviceWindow = hWnd
           .SwapEffect = D3DSWAPEFFECT_FLIP
       End With
   End If

   'Kaikki on asetettu, luodaan laite
   Set D3DDevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, _
   hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, D3DPP)
   'Tarkistetaan, onnistuiko laitteen luominen
   If Err.Number Then
       Err.Clear
       'Koitetaan luoda referenssilaite
       Set D3DDevice = D3D.CreateDevice(D3DADAPTER_DEFAULT, _
       D3DDEVTYPE_REF, hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, _
       D3DPP)
       'Mikäli sekin epäonnistuu, palautetaan virhe ja lopetetaan
       If Err.Number Then
           InitialisoiD3D = Err.Number
           Exit Function
       End If
   End If

   'Luodaan apukirjasto D3DX
   Set D3DX = New D3DX8
   If Err.Number Then
       InitialisoiD3D = Err.Number
       Exit Function
   End If

   'Ja lopuksi vielä Sprite-objekti, joka mahdollistaa (muun muassa)
   'helpon bittikarttojen piirtämisen näytölle
   Set D3DSprite = D3DX.CreateSprite(D3DDevice)
   If Err.Number Then
       InitialisoiD3D = Err.Number
       Exit Function
   End If
End Function

If InitialisoiD3D(Me.hWnd, True) Then
   MsgBox "Direct3D:n alustaminen epäonnistui. Ohjelma lopetetaan."
   End
End If

Private Sub TerminoiD3D()
   'Jos objektien luominen epäonnistui, niiden vapauttaminen saattaa
   'aiheuttaa virheen
   'Tässä vaiheessa olemme kuitenkin jo lopettamassa ohjelmaa, jolloin
   'virheenkäsittelyllä ei ole suurempaa merkitystä
   On Error Resume Next

   Set D3DSprite = Nothing
   Set D3DX = Nothing
   Set D3DDevice = Nothing
   Set D3D = Nothing
   Set DX = Nothing
End Sub

Private Sub Form_Load()
   Kaynnissa = True

   With Me
       'Normaalisti lomake näyttäytyy vasta, kun Form_Load on
       'lopettanut, siinä vaiheessa tämä ohjelma on kuitenkin jo
       'lopettanut, joten näytetään lomake nyt
       .Show
       'Asetetaan käytettäväksi yksiköksi pikselit
       .ScaleMode = 3
       'Seuraavaksi muutetaan lomake sopivan kokoiseksi
       .Width = .ScaleX(640, vbPixels, vbTwips)
       .Height = .ScaleY(480, vbPixels, vbTwips)
   End With

   'Jos alustaminen epäonnistuu, aloitetaan ohjelman sulkeminen
   If InitialisoiD3D(Me.hWnd, True) Then
       MsgBox "Direct3D:n alustaminen epäonnistui."
       Kaynnissa = False
   End If

   LataaTekstuurit

   'Pääsilmukka
   Do While Kaynnissa
       'Suoritetaan piirtäminen
       'Tässä välissä suoritetaan myös kaikki muu pelimekaniikkaan
       'liittyvä, esim. fysiikanmallinnus
       Piirra

       'Annetaan Windowsille aikaa miettiä
       DoEvents
   Loop

   TerminoiD3D
   End
End Sub

Dim Tekstuuri As Direct3DTexture8

Private Sub LataaTekstuurit()
   Set Tekstuuri = D3DX.CreateTextureFromFileEx(D3DDevice, App.Path & _
   "\tutorial.bmp", D3DX_DEFAULT, D3DX_DEFAULT, 1, 0, D3DFMT_UNKNOWN, _
   D3DPOOL_MANAGED, D3DX_FILTER_NONE, D3DX_FILTER_NONE, 0, ByVal 0, _
   ByVal 0)
End Sub

Private Sub Piirra()
   Dim SourceRect As RECT
   Dim Scaling As D3DVECTOR2
   Dim RotationCenter As D3DVECTOR2
   Dim Rotation As Single
   Dim Translation As D3DVECTOR2
   Dim Color As Long

   'Alustetaan muuttujat
   'SourceRect määrittää, minkä osan tekstuurista haluamme piirtää
   'Koko tekstuurin voi piirtää antamalle Draw:lle parametrina RECT:n
   'sijasta arvon ByVal 0, mutta täytämme RECT:n kuitenkin mallin vuoksi
   With SourceRect
       .bottom = 480
       .Left = 0
       .Right = 640
       .Top = 0
   End With
   'Kuvan kokoa voi muuttaa vaihtamalla Scalingin arvoja
   'Nyt haluamme kuvan kuitenkin 1:1 koossa
   Scaling.X = 1
   Scaling.Y = 1
   'Kuvaa voi pyörittää seuraavia arvoja muokkaamalla
   'Piirrämme kuvan nyt kuitenkin suorassa
   RotationCenter.X = 0.5
   RotationCenter.Y = 0.5
   Rotation = 0
   'Translation tarkoittaa kuvan paikkaa ruudulla
   'Piirrämme sen nyt piirtoalueen vasempaan ylänurkkaan
   Translation.X = 0
   Translation.Y = 0
   'Color on Draw -metodin parametreistä mielenkiintoisin, sen avulla
   'piirrettyä kuvaa voi sävyttää
   'Asettamalla Color:n valkoiseksi kuva toistuu alkuperäisen värisenä
   'Ensimmäiset kaksi F:ää ovat jälleen alfakanava, sen arvoa
   'pienentämällä kuvasta saa semi-läpinäkyvän
   'Eksperimentoi erilaisilla Color:n arvoilla
   Color = &HFFFFFFFF

   'Aloitetaan tyhjentämällä piirtoalue
   'Neljäs parametri on väri, jolla tyhjennetty alue täytetään,
   'esimerkissämme musta
   D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET, 0, 1#, 0

   'Kaikki piirtäminen pitää tapahtua BeginScenen ja EndScenen välissä
   D3DDevice.BeginScene
   D3DSprite.Begin
   D3DSprite.Draw Tekstuuri, SourceRect, Scaling, RotationCenter, _
   Rotation, Translation, Color
   D3DSprite.End
   D3DDevice.EndScene

   'Kaikki piirto tapahtuu takapuskuriin, nyt vaihdetaan taka- ja
   'näyttöpuskurin paikkaa ja tuodaan
   'vastapiirretty kuva esille
   'DirectX7 -veteraanit tunnistanevat tässä Surface.Flip:n
   D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
   If KeyCode = vbKeyEscape Then Kaynnissa = False
End Sub

Dim PalautusArvo As Long

'Käsittelemme virheemme jälleen itse
On Local Error Resume Next

'Selvitetään, missä tilassa laite on
PalautusArvo = D3DDevice.TestCooperativeLevel
If PalautusArvo = D3DERR_DEVICELOST Then
   'D3DERR_DEVICELOST tarkoittaa, että ohjelma ei ole aktiivinen -
   'piirtämistä on turha yrittää
   Exit Sub
ElseIf PalautusArvo = D3DERR_DEVICENOTRESET Then
   'DEVICENOTRESET tarkoittaa, että ohjelma on juuri muuttunut
   'aktiiviseksi, mutta laitetta ei ole vielä palautettu - palautetaan se
   PalautusArvo = 0
   PalautusArvo = PalautaLaite

   'Jos laitteen palauttaminen epäonnistui poistutaan aliohjelmasta
   If PalautusArvo Then Exit Sub
End If

'Poistutaan aliohjelmasta, jos ikkuna on pienennetty
If Me.WindowState = vbMinimized Then Exit SubPrivate Function PalautaLaite() As Long
   On Local Error Resume Next

   'Tuhotaan D3D, alustetaan se uudelleen ja lopuksi kutsutaan
   'D3DDevice:n Reset -metodia
   TerminoiD3D
   InitialisoiD3D Me.hWnd, True
   D3DDevice.Reset D3DPP

   If Err.Number Then
       PalautaLaite = Err.Number
       Exit Function
   End If

   'Resetointi tuhoaa tekstuurit, ladataan ne uudelleen
   LataaTekstuurit
End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   Kaynnissa = False
   Cancel = 1
End Sub