home *** CD-ROM | disk | FTP | other *** search
/ Microsoft DirectX SDK 7.0 / Dx7.bin / DXF / samples / multimedia / vbsamples / ddraw / src / tutorial4 / ddtut4.frm (.txt) next >
Encoding:
Visual Basic Form  |  1999-08-04  |  7.4 KB  |  227 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    BorderStyle     =   0  'None
  4.    Caption         =   "DD Animation"
  5.    ClientHeight    =   5625
  6.    ClientLeft      =   2355
  7.    ClientTop       =   1620
  8.    ClientWidth     =   7065
  9.    Icon            =   "DDtut4.frx":0000
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   375
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   471
  14.    ShowInTaskbar   =   1  'True
  15. Attribute VB_Name = "Form1"
  16. Attribute VB_GlobalNameSpace = False
  17. Attribute VB_Creatable = False
  18. Attribute VB_PredeclaredId = True
  19. Attribute VB_Exposed = False
  20. Option Explicit
  21. Dim binit As Boolean
  22. 'NOTE THIS SAMPLES SHOWS HOW TO BLIT TO AREAS OF THE SCREEN
  23. Dim dx As New DirectX7
  24. Dim dd As DirectDraw7
  25. Dim lakesurf As DirectDrawSurface7
  26. Dim spritesurf As DirectDrawSurface7
  27. Dim primary As DirectDrawSurface7
  28. Dim backbuffer As DirectDrawSurface7
  29. Dim ddsd1 As DDSURFACEDESC2
  30. Dim ddsd2 As DDSURFACEDESC2
  31. Dim ddsd3 As DDSURFACEDESC2
  32. Dim ddsd4 As DDSURFACEDESC2
  33. Dim spriteWidth As Integer
  34. Dim spriteHeight As Integer
  35. Dim cols As Integer
  36. Dim rows As Integer
  37. Dim row As Integer
  38. Dim col As Integer
  39. Dim currentFrame As Integer
  40. Dim brunning As Boolean
  41. Dim CurModeActiveStatus As Boolean
  42. Dim bRestore As Boolean
  43. Sub Init()
  44.     On Local Error GoTo errOut
  45.     Dim file As String
  46.     Set dd = dx.DirectDrawCreate("")
  47.     Me.Show
  48.     'indicate that we dont need to change display depth
  49.     Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
  50.     Call dd.SetDisplayMode(640, 480, 16, 0, DDSDM_DEFAULT)
  51.         
  52.     'get the screen surface and create a back buffer too
  53.     ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  54.     ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
  55.     ddsd1.lBackBufferCount = 1
  56.     Set primary = dd.CreateSurface(ddsd1)
  57.     'Get the backbuffer
  58.     Dim caps As DDSCAPS2
  59.     caps.lCaps = DDSCAPS_BACKBUFFER
  60.     Set backbuffer = primary.GetAttachedSurface(caps)
  61.     backbuffer.GetSurfaceDesc ddsd4
  62.          
  63.     'Create DrawableSurface class form backbuffer
  64.     backbuffer.SetFontTransparency True
  65.     backbuffer.SetForeColor vbGreen
  66.          
  67.     ' init the surfaces
  68.     InitSurfaces
  69.                                                   
  70.     binit = True
  71.     brunning = True
  72.     Do While brunning
  73.         blt
  74.         DoEvents
  75.     Loop
  76. errOut:
  77.     EndIt
  78. End Sub
  79. Sub InitSurfaces()
  80.     Set lakesurf = Nothing
  81.     Set spritesurf = Nothing
  82.     FindMediaDir "lake.bmp"
  83.     'load the bitmap into a surface - lake
  84.     ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  85.     ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  86.     ddsd2.lWidth = ddsd4.lWidth
  87.     ddsd2.lHeight = ddsd4.lHeight
  88.     Set lakesurf = dd.CreateSurfaceFromFile("lake.bmp", ddsd2)
  89.                         
  90.                                                                         
  91.     'load the bitmap into a surface - donuts
  92.     'this bitmap has many frames of animation
  93.     'each is 64 by 64 in layed out in cols x rows
  94.     ddsd3.lFlags = DDSD_CAPS
  95.     ddsd3.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  96.     Set spritesurf = dd.CreateSurfaceFromFile("donut.bmp ", ddsd3)
  97.     spriteWidth = 64
  98.     spriteHeight = 64
  99.     cols = ddsd3.lWidth / spriteWidth
  100.     rows = ddsd3.lHeight / spriteHeight
  101.     'use black for transparent color key which is on
  102.     'the source bitmap -> use src keying
  103.     Dim key As DDCOLORKEY
  104.     key.low = 0
  105.     key.high = 0
  106.     spritesurf.SetColorKey DDCKEY_SRCBLT, key
  107. End Sub
  108. Sub blt()
  109.     On Local Error GoTo errOut
  110.     If binit = False Then Exit Sub
  111.     Dim ddrval As Long
  112.     Static i As Integer
  113.     Dim rBack As RECT
  114.     Dim rLake As RECT
  115.     Dim rSprite As RECT
  116.     Dim rSprite2 As RECT
  117.     Dim rPrim As RECT
  118.     Static a As Single
  119.     Static x As Single
  120.     Static y As Single
  121.     Static t As Single
  122.     Static t2 As Single
  123.     Static tLast As Single
  124.     Static fps As Single
  125.     ' this will keep us from trying to blt in case we lose the surfaces (alt-tab)
  126.     bRestore = False
  127.     Do Until ExModeActive
  128.         DoEvents
  129.         bRestore = True
  130.     Loop
  131.     ' if we lost and got back the surfaces, then restore them
  132.     DoEvents
  133.     If bRestore Then
  134.         bRestore = False
  135.         dd.RestoreAllSurfaces
  136.         InitSurfaces ' must init the surfaces again if they we're lost
  137.     End If
  138.     'get the area of the screen where our window is
  139.     rBack.Bottom = ddsd4.lHeight
  140.     rBack.Right = ddsd4.lWidth
  141.     'get the area of the bitmap we want ot blt
  142.     rLake.Bottom = ddsd2.lHeight
  143.     rLake.Right = ddsd2.lWidth
  144.     'blt to the backbuffer from our  surface to
  145.     'the screen surface such that our bitmap
  146.     'appears over the window
  147.     ddrval = backbuffer.BltFast(0, 0, lakesurf, rLake, DDBLTFAST_WAIT)
  148.     'Calculate the frame rate
  149.     If i = 30 Then
  150.         If tLast <> 0 Then fps = 30 / (Timer - tLast)
  151.         tLast = Timer
  152.         i = 0
  153.     End If
  154.     i = i + 1
  155.     Call backbuffer.DrawText(10, 10, "640x480x16 Frames per Second " + Format$(fps, "#.0"), False)
  156.     Call backbuffer.DrawText(10, 30, "Click Screen to Exit", False)
  157.              
  158.     'calculate the angle from the center
  159.     'at witch to place the sprite
  160.     'calcultate wich frame# we are on in the sprite bitmap
  161.     t2 = Timer
  162.     If t <> 0 Then
  163.         a = a + (t2 - t) * 40
  164.         If a > 360 Then a = a - 360
  165.         currentFrame = currentFrame + (t2 - t) * 40
  166.         If currentFrame > rows * cols - 1 Then currentFrame = 0
  167.     End If
  168.     t = t2
  169.     'calculat the x and y position of the sprite
  170.     x = Cos((a / 360) * 2 * 3.141) * 100
  171.     y = Sin((a / 360) * 2 * 3.141) * 100
  172.     rSprite2.Top = y + Me.ScaleHeight / 2
  173.     rSprite2.Left = x + Me.ScaleWidth / 2
  174.     rSprite2.Right = rSprite2.Left + spriteWidth
  175.     rSprite2.Bottom = rSprite2.Top + spriteHeight
  176.     'from the current frame select the bitmap we want
  177.     col = currentFrame Mod cols
  178.     row = Int(currentFrame / cols)
  179.     rSprite.Left = col * spriteWidth
  180.     rSprite.Top = row * spriteHeight
  181.     rSprite.Right = rSprite.Left + spriteWidth
  182.     rSprite.Bottom = rSprite.Top + spriteHeight
  183.       
  184.     'blt to the backbuffer our animated sprite
  185.     ddrval = backbuffer.BltFast(rSprite2.Left, rSprite2.Top, spritesurf, rSprite, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT)
  186.     'flip the back buffer to the screen
  187.     primary.Flip Nothing, DDFLIP_WAIT
  188. errOut:
  189. End Sub
  190. Sub EndIt()
  191.     Call dd.RestoreDisplayMode
  192.     Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
  193.     End
  194. End Sub
  195. Private Sub Form_Click()
  196.     EndIt
  197. End Sub
  198. Private Sub Form_Load()
  199.     Init
  200. End Sub
  201. Private Sub Form_Paint()
  202.     blt
  203. End Sub
  204. Function ExModeActive() As Boolean
  205.     Dim TestCoopRes As Long
  206.     TestCoopRes = dd.TestCooperativeLevel
  207.     If (TestCoopRes = DD_OK) Then
  208.         ExModeActive = True
  209.     Else
  210.         ExModeActive = False
  211.     End If
  212. End Function
  213. Sub FindMediaDir(sFile As String)
  214.     On Local Error Resume Next
  215.     If Dir$(sFile) <> "" Then Exit Sub
  216.     If Mid$(App.Path, 2, 1) = ":" Then
  217.         ChDrive Mid$(App.Path, 1, 1)
  218.     End If
  219.     ChDir App.Path
  220.     If Dir$(sFile) = "" Then
  221.         ChDir "..\media"
  222.     End If
  223.     If Dir$(sFile) = "" Then
  224.         ChDir "..\..\media"
  225.     End If
  226. End Sub
  227.