titoli.bas

用VB编写一个非常好的赛车游戏,源程序来自网络,这里是转载~谢谢合作~

Attribute VB_Name = "titoli"
'///////////////////////////////////////////
'/////////MENU' E TITOLO///////////////////
'/////////////////////////////////////////
Public Type particelle
        x As Single
        y As Single
        z As Single
        direz As Long
        velocit As Single
        tempo As Single
        vita As Boolean
End Type



Sub dammiLaFaccia(p As Long)
    'restituisce la faccia
    Select Case veicoli(p).numC
    
    Case 1
        tRect.Left = 0
        tRect.Top = 0
    Case 2
        tRect.Left = 64
        tRect.Top = 0
    Case 3
        tRect.Left = 192
        tRect.Top = 0
    Case 4
        tRect.Left = 128
        tRect.Top = 64
    Case 5
        tRect.Left = 64
        tRect.Top = 64
    Case 6
        tRect.Left = 128
        tRect.Top = 0
    Case 7
        tRect.Left = 192
        tRect.Top = 64
    Case 8
        tRect.Left = 0
        tRect.Top = 64
    End Select

    tRect.Right = tRect.Left + 64
    tRect.bottom = tRect.Top + 64
    
End Sub

Sub titoloG()
'titolo numero 1
    Dim titolo As Direct3DSurface8
    Dim backbuffer As Direct3DSurface8
    Dim menuTit As Long '(posizione dell'icona
    'carica le superfici
    Set titolo = device.CreateImageSurface(modalit郪ideo.Width, modalit郪ideo.Height, modalit郪ideo.Format)
    Set backbuffer = device.GetBackBuffer(0, D3DBACKBUFFER_TYPE_MONO)
    D3DX.LoadSurfaceFromFile titolo, ByVal 0, ByVal 0, App.Path & "\photo\titolo.jpg", ByVal 0, D3DX_DEFAULT, 0, ByVal 0
    'carica le texture
    Dim menuTexture As Direct3DTexture8
    Set menuTexture = creaTex(App.Path & "\photo\menu.bmp", D3DColorMake(0, 0, 0, 1), True)
    'rettangolo da usare
    Dim ausV1 As D3DVECTOR2
    ausV1.x = modalit郪ideo.Width / 640 '1:640=X:resol
    ausV1.y = modalit郪ideo.Height / 480
    Dim ausV2 As D3DVECTOR2
    ausV2.x = 0
    ausV2.y = 0
    Dim ausV3 As D3DVECTOR2
    ausV3.x = 200 * (modalit郪ideo.Width / 640) '220:640=X:resol
    ausV3.y = 350 * (modalit郪ideo.Height / 480)
    '
    Dim ausR As RECT
    Dim sinistraAus As Long
    Dim fattoreAus As Long
    fattoreAus = 2
    'se i pulsanti sono premuti
    Dim premutoAus As Boolean
    premutoAus = True
    'gamma
    IsSolvenza = False
    gammaZero
    
    
    'parte audio
    Dim suono1 As DirectSoundSecondaryBuffer8
    Set suono1 = caricaWave(App.Path & "\audio\menu1.wav")
    
    suonaMidi 1
    
    
1
    device.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, D3DColorMake(0, 0, 0, 0), 1#, 0
    'copia sfondo
    device.CopyRects titolo, ByVal 0, 0, backbuffer, ByVal 0
    'copia texture
    
    ausR.Left = 0
    ausR.Right = 256
    ausR.Top = menuTit * 60
    ausR.bottom = menuTit * 60 + 60

    dSprite.Draw menuTexture, ausR, ausV1, ausV2, 0, ausV3, D3DColorMake(1, 1, 1, 1)
    
    'textR.Left = 0
    'textR.Top = 0
    'textR.Right = 400
    'textR.bottom = 400
    'D3DX.DrawText testo, D3DColorMake(1, 1, 1, 1), "Frame Rate " & nFPS, textR, DT_LEFT
    
    device.Present ByVal 0, ByVal 0, 0, ByVal 0
    If Not IsSolvenza Then solvenza: IsSolvenza = True
    
    
    DoEvents
        
        
        'contatore di frame
        While dmp.GetClockTime - timeF < 30
        Wend
        timeF = dmp.GetClockTime
        'frame rate
        nFrame = nFrame + 1
        If dmp.GetClockTime - FrameT >= 1000 Then
           nFPS = nFrame
           nFrame = 0
           FrameT = dmp.GetClockTime
        End If
    
'effetto di scorrimento
sinistraAus = sinistraAus + fattoreAus
If sinistraAus < -30 Then fattoreAus = 2
If sinistraAus > 30 Then fattoreAus = -2
ausV3.x = 200 * (modalit郪ideo.Width / 640) + sinistraAus '220:640=X:resol

'//////////////////////////////////

levaY = 0
tasto1 = 0
tasto2 = 0
'controllo in modo che un tasto deve essere lasciato prima di poterlo ripremere
If premutoAus Then
        premutoAus = False
        If presente Then
                mito.Poll
                mito.GetDeviceStateJoystick pulsanti
                'ricevi i dati
                With pulsanti
                    If .y > 7000 Then premutoAus = True
                    If .y < 3000 Then premutoAus = True
                    If .Buttons(0) <> 0 Then premutoAus = True
                    'If .Buttons(1) <> 0 Then tasto2 = 1
                End With
        End If
                'tastiera
                tastieraX.GetDeviceStateKeyboard tastiX
                If tastiX.Key(200) <> 0 Then premutoAus = True
                If tastiX.Key(208) <> 0 Then premutoAus = True
                If tastiX.Key(28) <> 0 Then premutoAus = True
                If tastiX.Key(1) <> 0 Then premutoAus = True
Else
        If presente Then
                mito.Poll
                mito.GetDeviceStateJoystick pulsanti
                'ricevi i dati
                With pulsanti
                    If .y > 7000 Then levaY = 1: premutoAus = True
                    If .y < 3000 Then levaY = -1: premutoAus = True
                    If .Buttons(0) <> 0 Then tasto1 = 1: premutoAus = True
                    'If .Buttons(1) <> 0 Then tasto2 = 1
                End With
        End If
                'tastiera
                tastieraX.GetDeviceStateKeyboard tastiX
                If tastiX.Key(200) <> 0 Then levaY = -1: premutoAus = True
                If tastiX.Key(208) <> 0 Then levaY = 1: premutoAus = True
                If tastiX.Key(28) <> 0 Then tasto1 = 1: premutoAus = True
                If tastiX.Key(1) <> 0 Then termina True
End If


            'scelta del tasto
            Select Case levaY
            Case -1
                menuTit = menuTit - 1
                If menuTit < 0 Then menuTit = 3
                suono1.Play DSBPLAY_DEFAULT
            Case 1
                menuTit = menuTit + 1
                If menuTit > 3 Then menuTit = 0
                suono1.Play DSBPLAY_DEFAULT
            End Select
            If tasto1 <> 0 Then GoTo uscita

GoTo 1
uscita:
        '
        Select Case menuTit
            Case 0
                'menu di classe
                nMenu = 2
                nGioco = 1
            Case 1
                'time trial
                nGioco = 2
                nMenu = 3
            Case 2
                'option
                nMenu = 4
            Case 3
                'versus
                nMenu = 3
                nGioco = 3
        End Select
                dissolvenza

End Sub





Sub titoloCL()
'titolo numero 1
    Dim titolo As Direct3DSurface8
    Dim backbuffer As Direct3DSurface8
    Dim menuTit As Long '(posizione dell'icona
    'carica le superfici
    Set titolo = device.CreateImageSurface(modalit郪ideo.Width, modalit郪ideo.Height, modalit郪ideo.Format)
    Set backbuffer = device.GetBackBuffer(0, D3DBACKBUFFER_TYPE_MONO)
    D3DX.LoadSurfaceFromFile titolo, ByVal 0, ByVal 0, App.Path & "\photo\sfondoCl.jpg", ByVal 0, D3DX_DEFAULT, 0, ByVal 0
    'carica le texture
    Dim menuTexture As Direct3DTexture8
    Set menuTexture = creaTex(App.Path & "\photo\menu2.bmp", D3DColorMake(0, 0, 0, 1), True)
    'rettangolo da usare
    Dim ausV1 As D3DVECTOR2
    ausV1.x = modalit郪ideo.Width / 640 '1:640=X:resol
    ausV1.y = modalit郪ideo.Height / 480
    Dim ausV2 As D3DVECTOR2
    ausV2.x = 0
    ausV2.y = 0
    Dim ausV3 As D3DVECTOR2
    ausV3.x = 200 * (modalit郪ideo.Width / 640) '220:640=X:resol
    ausV3.y = 350 * (modalit郪ideo.Height / 480)
    '
    Dim ausR As RECT
    Dim sinistraAus As Long
    Dim fattoreAus As Long
    fattoreAus = 2
    Dim premutoAus As Boolean
    premutoAus = True
    'gamma
    IsSolvenza = False
    gammaZero
    
    Dim suono1 As DirectSoundSecondaryBuffer8
    Set suono1 = caricaWave(App.Path & "\audio\menu1.wav")

    suonaMidi 1

    
1
    device.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, D3DColorMake(0, 0, 0, 0), 1#, 0
    'copia sfondo
    device.CopyRects titolo, ByVal 0, 0, backbuffer, ByVal 0
    'copia texture
    
    ausR.Left = 0
    ausR.Right = 256
    ausR.Top = menuTit * 60
    ausR.bottom = menuTit * 60 + 60

    dSprite.Draw menuTexture, ausR, ausV1, ausV2, 0, ausV3, D3DColorMake(1, 1, 1, 1)
    
'textR.Left = 0
'textR.Top = 0
'textR.Right = 400
'textR.bottom = 400
'D3DX.DrawText testo, D3DColorMake(1, 1, 1, 1), "Frame Rate " & nFPS, textR, DT_LEFT
    
    
    device.Present ByVal 0, ByVal 0, 0, ByVal 0
    If Not IsSolvenza Then solvenza: IsSolvenza = True
    
    
    DoEvents
        
        
        'contatore di frame
        While dmp.GetClockTime - timeF < 30
        Wend
        timeF = dmp.GetClockTime
        'frame rate
        nFrame = nFrame + 1
        If dmp.GetClockTime - FrameT >= 1000 Then
           nFPS = nFrame
           nFrame = 0
           FrameT = dmp.GetClockTime
        End If
    
'effetto di scorrimento
sinistraAus = sinistraAus + fattoreAus
If sinistraAus < -30 Then fattoreAus = 2
If sinistraAus > 30 Then fattoreAus = -2
ausV3.x = 200 * (modalit郪ideo.Width / 640) + sinistraAus '220:640=X:resol

'//////////////////////////////////

levaY = 0
tasto1 = 0
tasto2 = 0
'controllo in modo che un tasto deve essere lasciato prima di poterlo ripremere
If premutoAus Then
        premutoAus = False
        If presente Then
                mito.Poll
                mito.GetDeviceStateJoystick pulsanti
                'ricevi i dati
                With pulsanti
                    If .y > 7000 Then premutoAus = True
                    If .y < 3000 Then premutoAus = True
                    If .Buttons(0) <> 0 Then premutoAus = True
                    'If .Buttons(1) <> 0 Then tasto2 = 1
                End With
        End If
                'tastiera
                tastieraX.GetDeviceStateKeyboard tastiX
                If tastiX.Key(200) <> 0 Then premutoAus = True
                If tastiX.Key(208) <> 0 Then premutoAus = True
                If tastiX.Key(28) <> 0 Then premutoAus = True
                If tastiX.Key(1) <> 0 Then premutoAus = True
Else
        If presente Then
                mito.Poll
                mito.GetDeviceStateJoystick pulsanti
                'ricevi i dati
                With pulsanti
                    If .y > 7000 Then levaY = 1: premutoAus = True
                    If .y < 3000 Then levaY = -1: premutoAus = True
                    If .Buttons(0) <> 0 Then tasto1 = 1: premutoAus = True
                    'If .Buttons(1) <> 0 Then tasto2 = 1
                End With
        End If
                'tastiera
                tastieraX.GetDeviceStateKeyboard tastiX
                If tastiX.Key(200) <> 0 Then levaY = -1: premutoAus = True
                If tastiX.Key(208) <> 0 Then levaY = 1: premutoAus = True
                If tastiX.Key(28) <> 0 Then tasto1 = 1: premutoAus = True
                If tastiX.Key(1) <> 0 Then nMenu = 0: GoTo indietro
End If


            'scelta del tasto
            Select Case levaY
            Case -1
                menuTit = menuTit - 1
                If menuTit < 0 Then menuTit = 2
                suono1.Play DSBPLAY_DEFAULT
            Case 1
                menuTit = menuTit + 1
                If menuTit > 2 Then menuTit = 0
                suono1.Play DSBPLAY_DEFAULT
            End Select
            If tasto1 <> 0 Then GoTo uscita

GoTo 1
uscita:        '
        'ogni classe va bene
        nMenu = 3 'menu scelta auto
        nClasse = menuTit 'il numero della classe viene assegnato
indietro:
        dissolvenza
End Sub



Sub titoloAuto1()

'titolo numero 1
    Dim titolo As Direct3DSurface8
    Dim backbuffer As Direct3DSurface8
    Dim menuTit As Long '(posizione dell'icona
    Dim menuTit2 As Long '(posizione dell'icona
    Dim menuTit3 As Long 'auto scelta nel men