' ---Declarations--- '
Option Explicit
Dim binit As Boolean 'States weather we intialized or not.
'Also checks before drawing, If false, then we will get errors
'if we try to draw
Dim dx As DirectX7 'Root onject, everything comes from this
Dim dd As DirectDraw7 'All directDraw **** is fr0m this
Dim Mainsurf As DirectDrawSurface7 'This holds the BMP
Dim primary As DirectDrawSurface7 'This replaces screen
Dim backbuffer As DirectDrawSurface7 'This holds the BMP after to stop flickering
Dim ddsd1 As DDSURFACEDESC2 'Describes surface
Dim ddsd2 As DDSURFACEDESC2 'Describes BMP
Dim ddsd3 As DDSURFACEDESC2 'Describes screen size
Dim brunning As Boolean 'Check wether or not the main gaMe loop is runnin
Dim CurModeActiveStatus As Boolean 'Checks if we still have the correct display mode
Dim bRestore As Boolean 'If we dont then we need to restOre the dispLay mode
' ---mAiN--- '
Sub Init()
'On Local Error GoTo errOut 'If an error occurs then leave
Set dd = dx.DirectDrawCreate("") '() means default drivers
Me.Show 'Mazimises the form and makes it visibLe
'exclusive makes it so win pays more attention to this ap, and DirectDraw cant be used anywehre else
Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
'First 3 are res and color settings, 4th is refresh rate and last is not needed
Call dd.SetDisplayMode(640, 480, 16, 0, DDSDM_DEFAULT) '1024x768 16bit Auto Refreshrate
'Get screen surface and create bacKBuffer
ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
ddsd1.lBackBufferCount = 1
Set primary = dd.CreateSurface(ddsd1)
'Get the backbuffer
Dim caps As DDSCAPS2
caps.lCaps = DDSCAPS_BACKBUFFER
Set backbuffer = primary.GetAttachedSurface(caps)
backbuffer.GetSurfaceDesc ddsd3
'Init the surfaces
InitSurfaces
'This is the main loop. It only runs when bRunnng is true
binit = True
brunning = True
Do While brunning = True
blt
DoEvents
Loop
errOut:
EndIt
End Sub
Sub InitSurfaces()
Set Mainsurf = Nothing 'This must be cleared or we will get errors if we try to call this
'Load bmp into a surface
ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH '
ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN 'Offscreenplain means teh uSer never sees anything, its just stored in memory
ddsd2.lWidth = ddsd3.lWidth 'Make the BMP size same as screen
ddsd2.lHeight = ddsd3.lHeight '^^ height
Set Mainsurf = dd.CreateSurfaceFromFile(App.Path & "\backdrop.bmp", ddsd2)
'First fill in ddsd2 and then use it to make a surface from a file, using DirectDraw
End Sub
Sub blt()
On Local Error GoTo errOut 'If error, skip everything
If binit = False Then Exit Sub 'If not intiaised, then dont do anything DD related yet
Dim ddrval As Long 'Every drawing function returns a value, we will store it here and use it to check for errors
Dim rBack As RECT 'RECT is rectangLe.
bRestore = False
Do Until ExModeActive = True
DoEvents
bRestore = True
Loop
'If we lost and got back the surfaces, lets restore htem
DoEvents
If bRestore = True Then
bRestore = False
dd.RestoreAllSurfaces 'Re allocates memory back to the surfaces, we still need to reload all of them tho -_-
InitSurfaces 'Must init surfaces again if we're lost
End If
'Get area of screen where w1ndow is
rBack.Bottom = ddsd3.lHeight 'Set RECT to size of scrEEn
rBack.Right = ddsd3.lWidth
'Make bmp appear over the window
ddrval = backbuffer.BltFast(0, 0, Mainsurf, rBack, DDBLTFAST_WAIT)
'Flip the backbuffer to the screen
primary.Flip Nothing, DDFLIP_WAIT
'we completed 1 cycle and can see something on screen
errOut:
'Dont put anything here, if game is at like 100 fps, the error will try show 100 times in 1 second :x
End Sub
Sub EndIt()
'This runs on error or when we are done
'Restore back to default windows res
Call dd.RestoreDisplayMode
'tell dx and win that we no longer want exclusive access to directDraw
Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
End
End Sub
Private Sub Form_Click()
EndIt 'do this if the user clicks screen, since its
'fullscreen mode the click location doesnt matter
End Sub
Private Sub Form_Load()
Init 'main loop
End Sub
Private Sub Form_Paint()
'If window needs painting run blt
blt
End Sub
Function ExModeActive() As Boolean 'Check if were in correct res
Dim TestCoopRes As Long
TestCoopRes = dd.TestCooperativeLevel
If (TestCoopRes = DD_OK) Then
ExModeActive = True
Else
ExModeActive = False
End If
End Function
