用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