Rescue of the Magic Towerの完全なプロジェクトのダウンロードリンク：
前の記事、ゲームエンジンのソースコードに進みます。
ModMain.bas：画像スプライトを描画し、物理スプライト画像プールを管理するために使用されます。
Option Explicit
'主入口
'
'管理物理精灵图片池
'
Private Type TYPE_PATH '路径结构.
Count As Long '当前结构中包含的路径点数量
Index As Long '当前使用的路径点
Xs() As Long 'X与Y路径点序列,单位为像素
Ys() As Long
XSpeed() As Single '移动到下一点的速度,单位为像素/帧,填充路径时事先计算好
YSpeed() As Single
Angle As Single '位于当前点时的角度
End Type
Private Type SAVE_FILE
Pictures() As String '需要加载的精灵图象,格式为[文件名],[横向数量],[纵向数量]
Paths() As TYPE_PATH '需要加载的精灵路径
End Type
Dim Paths() As TYPE_PATH
Dim oGraphs() As xGraphPool
Sub Main()
frmMain.Show
End Sub
Public Sub LoadResData(ByVal sFileName As String)
'加载路径与图形
'
' Dim tmpBuff As SAVE_FILE, lFn As Long
' Dim I As Long, tmpStr() As String
'
' lFn = FreeFile
' Open sFileName For Binary As #lFn
' Get #lFn, , tmpBuff
' Close #lFn
'
' With tmpBuff
' ReDim oPics(UBound(.Pictures))
' For I = 0 To UBound(.Pictures)
' Set oPics(I) = New xGraphPool
' tmpStr() = Split(.Pictures, ",")
'
' oPics(I).LoadGraph tmpStr(0), xgBLACK, tmpStr(1), tmpStr(2)
' Next
' End With
End Sub
Public Sub DrawGraph(lPicIndex As Long, sngCell As Single, sngAngle As Single, mX As Long, mY As Long)
'按参数绘图
'
Dim i As Integer
With oGraphs(lPicIndex)
i = Int(sngCell)
If i <> .Cell Then .Cell = i
.SetRotate sngAngle
.DrawGraph mX, mY
End With
End Sub
xShow.clsモジュールは、バックグラウンドミュージックを再生するために使用されます。
'impactX Game Engine v1.0.0
'本类模块用于多媒体文件的回放和处理
'使用本类模块必须遵守:
'你可以免费使用本引擎及代码
'使用本引擎后的责任由使用者承担
'你可以任意拷贝本引擎代码，但必须保证其完整性
'希望我能得到你使用本引擎制作出的程序
'使用DirectShow，必须在工程->引用菜单中添加ActiveMovie control type library
'Davy.xu [email protected] qq:20998333
Option Explicit
Private m_objBasicAudio As IBasicAudio 'Basic Audio Object
Private m_objBasicVideo As IBasicVideo 'Basic Video Object
Private m_objMediaEvent As IMediaEvent 'MediaEvent Object
Private m_objVideoWindow As IVideoWindow 'VideoWindow Object
Private m_objMediaControl As IMediaControl 'MediaControl Object
Private m_objMediaPosition As IMediaPosition 'MediaPosition Object
Private m_dblStartPosition As Double
Private m_dblRunLength As Double
Private m_boolVideoRunning As Boolean
Private m_Vol As Integer
Private m_Bal As Integer
Private m_hWnd As Long
Private m_Width As Integer
Private m_Height As Integer
Private m_Top As Integer
Private m_Left As Integer
'初始化设定DShow的对象参数
Public Sub InitDXShow(hWnd As Long, Width As Integer, Height As Integer, Optional Left As Integer = 0, Optional Top As Integer = 0)
m_hWnd = hWnd
m_Width = Width
m_Height = Height
m_Top = Top
m_Left = Left
End Sub
'载入媒体,支持媒体类型为mpg,avi,wav,mov,mp3
Public Sub LoadMedia(Pathname As String)
On Local Error GoTo ErrLine
If Mid(Pathname, 2, 1) <> ":" Then Pathname = App.Path & "\" & Pathname
If Len(Dir(Pathname)) = 0 Then
Debug.Print "[PlayMeida]Err:文件不存在!"
Debug.Print Pathname
' MsgBox "音乐文件不存在，但不影响游戏运行！"
Exit Sub
End If
Set m_objMediaControl = New FilgraphManager
Call m_objMediaControl.RenderFile(Pathname)
Set m_objBasicAudio = m_objMediaControl
m_objBasicAudio.Volume = (m_Vol - 100) * 40
m_objBasicAudio.Balance = m_Bal * 50
Set m_objVideoWindow = m_objMediaControl
m_objVideoWindow.WindowStyle = CLng(&H6000000)
m_objVideoWindow.Top = m_Top
m_objVideoWindow.Left = m_Left
m_objVideoWindow.Width = m_Width
m_objVideoWindow.Height = m_Height
m_objVideoWindow.Owner = m_hWnd
Set m_objMediaEvent = m_objMediaControl '播放,停止,暂停的控制对象
Set m_objMediaPosition = m_objMediaControl '媒体位置控制对象
m_dblStartPosition = 0
m_objMediaPosition.Rate = 1
m_dblRunLength = Round(m_objMediaPosition.Duration, 2)
DoEvents
Exit Sub
ErrLine:
Err.Clear
Resume Next
End Sub
'音量的获取和设定
Public Property Get Volume() As Integer
Volume = m_Vol
End Property
Public Property Let Volume(ByVal Vol As Integer)
m_Vol = Vol
m_objBasicAudio.Volume = (Vol - 100) * 40
End Property
'播放进度的获取和设置
Public Property Get MediaPosition() As Double
MediaPosition = m_objMediaPosition.CurrentPosition
End Property
Public Property Let MediaPosition(ByVal Position As Double)
m_objMediaPosition.CurrentPosition = Position
End Property
'声道平衡的获取和设置
Public Property Get Balance() As Integer
Balance = m_Bal
End Property
Public Property Let Balance(ByVal bal As Integer)
m_Bal = bal
m_objBasicAudio.Balance = bal * 50
End Property
'获取媒体播放长度
Public Property Get Duration() As Double
Duration = m_dblRunLength
End Property
'检测媒体是否在播放
Public Property Get isPlaying() As Boolean
isPlaying = IIf(m_objMediaPosition.CurrentPosition < m_dblRunLength, True, False)
End Property
'播放媒体
Public Sub PlayMedia()
If CLng(m_objMediaPosition.CurrentPosition) < CLng(m_dblStartPosition) Then
m_objMediaPosition.CurrentPosition = m_dblStartPosition
ElseIf CLng(m_objMediaPosition.CurrentPosition) = CLng(m_dblRunLength) Then
m_objMediaPosition.CurrentPosition = m_dblStartPosition
End If
Call m_objMediaControl.Run
m_boolVideoRunning = True
DoEvents
DoEvents
End Sub
'暂停播放
Public Sub PauseMedia()
Call m_objMediaControl.Pause
m_boolVideoRunning = False
End Sub
'停止播放
Public Sub StopMedia()
Call m_objMediaControl.Stop
m_boolVideoRunning = False
m_objMediaPosition.CurrentPosition = 0
End Sub
'卸载DShow
Public Sub UnloadDXShow()
m_boolVideoRunning = False
DoEvents
If Not m_objMediaControl Is Nothing Then
m_objMediaControl.Stop
End If
' If Not m_objVideoWindow Is Nothing Then
' m_objVideoWindow.Left = Screen.Width * 8
' m_objVideoWindow.Height = Screen.Height * 8
' m_objVideoWindow.Owner = 0
' End If
If Not m_objBasicAudio Is Nothing Then Set m_objBasicAudio = Nothing
If Not m_objBasicVideo Is Nothing Then Set m_objBasicVideo = Nothing
If Not m_objMediaControl Is Nothing Then Set m_objMediaControl = Nothing
If Not m_objVideoWindow Is Nothing Then Set m_objVideoWindow = Nothing
If Not m_objMediaPosition Is Nothing Then Set m_objMediaPosition = Nothing
End Sub
Private Sub Class_Initialize()
m_Vol = 100
End Sub
xAudio.clsこのモジュールは、主にウォーキングサウンド、ドア開閉サウンドなどのサウンドエフェクトを再生するために使用されます。
'impactX Game Engine
'本类模块用于对WAV,MIDI格式的声音进行回放和处理
'使用本类模块必须遵守:
'你可以免费使用本引擎及代码
'使用本引擎后的责任由使用者承担
'你可以任意拷贝本引擎代码，但必须保证其完整性
'希望我能得到你使用本引擎制作出的程序
'Davy.xu [email protected] qq:20998333
Option Explicit
Dim DX As New DirectX8
Dim DS As DirectSound8
Dim DMA As DMUS_AUDIOPARAMS
'Dim myDSBuff(0 To 8) As DirectSoundSecondaryBuffer8
'Public myBuffDESC As DSBUFFERDESC
'Dim myWavFormat As WAVEFORMATEX
Dim DAperformance As DirectMusicPerformance8 '播放器
Dim DAloader As DirectMusicLoader8 '载入器
Dim dmPath As DirectMusicAudioPath8 '媒体路径,做调节音量用
Dim m_PausePos As Long '停止位置(待修正)
'功能:初始化DirectAudio
Public Function InitDXAudio(hWnd As Long) As Boolean
On Error GoTo ErrH
Set DAloader = DX.DirectMusicLoaderCreate
Set DAperformance = DX.DirectMusicPerformanceCreate
DAperformance.InitAudio hWnd, DMUS_AUDIOF_ALL, DMA, Nothing, DMUS_APATH_DYNAMIC_STEREO, 64
Set dmPath = DAperformance.CreateStandardAudioPath(DMUS_APATH_DYNAMIC_STEREO, 64, True)
InitDXAudio = True
Exit Function
ErrH:
Debug.Print "Err:[InitDXAudio] 初始化错误"
InitDXAudio = False
End Function
'功能:初始化DirectAudio的WAVE处理部分
Public Function InitDXSound(hWnd As Long) As Boolean
InitDXSound = False
'建立播放对象控件
Set DS = DX.DirectSoundCreate(vbNullString)
DS.SetCooperativeLevel hWnd, DSSCL_PRIORITY '建立缓冲区
InitDXSound = True
End Function
Public Function LoadWav(Pathname As String) As DirectSoundSecondaryBuffer8
On Error GoTo ErrH
Dim DSbufSC As DSBUFFERDESC
Pathname = Trim(Pathname)
If Len(Pathname) = 0 Then
Debug.Print "Err [LoadWav] 路径为空"
End
End If
If Mid(Pathname, 2, 1) <> ":" Then Pathname = App.Path & "\" & Pathname
If LCase(Right(Pathname, 3)) <> "wav" And LCase(Right(Pathname, 3)) <> "mid" Then
Debug.Print "Err [LoadWav] 载入格式不正确,只能载入wav文件"
End
End If
If Len(Dir(Pathname)) = 0 Then
Debug.Print "Err:[LoadWav] 文件不存在"
Debug.Print Pathname
End
End If
DSbufSC.lFlags = DSBCAPS_CTRLVOLUME Or DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN Or DSBCAPS_STATIC Or DSBCAPS_CTRLPOSITIONNOTIFY
Set LoadWav = DS.CreateSoundBufferFromFile(Pathname, DSbufSC)
Exit Function
ErrH:
Debug.Print "Err [LoadWav] 载入错误"
Debug.Print Pathname
End Function
'功能:载入音乐文件
'参数:音乐缓冲索引,路径.没有盘符的路径自动识别为工作目录
Public Function LoadAudio(Pathname As String) As DirectMusicSegment8
On Error GoTo ErrH
Pathname = Trim(Pathname)
If Len(Pathname) = 0 Then
Debug.Print "Err [LoadAudio] 路径为空"
End
End If
If Mid(Pathname, 2, 1) <> ":" Then Pathname = App.Path & "\" & Pathname
If LCase(Right(Pathname, 3)) <> "wav" And LCase(Right(Pathname, 3)) <> "mid" Then
Debug.Print "Err [LoadAudio] 载入格式不正确,只能载入wav和mid文件"
End
End If
If Len(Dir(Pathname)) = 0 Then
Debug.Print "Err:[LoadAudio] 文件不存在"
Debug.Print Pathname
End
End If
Set LoadAudio = DAloader.LoadSegment(Pathname)
LoadAudio.Download dmPath
Exit Function
ErrH:
Debug.Print "Err [LoadAudio] 载入错误 "
Debug.Print Pathname
Debug.Print "在非NT系统中(如Win98),请不要在路径中带有中文"
End Function
'功能: 播放索引号对应音乐缓冲里的音乐
Public Sub PlayAudio(Buf As DirectMusicSegment8, Optional isRepeat As Boolean = False)
On Error GoTo ErrH
If isRepeat Then
Buf.SetRepeats INFINITE
End If
DAperformance.PlaySegmentEx Buf, DMUS_SEGF_SECONDARY, 0, Nothing, dmPath
Exit Sub
ErrH:
Debug.Print "Err [PlayAudio] 播放时错误"
End Sub
'功能: 播放索引号对应音乐缓冲里的音乐
Public Sub PlayWav(Buf As DirectSoundSecondaryBuffer8, Optional isRepeat As Boolean = False)
On Error GoTo ErrH
Buf.SetCurrentPosition 0
If isRepeat Then
Buf.Play DSBPLAY_LOOPING
Else
Buf.Play DSBPLAY_DEFAULT
End If
Exit Sub
ErrH:
If Buf Is Nothing Then
Debug.Print "Err [PlayWav] 没有载入音乐，播放时错误"
Else
Debug.Print "Err [PlayWav] 播放时错误 "
End If
End Sub
'功能:停止播放音乐
Public Sub StopWav(Buf As DirectSoundSecondaryBuffer8)
On Error GoTo ErrH
Buf.Stop
Exit Sub
ErrH:
Debug.Print "Err [StopWav] 停止时错误"
End Sub
'功能:停止播放音乐
Public Sub StopAudio(Buf As DirectMusicSegment8)
On Error GoTo ErrH
m_PausePos = Buf.GetStartPoint
DAperformance.StopEx Buf, 0, 0
Exit Sub
ErrH:
Debug.Print "Err [StopAudio] 停止时错误 "
End Sub
'功能:设置Wav音乐音量
'参数:范围(0~100)
Public Sub SetWavVolume(Buf As DirectSoundSecondaryBuffer8, Volume As Integer)
If Volume < 0 Or Volume > 100 Then Exit Sub
Buf.SetVolume Volume * 30 - 3000
End Sub
'功能:设定声音左右平衡度
'参数:范围(左)-10~10(右)
Public Sub SetWavPan(Buf As DirectSoundSecondaryBuffer8, Lev As Integer)
If Lev < -10 Or Lev > 10 Then Exit Sub
Buf.SetPan ((Lev + 10) * 5 - 50) * 100
End Sub
'功能:设置音乐音量
'参数:范围(0~100)
Public Sub SetAudioVolume(Vol As Integer)
If Vol < 0 Or Vol > 100 Then Exit Sub
dmPath.SetVolume -(1 - Vol / 100) * 5000, 0
End Sub
'功能:音乐是否在播放
Public Function IsWavPlaying(Buf As DirectSoundSecondaryBuffer8) As Boolean
IsWavPlaying = IIf(Buf.GetStatus = DSBSTATUS_PLAYING, True, False)
End Function
'功能:音乐是否在播放
Public Function IsAudioPlaying(Buf As DirectMusicSegment8) As Boolean
IsAudioPlaying = DAperformance.isPlaying(Buf, Nothing)
End Function
'功能:设定声音左右平衡度
'参数:范围(左)-10~10(右)
Public Sub SetAudioBalance(Lev As Integer)
If Lev < -10 Or Lev > 10 Then Exit Sub
Dim DSbuf As DirectSound3DBuffer8
Set DSbuf = dmPath.GetObjectinPath(DMUS_PCHANNEL_ALL, DMUS_PATH_BUFFER, 0, vbNullString, 0, "IID_IDirectSound3DBuffer")
DSbuf.SetPosition Lev / 5, 0, 0, DS3D_IMMEDIATE
Set DSbuf = Nothing
End Sub
'卸载DirectAudio
Public Sub UnloadDXAudio()
On Error GoTo ErrH
Dim i As Long
DAperformance.CloseDown '关闭DirectMusicPerformance8
Set DAperformance = Nothing
Set DAloader = Nothing
Set DS = Nothing
Exit Sub
ErrH:
Debug.Print "Err [UnloadDXAudio] 卸载错误"
End Sub
'卸载DirectAudio
Public Sub UnloadDXSound()
Set DS = Nothing
End Sub
Public Sub ReleaseWav(Buf As DirectSoundSecondaryBuffer8)
Set Buf = Nothing
End Sub
Public Sub ReleaseAudio(Buf As DirectMusicSegment8)
Set Buf = Nothing
End Sub