VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   0  'None
   Caption         =   "DD Animation"
   ClientHeight    =   5625
   ClientLeft      =   2355
   ClientTop       =   1620
   ClientWidth     =   7065
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   375
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   471
   ShowInTaskbar   =   0   'False
   Begin VB.TextBox Text1 
      Height          =   495
      Left            =   2880
      TabIndex        =   0
      Text            =   "0"
      Top             =   2520
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim binit As Boolean 'A simple flag (true/false)



Dim dx As New DirectX7 'This is the root object. DirectDraw is created From this
Dim DD As DirectDraw7 'This is DirectDraw, all things DirectDraw come From here
Dim Mainsurf As DirectDrawSurface7 'This holds our background
Dim You As DirectDrawSurface7 'you
Dim YouDes As DDSURFACEDESC2 'desc you

Private Declare Function GetTickCount Lib "kernel32" () As Long

Dim LastTick As Long
Dim FPS As Integer

'Dim DD As DirectDraw7
Dim primary As DirectDrawSurface7 'This surface represents the screen
Dim backbuffer As DirectDrawSurface7 'this describes the primary surface
Dim Ddsd1 As DDSURFACEDESC2 'this describes the primary surface
Dim ddsd2 As DDSURFACEDESC2 'this describes the bitmap that we load
Dim ddsd3 As DDSURFACEDESC2 'this describes the size of the screen
Dim brunning As Boolean 'this is another flag that states whether or not
        'the main game loop is running.
Dim CurModeActiveStatus As Boolean 'This checks that we still have the
        'correct display mode
Dim bRestore As Boolean 'If we don't have the correct display mode then
        'this flag states that we need to restore the display mode
      Dim sx As Integer
      Dim sy As Integer
      Dim OfsetX
      Dim OfsetY
      
      Dim sx1 As Integer
      Dim sy1 As Integer
      
      Dim cx As Integer
      Dim cy As Integer
      Dim cx2 As Integer
      Dim cy2 As Integer
      
      Dim rBack As RECT 'a RECT is the rectangle that i've mentioned.
    Dim Ryou As RECT ' rect of you
  
    
Dim ColorKey As DDCOLORKEY
  Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

Sub Init()
    'On Local Error GoTo errOut 'If there is an error we end the program.
    
    Set DD = dx.DirectDrawCreate("") 'the ("") means that we want the default driver
    Me.Show 'maximises the form and makes sure it's visible
    
    'The first line links the DirectDraw object to our form, It also sets the parameters
    'that are to be used - the important ones being DDSCL_FULLSCREEN and DDCSL_EXCLUSIVE. Making it
    'exclusive is important, it means that while our application is running nothing else can
    'use DirectDraw, and it makes windows give us more time/attention
    Call DD.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
    'This is where we actually see a change. It states that we want a display mode
    'of 640x480 with 16 bit colour (65526 colours). the fourth argument ("0") is the
    'refresh rate. leave this to 0 and DirectX will sort out the best refresh rate. It is advised
    'that you don't mess about with this variable. the fifth variable is only used when you
    'want to use the more advanced resolutions (usually the lower, older ones)...
    Call DD.SetDisplayMode(800, 600, 16, 0, DDSDM_DEFAULT)
    
        
    'get the screen surface and create a back buffer too
    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
    sx = 400
    sy = 300
    
 

                                                  
    'This is the main loop. It only runs whilst brunning=true
    binit = True
    brunning = True
    Do While brunning
        
        DoEvents 'you MUST have a doevents in the loop, otherwise you'll overflow the
        'system (which is bad). All your application does is keep sending messages to DirectX
        'and windows, if you dont give them time to complete the operation they'll crash.
        'adding doevents allows windows to finish doing things that its doing.
 blt
'Call Mainsurf.BltColorFill(rBack, 0)

'Call Mainsurf.BltColorFill(rBack, 0)
'Call backbuffer.DrawText(200, 25, Text1.Text, False)

 'Call backbuffer.BltColorFill(rBack, RGB(0, 0, 1))
 'Call Mainsurf.BltColorFill(rBack, RGB(0, 0, 1))
 
 If GetKeyState(vbKeyLeft) < -5 Then MoveL 'sx1 = sx1 + 4 'background
 
 If GetKeyState(vbKeyRight) < -5 Then MoveR 'sx1 = sx1 - 4 'sprite
 
 If GetKeyState(vbKeyUp) < -5 Then MoveU 'sy1 = sy1 + 4
 If GetKeyState(vbKeyDown) < -5 Then MoveD 'sy1 = sy1 - 4
 
 
 
 If GetKeyState(vbKeyEscape) < -5 Then End
    Loop

'errOut: 'If there is an error we want to close the program down straight away.
    'EndIt
End Sub
Sub MoveL()
'sx = sx - 5

sx1 = sx1 + 4
If sx1 >= 5 Then sx1 = sx1 - 4
'If sx >= -15 Then sx = sx + 1
'sx = sx + sx1
End Sub
Sub MoveR()
'sx = sx + 5

sx1 = sx1 - 4
If sx1 >= 1990 Then sx1 = sx1 + 4
'sx = sx + 1
End Sub
Sub MoveU()
'If sy1 >= 500 Then Exit Sub
'sy1 = sy1 + 4
'If sy1 >= 5 Then sy1 = sy1 - 4

sy = sy - 1
End Sub
Sub MoveD()
'sy1 = sy1 - 4
'If sy1 >= 1260 Then sy1 = sy1 + 4
sy = sy + 1
End Sub





Sub InitSurfaces()


    'This procedure may look small, but when you make a program this procedure could
    'take a good 60-120 seconds to process, and run into 1000's of lines of code.

    Set Mainsurf = Nothing 'Although the first time we call this procedure this
    'variable will be empty, it must be cleared. As you'll see in the blt procedure
    'the program may try and re-load the surfaces, at which point the "mainsurf" object
    'will have some information in it. If we try and recreate a surface that already has
    'information in it DirectDraw will crash, because of this we must clear the buffer first.
    Set You = Nothing
    'load the bitmap into a surface - backdrop.bmp
    ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH 'default flags
    ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN 'An offscreenplain means that
    
    YouDes.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH 'default flags
    YouDes.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN 'An offscreenplain means that
    
    YouDes.lWidth = 50
    YouDes.lHeight = 50
    
    'These are used for transparency during the blitting process
  
    'the transparent color will be black
    ColorKey.high = 0
    ColorKey.low = 0
    'This sets the surfaces color key to the color keys above
    'Call surface.SetColorKey(DDCKEY_SRCBLT, ColorKey)
    
   'Call You.SetColorKey(DDCKEY_SRCBLT, ColorKey)
    'Call You.SetColorKey(DDCKEY_COLORSPACE, ColorKey)
    'Call backbuffer.SetColorKey(DDCKEY_SRCBLT, ColorKey)
    'Module1.AddColorKey You, ColorKey, vbWhite, vbWhite
    'the user never actually gets to see the surface - it is just an are in memory.
    ddsd2.lWidth = 1000 'ddsd3.lWidth 'the ddsd3 structure already holds the size
    'of the screen. We could replace it with 640 and 480 - it would have the same effect
    ddsd2.lHeight = 1000 'ddsd3.lHeight
    'this is where the surface is created. You use the DDraw object to create a
    'surface from the specified file name using the above description.
    Set Mainsurf = DD.CreateSurfaceFromFile(App.Path & "\BackTestFinal2.bmp", ddsd2)
    Set You = DD.CreateSurfaceFromFile(App.Path & "\sprite.bmp", YouDes)
   
    Call Mainsurf.SetColorKey(DDCKEY_SRCBLT, ColorKey)
  
    Call You.SetColorKey(DDCKEY_SRCBLT, ColorKey)
End Sub


Sub blt()
    'again, this procedure looks fairly simple - it is!
    'You should try and keep this procedure as short as possible, and as fast as possible
    'On Local Error GoTo errOut 'If there is an error don't do anything - just skip
    'the procedure
    If binit = False Then Exit Sub 'If we haven't initiaised then don't try anything
    'DirectDraw related.
    
    Dim ddrval As Long 'Every drawing procedure returns a value, so we must have a
    'variable to hold it. From this value we can check for errors.
    
    Dim rectTemp As RECT
    
    backbuffer.BltColorFill rectTemp, 0
    
    ' this will keep us from trying to blt in case we lose the surfaces (alt-tab)
    bRestore = False
    Do Until ExModeActive
        DoEvents
        bRestore = True
    Loop
    
    ' if we lost and got back the surfaces, then restore them
    DoEvents
    If bRestore Then
        bRestore = False
        DD.RestoreAllSurfaces 'this just re-allocates memory back to us. we must
        'still reload all the surfaces.
        InitSurfaces ' must init the surfaces again if they we're lost
    End If
    
    'get the area of the screen where our window is
    rBack.Left = Abs(sx1)
    rBack.Right = Abs(800 - sx1)
    
    rBack.Top = Abs(sy1)
    rBack.Bottom = Abs(600 - sy1)
    
   
    'this sets the rectangle to be the size of the screen.
   'rBack.Bottom = ddsd3.lHeight
    'rBack.Right = ddsd3.lWidth
    
    Ryou.Bottom = 50
    Ryou.Right = 50
   
 

    'blt to the backbuffer from our  surface to
    'the screen surface such that our bitmap
    'appears over the window
    'This Blits to the screen starting from 0,0 on the screen. the DDBLTFAST_WAIT
    'flag tells Directdraw to wait if the blitter is busy at the time of the call.
     ddrval = backbuffer.BltFast(0, 0, Mainsurf, rBack, DDBLTFAST_WAIT)
     'ddrval = backbuffer.BltFast(sx, sy, You, Ryou, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT)
     ddrval = backbuffer.BltFast(sx, sy, You, Ryou, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT)
   
    FPS = FPS + 1
    If (GetTickCount) > (LastTick + 1000) Then
    'Call BackBuf.DrawText(200, 25, Str$(FPS), False)
    Text1.Text = Str$(FPS)
    'txtR.Text = Str$(FPS)
    FPS = 0
    LastTick = GetTickCount
    End If
    Call backbuffer.DrawText(200, 25, Text1.Text, False)
   
   'sx = sx + 500
    'flip the back buffer to the screen
    primary.Flip Nothing, DDFLIP_WAIT
   
    'At this point we have completed one cycle, and we can now see something on screen

'errOut:
'Skip everything if there is an error. Don't stick a message box in here - because
'you're likely to be running the program at 100's of frames per second, in just one second the
'program will try and generate 100 message boxes...
End Sub

Sub EndIt()
    'This procedure is called at the end of the loop, or whenever there is an error.
    'Although you can get away without these few lines it is a good idea to keep them
    'as you can get unpredictable results if you leave windows to "clear-up" after you.
    
    'This line restores you back to your default (windows) resolution.
    Call DD.RestoreDisplayMode
    'This tells windows/directX that we no longer want exclusive access
    'to the graphics features/directdraw
    Call DD.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
    'Stop the program:
    End
End Sub

Private Sub Form_Click()
'Kill App.Path & "\BackTestL.bmp"
    'Clicking the form will result in the program closing down.
    'because the form is maximised (and therefore covers the whole screen)
    'where you click is not important.
    EndIt
End Sub

Private Sub Form_Load()
    'Starts the whole program.
    'SavePicture BackGround.Picture, App.Path & "\BackTestL.bmp"
    Init
End Sub


Private Sub Form_Paint()
    'If windows sends a "paint" message translate this into a call
    'to DirectDraw.
    'blt
End Sub

Function ExModeActive() As Boolean
    'This is used to test if we're in the correct resolution.
    Dim TestCoopRes As Long
    
    TestCoopRes = DD.TestCooperativeLevel
    
    If (TestCoopRes = DD_OK) Then
        ExModeActive = True
    Else
        ExModeActive = False
    End If
End Function