把以下代码复制存为FORM1.FRM即可,两个MID文件假设分别为1.MID,2.MID
请根据自己的文件名进行修改

代码开始:


VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "连续循环播放MID背景音乐"
ClientHeight = 810
ClientLeft = 45
ClientTop = 435
ClientWidth = 4680
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 810
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command3
Caption = "结束"
Height = 495
Left = 3240
TabIndex = 2
Top = 120
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "播放"
Height = 495
Left = 120
TabIndex = 1
Top = 120
Width = 1455
End
Begin VB.CommandButton Command2
Caption = "停止"
Height = 495
Left = 1680
TabIndex = 0
Top = 120
Width = 1455
End
Begin VB.Timer Timer1
Left = 4080
Top = 960
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'看我的播放模块
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As

Long) As Long
Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal

lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal

lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Long, ByVal uMessage As

Long, ByVal dwParam1 As Long, ByVal dwParam2 As Any) As Long
Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2

Public PlayError As Boolean '是否错误

Private PLAYMusicFileName As Integer '播放那一首音乐

'测试是否安装了声卡
Public Function TestSound() As Boolean
Dim Ret As Long
Ret& = waveOutGetNumDevs
If Ret > 0 Then
TestSound = True
Else
TestSound = False
End If
'TestSound = False
End Function



'播放音乐mp3,wav,mid等
Public Sub PlayMusic(FileName As String)
Dim Buffer As String * 128
Dim Ret As Long
Dim PlayStatus As String * 20
Dim ShortFileName As String
mciExecute "close all"
If Dir(FileName) = "" Then PlayError = True: Exit Sub
ShortFileName = ShortName(FileName)
mciSendString "open " & ShortFileName & " alias mp3", Buffer, Ret, 0
mciSendString "play mp3", Buffer, Ret, 0
PlayError = False
End Sub

Public Sub StopMusic() '停止播放
Dim Buffer As String * 128
Dim Ret As Long
mciSendString "stop mp3", Buffer, Ret, 0
End Sub


Public Function GetPlayMode() As String '得到播放状态
Dim Buffer As String * 128
Dim pos As Integer
mciSendString "status mp3 mode", Buffer, 128, 0&
pos = InStr(Buffer, Chr(0))
GetPlayMode = Left(Buffer, pos - 1)
End Function

'得到文件短文件名
Function ShortName(LongPath As String) As String
Dim ShortPath As String
Dim pos As String
Dim Ret As Long
Const MAX_PATH = 260
If LongPath = "" Then Exit Function
ShortPath = Space$(MAX_PATH)
Ret& = GetShortPathName(LongPath, ShortPath, MAX_PATH)
If Ret& Then
pos = InStr(1, ShortPath, " ")
ShortName = Left$(ShortPath, pos - 2)
End If
End Function

'此函数从字符串中分离出文件名
Function ParseFileName(sFileIn As String) As String
Dim i As Integer
For i = Len(sFileIn) To 1 Step -1
If InStr("\", Mid$(sFileIn, i, 1)) Then Exit For
Next
ParseFileName = Mid$(sFileIn, i + 1, Len(sFileIn) - i)
End Function

Private Sub Command1_Click() '播放
Dim PathName As String, S As String, ShortPathName As String
'当前目录
PathName = App.Path
If Right(PathName, 1) <> "\" Then PathName = PathName & "\"
PLAYMusicFileName = PLAYMusicFileName + 1 '播放那一首歌

Select Case PLAYMusicFileName
Case 1 '播放第1首歌
'文件名
PathName = PathName & "1.mid" '"1.mp3"'"1.wav"'(支持三种文件格式)

Case 2 '播放第2首歌
'文件名
PathName = PathName & "2.mid" '"1.mp3"'"1.wav"'(支持三种文件格式)
'播放完毕继续播放
If PLAYMusicFileName = 2 Then PLAYMusicFileName = 0
End Select
If Dir(PathName) = "" Then MsgBox "没有发现文件": PLAYErr: Exit Sub '没有发现文件,防错处理

Me.Caption = "正在播放: " & ParseFileName(PathName) '我的标题=文件名

'得到文件短文件名
ShortPathName = ShortName(PathName)
PlayMusic ShortPathName '播放音乐
Timer1.Enabled = True '启动时间检测播放状态
End Sub


'
Private Sub Command2_Click() '停止播放
StopMusic
Timer1.Enabled = False
End Sub

Private Sub Command3_Click()
Unload Me '结束程序
End Sub

'
Private Sub Form_Load()
If TestSound = True Then '测试是否安装了声卡
Timer1.Interval = 500 '每半秒检查一次播放状态
Command1.Caption = "播放"
Command2.Caption = "关闭"
Command1_Click '开始播放
Else
MsgBox "'你没有安装声卡,不能播放音乐"
PLAYErr '防错处理
End If
End Sub

Private Sub PLAYErr() '防错处理
Timer1.Enabled = False
Command1.Enabled = False
Command2.Enabled = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
StopMusic '停止播放
End Sub

Private Sub Form_Unload(Cancel As Integer) '结束程序
Set Form1 = Nothing
End
End Sub

Private Sub Timer1_Timer()
Dim S As String
S = GetPlayMode '得到播放状态
If S = "stopped" Then Command1_Click '如果停止就循环播放
End Sub



'代码结束