Dobrej pokec   Lišanská šlapka   MSDN   VB na Microsoft.cz   NCHAT Nový design
   Portál  O firmě  Profil  Reference  Produkty  Odkazy  Diskuse  Tisková verze 



  Novinky e-mailem
Pokud chcete být informováni o změnách ,přihlašte se k odběru novinek!
  
  
  Nejčtenější články
 Seznam všech českých hubů abecedně. (32255)
 Seznam hubů nad 100 uživatelů (20982)
 Konfigurovatelné rozbalovací menu (17602)
 Jak na makra (14426)
 Rozbalovací menu v JavaScriptu (2.) (12804)
  Nejstahovanější soubory
 Action Meter (1846)
 Slovní Fotbal (777)
 IE Boss Guard (484)
 zdroják slovní fotbal (383)
 Folder Watcher (370)
  Anketa

  Nabídka portálu

 Adobe Premiere
    Jak se dá udělat
 Alternativní prohlížeče
    FireFox
 ASP
    Tipy a triky
 Direct Connect
    Huby
    Scripty pro HUB
    Tipy a triky CZDC++
 Game Maker
    Tipy a triky
 Hry
    Akční
    Logické
 HTML
    Scripting (VBS,JS)
    Tipy a triky
 Internet
    Užitečné triky
 Microsoft Office
    Tipy, triky, návody
    Užitečná makra
    VBA Tipy a triky
 MS SQL Server
    Nastavení
    Seriály
    Tipy a triky
 Multimedia
    Návody
 Oracle
    PL/SQL
 PHP
    Jak na to
    Tipy a triky
 Užitečné odkazy
    Grafické programy
    Programátorské
 Visual Basic
    DirectX
    Formuláře
    Jak se dá udělat ...
    Užitečné funkce
    Win32Api
    Zdroje
 Visual Basic .NET
    Užitečné funkce
 Vtípky
    Vtipy a anekdnoty
 Vypalování
    DVD Shrink
    Tipy a triky
 Windows
    Jak se dá ...
    Tipy a triky pro XP
    Triky pro IE


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




Příspěvky ke článku:



© Swit.cz, Marek Kočí 2003