gamestuf.bas

breakthrough游戏(保持小球在屏幕上跳动)源程序

Attribute VB_Name = "GAMESTUF"
Option Explicit
'--------------------------------------------------
' Global variables, constants and declaration.
'--------------------------------------------------

' Functions and constants used to play sounds.
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Declare Function sndStopSound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszNull As Long, ByVal uFlags As Long) As Long

Global Const SND_SYNC = &H0
Global Const SND_ASYNC = &H1
Global Const SND_NODEFAULT = &H2
Global Const SND_MEMORY = &H4
Global Const SND_LOOP = &H8
Global Const SND_NOSTOP = &H10

' Color Constants
Global Const DARK_GRAY = &H808080
Global Const WHITE = &HFFFFFF
Global Const BLACK = &H0

' KeyCode constants
Global Const KEY_LEFT = &H25
Global Const KEY_RIGHT = &H27

' 3D effect constants
Global Const BORDER_INSET = 0
Global Const BORDER_RAISED = 1

' A general purpose data structure used for tracking bitmaps.
' This structure can also be passed to Windows API calls requiring
' a RECT (rectangle structure).
Type tBitMap
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    Width As Long
    Height As Long
End Type

' Windows GDI Bitmap API constants and functions
Global Const SRCCOPY = &HCC0020
Global Const SRCINVERT = &H660046
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

' Windows API rectangle functions
Declare Function IntersectRect Lib "user32" (lpDestRect As tBitMap, lpSrc1Rect As tBitMap, lpSrc2Rect As tBitMap) As Long

' Two Windows API calls used to read and write private .INI files.
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long


Sub Make3D(pic As Form, ctl As Control, ByVal BorderStyle As Integer)
'--------------------------------------------------
' Wrap a 3D effect around a control on a form.
'--------------------------------------------------
Dim AdjustX As Integer, AdjustY As Integer
Dim RightSide As Single
Dim BW As Integer, BorderWidth As Integer
Dim LeftTopColor As Long, RightBottomColor As Long
Dim i As Integer

    If Not ctl.Visible Then Exit Sub

    AdjustX = Screen.TwipsPerPixelX
    AdjustY = Screen.TwipsPerPixelY

    BorderWidth = 3

    Select Case BorderStyle
    Case 0: ' Inset
        LeftTopColor = DARK_GRAY
        RightBottomColor = WHITE
    Case 1: ' Raised
        LeftTopColor = WHITE
        RightBottomColor = DARK_GRAY
    End Select
    

    ' Set the top shading line.
    For BW = 1 To BorderWidth
        ' Top
        pic.CurrentX = ctl.Left - (AdjustX * BW)
        pic.CurrentY = ctl.Top - (AdjustY * BW)
        pic.Line -(ctl.Left + ctl.Width + (AdjustX * (BW - 1)), ctl.Top - (AdjustY * BW)), LeftTopColor
        ' Right
        pic.Line -(ctl.Left + ctl.Width + (AdjustX * (BW - 1)), ctl.Top + ctl.Height + (AdjustY * (BW - 1))), RightBottomColor
        ' Bottom
        pic.Line -(ctl.Left - (AdjustX * BW), ctl.Top + ctl.Height + (AdjustY * (BW - 1))), RightBottomColor
        ' Left
        pic.Line -(ctl.Left - (AdjustX * BW), ctl.Top - (AdjustY * BW)), LeftTopColor
    Next
End Sub

Function NoiseGet(ByVal FileName) As String
'------------------------------------------------------------
' Load a sound file into a string variable.
'------------------------------------------------------------
Dim buffer As String
Dim f As Integer
Dim SoundBuffer As String

    On Error GoTo NoiseGet_Error

    buffer = Space$(1024)
    SoundBuffer = ""
    f = FreeFile
    Open FileName For Binary As f
    Do While Not EOF(f)
        Get #f, , buffer     ' Load in 1K chunks
        SoundBuffer = SoundBuffer & buffer
    Loop
    Close f
    NoiseGet = Trim$(SoundBuffer)
Exit Function

NoiseGet_Error:
    SoundBuffer = ""
    Exit Function
End Function

Sub NoisePlay(SoundBuffer As String, ByVal PlayMode As Integer)
'------------------------------------------------------------
' Plays a sound previously loaded into memory with function
' NoiseGet().
'------------------------------------------------------------
Dim retcode As Integer
    
    If SoundBuffer = "" Then Exit Sub

    ' Stop any sound that may currently be playing.
    retcode = sndStopSound(0, SND_ASYNC)

    ' PlayMode should be SND_SYNC or SND_ASYNC
    retcode = sndPlaySound(ByVal SoundBuffer, PlayMode Or SND_MEMORY)
End Sub