Nabídka portálu se při zobrazení článku přesouvá na konec pravého sloupce nabídek.
Programování pod DirectX ve VB (2.) |
Autor: Kočí Marek
| Zdroj:
| Vytvořeno: 10.1.2003
| Publikováno: 10.1.2003
| Čtenářů: 3121
| Unikátních: 3050
|
Další příklad použití DIrectX ve Visual Basicu. Dnes ukázka pohybu obrázku.
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
Do projektu přidejte další formulář a pojmenujte ho frmMain.
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
|