用VB6来实现QBASIC中的Play语句
很久以前写的了，用Midi的API函数来实现以前QBasic中的Play语句，控制符实现可能还不完善，感觉演奏的还是有些问题，懒得弄了，发出来吧。希望有人可以接着完善一下，关于Play语句可以参考一下这个https://www.cnblogs.com/djcsch2001/articles/1965318.html
用法，Play "ABCDEFGAB"
下边是这个bas模块文件的代码，例程代码下载地址 https://download.csdn.net/download/bakw/88457053
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Public Declare Function midiOutGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function timeGetDevCaps Lib "winmm.dll" (lpTimeCaps As TIMECAPS, ByVal uSize As Long) As Long
Public Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Public Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Public Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Public Const MIDI_MAPPER = -1 'MIDI
Public Const DSSCL_PRIORITY = 2 'DX7
Type MIDIOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * 32
wTechnology As Integer
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type
Type TIMECAPS
wPeriodMin As Long
wPeriodMax As Long
End Type
Private NumDevs As Long
Private WaveNumDevs As Long
Private BestRes As Long
Public Function Initialize() As Long
Dim TC As TIMECAPS, Rv As Long
Dim hMidiOut As Long
Initialize = 0
NumDevs = midiOutGetNumDevs()
WaveNumDevs = waveOutGetNumDevs()
Rv = timeGetDevCaps(TC, Len(TC))
If Rv <> 0 Then Exit Function 'Exit
BestRes = TC.wPeriodMin
Rv = timeBeginPeriod(BestRes)
If Rv <> 0 Then Exit Function 'Exit
Rv = midiOutOpen(hMidiOut, MIDI_MAPPER, 0, 0, 0)
If Rv <> 0 Then
timeEndPeriod BestRes
Exit Function 'Exit
End If
Initialize = hMidiOut
End Function
Public Sub Terminate(ByVal hMidiOut As Long)
timeEndPeriod BestRes
midiOutClose hMidiOut
End Sub
Public Sub Play(ByVal MusicStr As String)
Dim hMidiOut As Long, dwMsg As Long, I As Long, J As Integer, L As Integer, F As Integer
Dim CH As String, Num As Integer, BFlip As Integer, T As Long, XT As Long
Dim Volume As Integer, Channel As Integer, BT As Long, Flip As Integer
MusicStr = Replace(MusicStr, Chr(0), "")
MusicStr = Replace(MusicStr, Chr(32), "")
hMidiOut = 0
Volume = 100
Channel = 0
BT = 500
BFlip = 60
L = Len(MusicStr)
If L = 0 Then Exit Sub
hMidiOut = Initialize
If hMidiOut = 0 Then
Debug.Print "Initialize Error"
Exit Sub
End If
I = 1
T = BT
XT = 0
F = 0
Flip = BFlip
Do
XT = 0
Flip = 0
CH = UCase(Mid(MusicStr, I, 1))
I = I + 1
Select Case CH
Case "A", "B", "C", "D", "E", "F", "G"
Select Case CH
Case "A"
Flip = BFlip + 10
Case "B"
Flip = BFlip + 12
Case "C"
Flip = BFlip
Case "D"
Flip = BFlip + 2
Case "E"
Flip = BFlip + 4
Case "F"
Flip = BFlip + 6
Case "G"
Flip = BFlip + 8
End Select
If I <= L Then CH = Mid(MusicStr, I, 1) Else CH = ""
If (CH = "+") Or (CH = "#") Then
Flip = Flip + 1
I = I + 1
ElseIf (CH = "-") Or (CH = "$") Then
Flip = Flip - 1
I = I + 1
End If
CH = ""
If I <= L Then
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
End If
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 1
If Num = 0 Then Num = 1
If I <= L Then CH = Mid(MusicStr, I, 1) Else CH = ""
T = CLng(BT / Num)
If CH = "." Then
I = I + 1
XT = 0.5 * T
End If
Case "L"
CH = ""
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 1
If Num = 0 Then Num = 1
T = CLng(BT / Num)
XT = -T
Case "M"
Select Case Mid(MusicStr, I, 1)
Case "N"
F = 1
Case "L"
F = 0
End Select
Case "O"
CH = ""
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 4
BFlip = 4 + 14 * Num
XT = -T
Case "P", "R"
CH = ""
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 1
If Num = 0 Then Num = 1
If I <= L Then CH = Mid(MusicStr, I, 1) Else CH = ""
T = CLng(BT / Num)
If CH = "." Then
I = I + 1
XT = 0.5 * T
End If
Case "T"
CH = ""
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 0
If Num > 0 Then BT = 60000 \ Num
Case "V"
CH = ""
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 100
Volume = Num
Case "Y"
CH = ""
Do Until Not IsNumeric(Mid(MusicStr, I, 1))
CH = CH & Mid(MusicStr, I, 1)
I = I + 1
If I > L Then Exit Do
Loop
If IsNumeric(CH) Then Num = CInt(CH) Else Num = 0
If hMidiOut <> 0 Then midiOutShortMsg hMidiOut, CLng(Num) * &H100 + &HC0 + CLng(Channel)
XT = -T
Case Else
End Select
If Flip > 0 Then
dwMsg = CLng(Volume) * &H10000 + CLng(Flip) * &H100 + &H90 + CLng(Channel)
If hMidiOut <> 0 Then midiOutShortMsg hMidiOut, dwMsg
End If
Sleep T + XT
If Flip > 0 Or F > 0 Then
dwMsg = CLng(Flip) * &H100 + &H80 + CLng(Channel)
If hMidiOut <> 0 Then midiOutShortMsg hMidiOut, dwMsg
End If
Loop Until I > Len(MusicStr)
If hMidiOut <> 0 Then Terminate hMidiOut
End Sub