Programování pod DirectX ve VB (2.)

V minulém díle jsme otestovali, zda systém podporuje naše rozlišení DirectX. Dnes si nahrajeme grafiku a pokusíme se definovat pokyb.

Do projektu, který jsme vytvořili minule, vložte do kódu tlačítka start (Command2_Click) řádek:

  frmMain.show

Nyní nastavte vlastnosti formuláře frmMain takto:

BorderStyle	0 - None
BackColor	&H00000000&
ScaleMode	3 - Pixel

Do kódu formuláře vložte následující kód.

  Option Explicit

  Private Sub Form_Load()
    SprX = 350
    SprY = 250
    'Zruší testovaci form z pameti
    Unload Form1 
    'Smycka pro hru
    MainLoop
  End Sub

Nyní si připravte jeden obrázek BG.BMP (TrueColor) v rozlišení 800x600, použijeme ho jako pozadí. Doporučuji u obrázku pozadí nepoužívat barvu s RGB(0,0,0). Dále si připravte obrázek SPR.BMP velikosti 100x100 jako objekt, s kterým budeme pohybovat. Obrázek 100x100 musí mít jako pozadí barvu s RGB(0,0,0), ta bude při vykreslování vynechávána. Obrázky vložte do stejného adresáře s projektem, do podadresáře Images.
Máte-li již obrázky připravené, můžeme začít programovat.

Nejprve přidejte jeden modul do projektu a nazvěte ho mGraph. Do něho vložte následující kód.

Public ddsBG As DirectDrawSurface7
Public ddsdBG As DDSURFACEDESC2
Public rectBG As RECT

Public ddsSpr As DirectDrawSurface7
Public ddsdSpr As DDSURFACEDESC2
Public rectSpr As RECT

Sub InitGraphics()
    CreateGraphicsFromFile "bg", ddsBG, ddsdBG, 800, 600
    CreateGraphicsFromFile "spr", ddsSpr, ddsdSpr, 100, 100
End Sub

Sub CreateGraphicsFromFile(fName As String, _
    dds As DirectDrawSurface7, _
    ddsd As DDSURFACEDESC2, _
    ddsdWidth As Integer, ddsdHeight As Integer)
  On Error GoTo errCreateGraphicsFromFile
  fName = App.Path & "images" & _
          fName & ".bmp"

  ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  ddsd.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  ddsd.lHeight = ddsdHeight
  ddsd.lWidth = ddsdWidth

  Set dds = dd.CreateSurfaceFromFile(fName, ddsd)

  'Pro transparentnost obrázku
  Dim ColorKey As DDCOLORKEY
    ColorKey.high = 0
    ColorKey.low = 0
    Call dds.SetColorKey(DDCKEY_SRCBLT, ColorKey)

  Exit Sub
errCreateGraphicsFromFile:
    MsgBox "Grafika nebyla nactena"
    EndGame
End Sub

Přidejte další modul do projektu a nazvěte ho mMain. Do něho vložte následující kód.

Option Explicit

Public exitprogram As Boolean
Public dx As New DirectX7
Public dd As DirectDraw7
Public di As DirectInput
Public diKeyBoard As DirectInputDevice
Public KeyboardState As DIKEYBOARDSTATE
Public dmLoader As DirectMusicLoader
Public dmPerformance As DirectMusicPerformance

Public Const ScreenCurW As Integer = 800
Public Const ScreenCurH As Integer = 600
Public Const ScreenCurBPP As Integer = 32
Public Const Step As Integer = 5

Public bRestore As Boolean


Public ddsFrontBuf As DirectDrawSurface7
Public ddsdFrontBuf As DDSURFACEDESC2
Public ddsBackBuf As DirectDrawSurface7
Public ddsdBackBuf As DDSURFACEDESC2

Public SprX As Integer, SprY As Integer

Public Declare Function ShowCursor _
              Lib "user32" _
      (ByVal bShow As Long) As Long
      
Public Const ChosenRes As String = "800x600"

Sub CreateLoaderPerformance(Hdl As Long)
   Set dmLoader = dx.DirectMusicLoaderCreate
   Set dmPerformance = dx.DirectMusicPerformanceCreate
   Call dmPerformance.Init(Nothing, Hdl)
   Call dmPerformance.SetPort(-1, 1)
End Sub

Sub InitDI()
   Set di = dx.DirectInputCreate
   Set diKeyBoard = di.CreateDevice("GUID_SysKeyboard")
   diKeyBoard.SetCommonDataFormat DIFORMAT_KEYBOARD
   diKeyBoard.SetCooperativeLevel frmMain.hWnd, _
           DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
End Sub

Sub InitDX()
  On Error GoTo errInitDX
  Set dd = dx.DirectDrawCreate("")
  Exit Sub
errInitDX:
   MsgBox "DirectX nezinicializován"
   EndGame
End Sub

Sub SetCoopLevel(fhWnd As Form)
On Error GoTo errSetCoopLevel
   Call dd.SetCooperativeLevel(fhWnd.hWnd, _
          DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN _
          Or DDSCL_ALLOWMODEX)
   Exit Sub
errSetCoopLevel:
   MsgBox "Set Cooperative Level"
   EndGame
End Sub

Sub MainLoop()
   exitprogram = True
   InitDX
   InitDI
   'LoadSounds
   CreateLoaderPerformance frmMain.hWnd
   SetCoopLevel frmMain
   SetDisplay ScreenCurW, ScreenCurH, ScreenCurBPP

   CreateFrontBackBuf
   mGraph.InitGraphics

   'hides the cursor
   ShowCursor False
   exitprogram = False
   Do
       DoEvents
       MainScreen
   Loop Until exitprogram = True
   'StopSounds
   EndGame
End Sub

Sub SetDisplay(w As Integer, h As Integer, _
              bpp As Integer)
On Error GoTo errSetDisplay
   Call dd.SetDisplayMode(w, h, bpp, _
                          0, DDSDM_DEFAULT)
   Exit Sub
errSetDisplay:
   MsgBox "Display Mod nenastaven"
   EndGame
End Sub

Sub MainScreen()
On Error GoTo errMainScreen

Dim mGoUp As Boolean, mGoDown As Boolean
Dim mGoLeft As Boolean, mGoRight As Boolean

Dim EnterPress As Boolean
Dim Myexitprogram As Boolean
   DoEvents

   diKeyBoard.Acquire
   Call dmPerformance.Stop(Nothing, Nothing, 0, 0)
   diKeyBoard.GetDeviceStateKeyboard KeyboardState
   If KeyboardState.Key(DIK_ESCAPE) <> 0 Then
        exitprogram = True
   End If

   diKeyBoard.Unacquire
   diKeyBoard.Acquire

   If KeyboardState.Key(DIK_ESCAPE) <> 0 Then
      Myexitprogram = True
   End If
   If KeyboardState.Key(DIK_RETURN) <> 0 Then
      EnterPress = True
   End If
   If KeyboardState.Key(DIK_UP) <> 0 Then
      mGoDown = False: mGoUp = True
   End If
   If KeyboardState.Key(DIK_DOWN) <> 0 Then
     mGoUp = False: mGoDown = True
   End If
   If KeyboardState.Key(DIK_LEFT) <> 0 Then
     mGoLeft = False: mGoLeft = True
   End If
   If KeyboardState.Key(DIK_RIGHT) <> 0 Then
     mGoRight = False: mGoRight = True
   End If
       
   If mGoUp = True Then
     SprY = SprY - Step
   ElseIf mGoDown = True Then
     SprY = SprY + Step
   ElseIf mGoLeft = True Then
     SprX = SprX - Step
   ElseIf mGoRight = True Then
     SprX = SprX + Step
   End If
   CreateBG ddsBG
   BltFast 0, 0, 100, 100, ddsSpr, rectSpr, _
           SprX, SprY, True
   DoEvents
   
   ddsBackBuf.DrawText ScreenCurW - 250, _
                       ScreenCurH - 30, _
                       "ESC pro Konec", False
   ddsFrontBuf.Flip Nothing, DDFLIP_WAIT
   Exit Sub
errMainScreen:
   MsgBox "Chyba :" & Err.Description
   EndGame
End Sub

Sub BltFast(rTop As Integer, rLeft As Integer, _
           Width As Integer, Height As Integer, _
           dds As DirectDrawSurface7, _
           srcRect As RECT, X As Integer, _
           Y As Integer, Transparency As Boolean)
On Error GoTo errBltFast
   DoUntilReady
   With srcRect
     .Top = rTop
     .Left = rLeft
     .Right = Width
     .Bottom = Height
   End With
   If Transparency = False Then
       Call ddsBackBuf.BltFast(X, Y, _
                    dds, srcRect, DDBLTFAST_WAIT)
   Else
       Call ddsBackBuf.BltFast(X, Y, dds, srcRect, _
       DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY)
   End If
   Exit Sub
errBltFast:
   MsgBox "Grafika selhala"
   EndGame
End Sub
Sub EndGame()
   DestroyDX
   ShowCursor True
   Unload frmMain
   End
End Sub

Sub CreateBG(dds As DirectDrawSurface7)
On Error GoTo errRenderMap

Dim r As RECT, retVal As Long
 retVal = ddsBackBuf.BltFast(0, 0, dds, _
 r, DDBLTFAST_WAIT)
Exit Sub
errRenderMap:
   MsgBox "Vykresleni selhalo"
   EndGame
End Sub

Sub CreateFrontBackBuf()
On Error GoTo errCreateFrontBackBuf

  ddsdBackBuf.lFlags = DDSD_CAPS Or _
                       DDSD_BACKBUFFERCOUNT
  ddsdBackBuf.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE _
                    Or DDSCAPS_COMPLEX Or DDSCAPS_FLIP
  ddsdBackBuf.lBackBufferCount = 1
  Set ddsFrontBuf = dd.CreateSurface(ddsdBackBuf)

  Dim caps As DDSCAPS2
  caps.lCaps = DDSCAPS_BACKBUFFER
  Set ddsBackBuf = ddsFrontBuf.GetAttachedSurface(caps)
  Exit Sub

errCreateFrontBackBuf:
  MsgBox "Create Front and Back Buffer"
  EndGame
End Sub

Sub DoUntilReady()
  Dim bRest As Boolean

  bRest = False
  Do Until InDxMode
      DoEvents
      bRest = True
  Loop

  DoEvents
  If bRest Then
      bRest = False
      dd.RestoreAllSurfaces
  End If
End Sub

Sub DestroyDX()
  Set ddsBG = Nothing
  Set ddsSpr = Nothing
  Set diKeyBoard = Nothing
  Set dmPerformance = Nothing
  Set dmLoader = Nothing
  Set di = Nothing
  Set dd = Nothing
  Set dx = Nothing
End Sub

Function InDxMode() As Boolean
  Dim TestCoopLevel As Long
  TestCoopLevel = dd.TestCooperativeLevel
  If (TestCoopLevel = DD_OK) Then
    InDxMode = True
  Else
    InDxMode = False
  End If
End Function

Tak jsme hotovi, v příštím díle přidáme zvuk a poté zkonfortníme ovládání. Demo přerušíte stiskem ESC