gamefunctions.bas

在游戏中场景的移动

Dim rt As Long
Dim ErrorString As String
Static DeviceIdentifier As Integer

'Up the count (making it unique)
DeviceIdentifier = DeviceIdentifier + 1

ErrorString = Space(255)

Select Case Device

    Case WAV 'Wav files
        
        rt = mciSendString("OPEN " & FileName & " TYPE WAVEAUDIO ALIAS WAVNR" _
                            & CStr(DeviceIdentifier) & " BUFFER 4", "", 0, 0)
        
        If rt <> 0 Then 'Zero on success
                                    
            PlayBackGroundSound = Str(0)
                                    
        Else
            
            rt = mciSendString("PLAY WAVNR" & CStr(DeviceIdentifier) & " FROM 0", "", 0, 0)
            
            'Used for debugging..Fills the ErrorString variable witha description on the error
            'mciGetErrorString rt, ErrorString, Len(ErrorString)
            'Debug.Print ErrorString
            
            PlayBackGroundSound = "WAVNR" & DeviceIdentifier
                       
        End If
    
    Case MIDI
    
        rt = mciSendString("OPEN " & FileName & " TYPE SEQUENCER ALIAS MIDINR" _
                            & CStr(DeviceIdentifier), "", 0, 0)
        
        If rt <> 0 Then 'Zero on success
                        
            PlayBackGroundSound = Str(0)
            
        Else
            
            rt = mciSendString("PLAY MIDINR" & CStr(DeviceIdentifier) & " FROM 0", "", 0, 0)
            
            'Used for debugging..Fills the ErrorString variable witha description on the error
            'mciGetErrorString rt, ErrorString, Len(ErrorString)
            'Debug.Print ErrorString
            
            PlayBackGroundSound = "MIDINR" & DeviceIdentifier
                       
        End If
    
End Select


End Function
'Stops background music from playing
'IN: Identifier: Device identifier
'OUT: 1: No errors music stopped
'     0: Error, music not stopped (might not even be playing)
Public Function StopBackgroundMusic(Identifier As String) As Long
Dim rt As Long
Dim ErrorString As String

ErrorString = Space(255)

If Identifier <> "" Then
        
        rt = mciSendString("STOP " & Identifier, "", 0, 0)
        
        If rt <> 0 Then 'Error, Zero on success
            
            'Used for debugging..Fills the ErrorString variable witha description on the error
            'mciGetErrorString rt, ErrorString, Len(ErrorString)
            'Debug.Print ErrorString
            
            StopBackgroundMusic = 0
        
        Else
        
            StopBackgroundMusic = 1
        
        End If
Else
    
    StopBackgroundMusic = 0

End If

End Function

'Use this function to service background music, ie Start playing it if has stopped
'IN: Device identifier of the multimedia device to be serviced
'OUT: 1: No errors, but service not needed
'     2: No erros, service was performed
'     0: Error
Public Function ServiceBackgroundMusic(Identifier As String) As Long
Dim rt As Long
Dim Status As String

Status = Space(25)

rt = mciSendString("STATUS " & Identifier & " MODE", Status, Len(Status), 0)

If rt = 0 Then
    Status = Trim$(Status)
    
    If Left(UCase$(Status), Len("STOPPED")) = "STOPPED" Then 'Music has stopped play it again
        
        rt = mciSendString("PLAY " & Identifier & " FROM 0", "", 0, 0)
        
        If rt = 0 Then
            
            ServiceBackgroundMusic = 2
        
        Else
            
            ServiceBackgroundMusic = 0
        
        End If
    Else
        
        ServiceBackgroundMusic = 1
    End If

Else

    'Used for debugging..Fills the ErrorString variable witha description on the error
    'mciGetErrorString rt, ErrorString, Len(ErrorString)
    'Debug.Print ErrorString
    
    ServiceBackgroundMusic = 0

End If
           
    
End Function

'Reads a bitmap file and generates a Memory context for it
'IN: CompatibleDC: The context, which the generated DC should be compatible with
'    FileName: The file name of the graphics
'OUT: The Generated DC
Public Function GenerateDC(FileName As String) As Long
Dim DC As Long
Dim hBitmap As Long

'Create a Device Context
DC = CreateCompatibleDC(0)

If DC < 1 Then
    GenerateDC = 0
    Exit Function
End If

'Load the image....BIG NOTE: This function is not supported under NT, there you can not
'specify the LR_LOADFROMFILE flag
hBitmap = LoadImage(0, FileName, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)

If hBitmap = 0 Then 'Failure in loading bitmap
    DeleteDC DC
    GenerateDC = 0
    Exit Function
End If

'Throw the Bitmap into the Device Context
SelectObject DC, hBitmap

'Return the device context
GenerateDC = DC

DeleteObject hBitmap

End Function

'Destroy a Device Context created with the GenerateDC function
Public Function DestroyDC(DC As Long) As Long

If DC > 0 Then
    DestroyDC = DeleteDC(DC)
End If

End Function

'Checks whether the LEFT Arrow key is pressed
'OUT: True if the key is pressed, else false
Public Function CheckLeftKey() As Boolean
Dim vkLeft As Long

vkLeft = GetKeyState(VK_LEFT)

If vkLeft = VK_KEYDOWN Or vkLeft = VK2_KEYDOWN Then
    CheckLeftKey = True
Else
    CheckLeftKey = False
End If

End Function

'Checks whether the RIGHT Arrow key is pressed
'OUT: True if the key is pressed, else false
Public Function CheckRightKey() As Boolean
Dim vkRight As Long

vkRight = GetKeyState(VK_RIGHT)

If vkRight = VK_KEYDOWN Or vkRight = VK2_KEYDOWN Then
    CheckRightKey = True
Else
    CheckRightKey = False
End If

End Function

'Checks whether the Down Arrow key is pressed
'OUT: True if the key is pressed, else false
Public Function CheckDownKey() As Boolean
Dim vkDown As Long

vkDown = GetKeyState(VK_DOWN)

If vkDown = VK_KEYDOWN Or vkDown = VK2_KEYDOWN Then
    CheckDownKey = True
Else
    CheckDownKey = False
End If

End Function

'Checks whether the UP Arrow key is pressed
'OUT: True if the key is pressed, else false
Public Function CheckUPKey() As Boolean
Dim vkUP As Long

vkUP = GetKeyState(VK_UP)

If vkUP = VK_KEYDOWN Or vkUP = VK2_KEYDOWN Then
    CheckUPKey = True
Else
    CheckUPKey = False
End If

End Function

'Checks if Escape key is pressed
Public Function IsEscapePressed() As Boolean
Dim vkEscape As Long

vkEscape = GetKeyState(VK_ESCAPE)

If vkEscape = VK_KEYDOWN Or vkEscape = VK2_KEYDOWN Then
    IsEscapePressed = True
Else
    IsEscapePressed = False
End If

End Function

'Collision detection.
'IN: Two RECTS Structures
Public Function DetectCollision(FirstRect As RECT, SecondRect As RECT) As Boolean
Dim Collision As Boolean

Collision = True

If ((FirstRect.X2 < SecondRect.X1) Or (FirstRect.X1 > SecondRect.X2) Or _
    (FirstRect.Y1 < SecondRect.Y1) Or (FirstRect.Y1 > SecondRect.Y2)) Then
        
        Collision = False
End If

DetectCollision = Collision

End Function