home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD72326282000.psc / ModDX7.bas < prev    next >
Encoding:
BASIC Source File  |  2000-06-15  |  4.1 KB  |  138 lines
  1. Attribute VB_Name = "ModDX7"
  2. 'ModDX7 - by Simon Price
  3. 'a module of simple funtions to make DirectX 7 easier to program
  4.  
  5. Public DirectX As New DirectX7
  6. Public DX_Draw As DirectDraw7
  7.  
  8. Public DestRect As RECT
  9. Public SrcRect As RECT
  10.  
  11. Dim InExMode As Boolean
  12.  
  13. Sub SetDisplayMode(Width As Integer, Height As Integer, Colors As Byte)
  14. 'set's the display mode to the required size and colors
  15.  DX_Draw.SetDisplayMode Width, Height, Colors, 0, DDSDM_DEFAULT
  16. End Sub
  17.  
  18. Sub RestoreDisplayMode()
  19. 'puts the screen back to normal
  20.  DX_Draw.RestoreDisplayMode
  21. End Sub
  22.  
  23. Sub CreateSurfaceFromFile(Surface As DirectDrawSurface7, Surfdesc As DDSURFACEDESC2, Filename As String, Width As Integer, Height As Integer)
  24. On Error GoTo LostFile
  25. 'loads a bitmap from a file and makes a pic from it
  26.      Surfdesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  27.      Surfdesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  28.      Surfdesc.lWidth = Width
  29.      Surfdesc.lHeight = Height
  30.      
  31.      Set Surface = DX_Draw.CreateSurfaceFromFile(Filename, Surfdesc)
  32. Exit Sub
  33. LostFile:
  34. Debug.Print "File not found : " & Filename
  35. End Sub
  36.  
  37. Sub Init(hwnd As Long)
  38. If InExMode Then Exit Sub
  39.  
  40. 'starts up everyfink
  41. On Error GoTo CrapThingDontWork
  42. 'creates direct draw. whopee
  43. Set DX_Draw = DirectX.DirectDrawCreate("")
  44. 'allow us to do cool stuff
  45. DX_Draw.SetCooperativeLevel hwnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE
  46. InExMode = True
  47. Exit Sub
  48.  
  49. CrapThingDontWork:
  50. MsgBox "Error - Cannot activate DirectX 7 - make sure you have it installed correctly!", vbExclamation, "Error!"
  51. End
  52. End Sub
  53.  
  54. Sub StretchBlt(Pic As DirectDrawSurface7, x As Integer, y As Integer, Width As Integer, Height As Integer, DestPic As DirectDrawSurface7, DestX As Integer, DestY As Integer, DestWidth As Integer, DestHeight As Integer)
  55. WaitTillOK
  56. Dim Box As RECT
  57. Box.LEFT = x
  58. Box.Top = y
  59. Box.RIGHT = x + Width
  60. Box.Bottom = y + Height
  61.  
  62. Dim DestBox As RECT
  63. DestBox.LEFT = DestX
  64. DestBox.Top = DestY
  65. DestBox.RIGHT = DestX + DestWidth
  66. DestBox.Bottom = DestY + DestHeight
  67.  
  68. Pic.Blt DestBox, DestPic, Box, DDBLT_WAIT
  69. End Sub
  70.  
  71. Sub BitBlt(Pic As DirectDrawSurface7, x As Integer, y As Integer, Width As Integer, Height As Integer, DestPic As DirectDrawSurface7, DestX As Integer, DestY As Integer)
  72. WaitTillOK
  73. Dim DestBox As RECT
  74. DestBox.LEFT = DestX
  75. DestBox.Top = DestY
  76. DestBox.RIGHT = DestX + DestWidth
  77. DestBox.Bottom = DestY + DestHeight
  78.  
  79. Pic.BltFast x, y, DestPic, DestBox, DDBLTFAST_WAIT
  80. End Sub
  81.  
  82. Sub WaitTillOK()
  83. Dim bRestore As Boolean
  84.  
  85. bRestore = False
  86. Do Until ExModeActive 'short way of saying "do until it returns true"
  87.     DoEvents 'Lets windows do other things
  88.     bRestore = True
  89. Loop
  90.  
  91. ' if we lost and got back the surfaces, then restore them
  92. DoEvents 'Lets windows do it's things
  93. If bRestore Then
  94.     bRestore = False
  95.     DX_Draw.RestoreAllSurfaces
  96.     ModSurfaces.LoadAllPics ' must init the surfaces again if they we're lost. When this happens the first line of initsurfaces is important
  97. End If
  98. End Sub
  99.  
  100. Function ExModeActive() As Boolean
  101.      Dim TestCoopRes As Long 'holds the return value of the test.
  102.  
  103.      TestCoopRes = DX_Draw.TestCooperativeLevel 'Tells DDraw to do the test
  104.  
  105.      If (TestCoopRes = DD_OK) Then
  106.          ExModeActive = True 'everything is fine
  107.      Else
  108.          ExModeActive = False 'this computer doesn't support this mode
  109.      End If
  110.  End Function
  111.  
  112. Sub EndIt(hwnd As Long)
  113. DX_Draw.SetCooperativeLevel hwnd, DDSCL_NORMAL
  114. InExMode = False
  115. End Sub
  116.  
  117. Sub AddColorKey(Surface As DirectDrawSurface7, ColorKey As DDCOLORKEY, low As Long, high As Long)
  118. ColorKey.low = low
  119. ColorKey.high = high
  120. Surface.SetColorKey DDCKEY_SRCBLT, ColorKey
  121. End Sub
  122.  
  123. Sub SetRect(Box As RECT, LEFT As Integer, Top As Integer, Width As Integer, Height As Integer)
  124. Box.LEFT = LEFT
  125. Box.Top = Top
  126. Box.RIGHT = LEFT + Width
  127. Box.Bottom = Top + Height
  128. End Sub
  129.  
  130. Sub ClearSurface(Surface As DirectDrawSurface7, Width As Integer, Height As Integer)
  131. Surface.SetForeColor vbBlack
  132. ModDX7.SetRect SrcRect, 0, 0, 1, 1
  133. ModDX7.SetRect DestRect, 0, 0, Width, Height
  134. Surface.DrawLine 0, 0, 1, 1
  135. Surface.Blt DestRect, Surface, SrcRect, DDBLT_WAIT
  136. End Sub
  137.  
  138.