vb6.0简谱播放器代码ZQZX-2025-4-13-优快云博客

本文链接：https://blog.youkuaiyun.com/qq_32257509/article/details/147222614

Private Declare Function GetKeyState% Lib “user32” (ByVal nVirtKey As Long)
Private Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)
Private sudu As Integer
Private Const VK_LBUTTON& = &H1
Private isOgain As Boolean '是否重复按键
Private Sta As Integer

Private Declare Function midiOutGetDevCaps Lib “winmm.dll” Alias “midiOutGetDevCapsA” (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib “winmm” () As Integer
Private Declare Function MIDIOutOpen Lib “winmm.dll” Alias “midiOutOpen” (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiOutClose Lib “winmm.dll” (ByVal hMidiOut As Long) As Long
Private Declare Function midiOutShortMsg Lib “winmm.dll” (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function midiOutGetErrorText Lib “winmm.dll” Alias “midiOutGetErrorTextA” (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long

Private Const MAXERRORLENGTH = 128 '最大错误文本长度（包括 NULL）
Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
'MIDIOUTCAPS结构描述了Musical Instrument Digital Interface(MIDI)输入设备的性能
Private Type MIDIOUTCAPS
wMid As Integer
wPid As Integer '产品 ID
vDriverVersion As Long '设备版本
szPname As String * 32 '设备 name
wTechnology As Integer '设备类型
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type

Dim hMidi As Long

Dim k As Integer

Private Function Midi_OutDevsToList(Obj As Control) As Boolean
Dim i As Integer
Dim midicaps As MIDIOUTCAPS
Dim isAdd As Boolean

Obj.Clear
isAdd = False
If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then    '若获取设备信息成功
      Obj.AddItem midicaps.szPname       '添加设备名称
      Obj.ItemData(Obj.NewIndex) = MIDIMAPPER   '这是默认设备ID  = -1
      isAdd = True
End If
    '添加其他设备
For i = 0 To midiOutGetNumDevs() - 1
    If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then
      Obj.AddItem midicaps.szPname
      Obj.ItemData(Obj.NewIndex) = i
      isAdd = True
    End If
Next
Midi_OutDevsToList = isAdd

End Function

Private Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer
midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)
MIDI_OutOpen = (hMidi <> 0)
End Function

Private Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)
Call midi_outshort(&H90 + ch, kk, v)
End Sub

Private Sub note_off(ch As Integer, ByVal kk As Integer)
Call midi_outshort(&H80 + ch, kk, 0)
End Sub

Private Sub midi_OutClose()
Dim midi_error As Integer
midi_error = midiOutClose(hMidi)
hMidi = 0
End Sub

Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub

Sub midi_outshort(b1 As Integer, b2 As Integer, b3 As Integer)
Dim midi_error As Integer
midi_error = midiOutShortMsg(hMidi, b3 * &H10000 + b2 * &H100 + b1)
End Sub

Private Sub Combo1_Click()
Dim dl As Integer
dl = MIDI_OutOpen(Combo1.ItemData(Combo1.ListIndex))
Combo1.ListIndex = 0
End Sub

Private Sub Combo2_Click()
Call program_change(0, 0, Combo2.ListIndex)
End Sub

Private Sub Command3_Click()
Dim s1 As String
Dim s2 As String
Dim notes1() As String
Dim notes2() As String
Dim i As Integer
Dim midiNote1 As Integer
Dim midiNote2 As Integer
Dim duration1 As Double
Dim duration2 As Double
k = Int(Text3.Text)
s1 = Text1.Text
s2 = Text2.Text '假设第二个文本框的名称为 Text2

notes1 = Split(s1, ",")
notes2 = Split(s2, ",")

Dim maxLength As Integer
maxLength = IIf(UBound(notes1) > UBound(notes2), UBound(notes1), UBound(notes2))

For i = 0 To maxLength
    Dim note1 As String
    Dim note2 As String
    
    If i <= UBound(notes1) Then
        note1 = notes1(i)
    Else
        note1 = "" '如果第一个字符串结束了，设置为空字符串
    End If
    
    If i <= UBound(notes2) Then
        note2 = notes2(i)
    Else
        note2 = "" '如果第二个字符串结束了，设置为空字符串
    End If
    
    midiNote1 = ParseNote(note1)
    midiNote2 = ParseNote(note2)
    duration1 = durationFactor(note1)
    duration2 = durationFactor(note2)
    
    If midiNote1 > 0 Then
        Call note_on(0, midiNote1 + Sta, sudu) '使用 note_on 过程播放音符
    End If
    
    If midiNote2 > 0 Then
        Call note_on(0, midiNote2 + Sta, sudu) '使用 note_on 过程播放音符
    End If
    
    Dim maxDuration As Double
    maxDuration = IIf(duration1 > duration2, duration1, duration2)
    Sleep k * maxDuration
    
    If midiNote1 > 0 Then
        Call note_off(0, midiNote1 + Sta)
    End If
    If midiNote2 > 0 Then
        Call note_off(0, midiNote2 + Sta)
    End If
Next

End Sub

Private Function ParseNote(note As String) As Integer
Dim baseNote As Integer
Dim octave As Integer
Dim accidental As Integer
octave = 0
accidental = 0

Dim pos As Integer
pos = 1

' 处理八度和半音变化
Do While pos <= Len(note)
    Dim char As String
    char = Mid(note, pos, 1)
    Select Case char
        Case "+"
            octave = octave + 12
            pos = pos + 1
        Case "-"
            If pos = 1 And (Mid(note, pos + 1, 1) Like "[0-9]") Then
                octave = octave - 12
                pos = pos + 1
            Else
                Exit Do
            End If
        Case "#"
            accidental = accidental + 1
            pos = pos + 1
        Case "!"
            accidental = accidental - 1
            pos = pos + 1
        Case Else
            Exit Do
    End Select
Loop

' 处理基本音符
If pos <= Len(note) Then
    Dim noteChar As String
    noteChar = Mid(note, pos, 1)
    Select Case noteChar
        Case "1"
            baseNote = 60 ' 中央 C
        Case "2"
            baseNote = 62
        Case "3"
            baseNote = 64
        Case "4"
            baseNote = 65
        Case "5"
            baseNote = 67
        Case "6"
            baseNote = 69
        Case "7"
            baseNote = 71
        Case "0"
            baseNote = 0
        Case Else
            baseNote = 0
    End Select
End If

ParseNote = baseNote + octave + accidental
Debug.Print "Parsed note: " & note & " -> " & ParseNote ' 调试信息

End Function

Private Sub Form_Load()
Dim Retu As Boolean
Dim i As Integer

Retu = Midi_OutDevsToList(Combo1)
Combo1.ListIndex = 0
Call fill_sound_list

For i = 0 To 64
   Picture1(i).DragMode = 1
Next
HScroll1.Value = 7
HScroll2.Value = 100

End Sub

Private Sub fill_sound_list()
Dim s As String
Combo2.AddItem “大钢琴（声学钢琴）0”
Combo2.AddItem “明亮的钢琴1”
Combo2.AddItem “电钢琴2”
Combo2.AddItem “酒吧钢琴3”
Combo2.AddItem “柔和的电钢琴4”
Combo2.AddItem “加合唱效果的电钢琴5”
Combo2.AddItem “羽管键琴（拨弦古钢琴）6”
Combo2.AddItem “科拉维科特琴（击弦古钢琴）7”
Combo2.AddItem “钢片琴8”
Combo2.AddItem “钟琴9”
Combo2.AddItem “八音盒10”
Combo2.AddItem “颤音琴11”
Combo2.AddItem “马林巴12”
Combo2.AddItem “木琴13”
Combo2.AddItem “管钟14”
Combo2.AddItem “大扬琴15”
Combo2.AddItem “击杆风琴16”
Combo2.AddItem “打击式风琴17”
Combo2.AddItem “摇滚风琴18”
Combo2.AddItem “教堂风琴19”
Combo2.AddItem “簧管风琴20”
Combo2.AddItem “手风琴21”
Combo2.AddItem “口琴22”
Combo2.AddItem “探戈手风琴23”
Combo2.AddItem “尼龙弦吉他24”
Combo2.AddItem “钢弦吉他25”
Combo2.AddItem “爵士电吉他26”
Combo2.AddItem “清音电吉他27”
Combo2.AddItem “闷音电吉他28”
Combo2.AddItem “加驱动效果的电吉他29”
Combo2.AddItem “加失真效果的电吉他30”
Combo2.AddItem “吉他和音31”
Combo2.AddItem “大贝司（声学贝司）32”
Combo2.AddItem “电贝司（指弹）33”
Combo2.AddItem “电贝司（拨片）34”
Combo2.AddItem “无品贝司35”
Combo2.AddItem “掌击贝司136”
Combo2.AddItem “掌击贝司237”
Combo2.AddItem “电子合成贝司138”
Combo2.AddItem “电子合成贝司239”
Combo2.AddItem “小提琴40”
Combo2.AddItem “中提琴41”
Combo2.AddItem “大提琴42”
Combo2.AddItem “低音大提琴43”
Combo2.AddItem “弦乐群颤音音色44”
Combo2.AddItem “弦乐群拨弦音色45”
Combo2.AddItem “竖琴46”
Combo2.AddItem “定音鼓47”
Combo2.AddItem “弦乐合奏音色148”
Combo2.AddItem “弦乐合奏音色249”
Combo2.AddItem “合成弦乐合奏音色150”
Combo2.AddItem “合成弦乐合奏音色251”
Combo2.AddItem “人声合唱啊52”
Combo2.AddItem “人声嘟53”
Combo2.AddItem “合成人声54”
Combo2.AddItem “管弦乐敲击齐奏55”
Combo2.AddItem “小号56”
Combo2.AddItem “长号57”
Combo2.AddItem “大号58”
Combo2.AddItem “加弱音器小号59”
Combo2.AddItem “法国号（圆号）60”
Combo2.AddItem “铜管组（铜管乐器合奏音色）61”
Combo2.AddItem “合成铜管音色162”
Combo2.AddItem “合成铜管音色263”
Combo2.AddItem “高音萨克斯风64”
Combo2.AddItem “次中音萨克斯风65”
Combo2.AddItem “中音萨克斯风66”
Combo2.AddItem “低音萨克斯风67”
Combo2.AddItem “双簧管68”
Combo2.AddItem “英国管69”
Combo2.AddItem “巴松（大管）70”
Combo2.AddItem “单簧管（黑管）71”
Combo2.AddItem “短笛72”
Combo2.AddItem “长笛73”
Combo2.AddItem “竖笛74”
Combo2.AddItem “排箫75”
Combo2.AddItem “吹瓶声76”
Combo2.AddItem “日本尺八77”
Combo2.AddItem “口哨声78”
Combo2.AddItem “奥卡雷那79”
Combo2.AddItem “合成主音1（方波）80”
Combo2.AddItem “合成主音2（锯齿波）81”
Combo2.AddItem “合成主音382”
Combo2.AddItem “合成主音483”
Combo2.AddItem “合成主音584”
Combo2.AddItem “合成主音6（人声）85”
Combo2.AddItem “合成主音7（平行五度）86”
Combo2.AddItem “合成主音8（贝司加主音）87”
Combo2.AddItem “合成音色1（新世纪）88”
Combo2.AddItem “合成音色2（温暖）89”
Combo2.AddItem “合成音色390”
Combo2.AddItem “合成音色4（合唱）91”
Combo2.AddItem “合成音色592”
Combo2.AddItem “合成音色6（金属声）93”
Combo2.AddItem “合成音色7（光环）94”
Combo2.AddItem “合成音色895”
Combo2.AddItem “合成效果1雨声96”
Combo2.AddItem “合成效果2音轨97”
Combo2.AddItem “合成效果3水晶98”
Combo2.AddItem “合成效果4大气99”
Combo2.AddItem “合成效果5明亮100”
Combo2.AddItem “合成效果6鬼怪101”
Combo2.AddItem “合成效果7回声102”
Combo2.AddItem “合成效果8科幻103”
Combo2.AddItem “西塔尔（印度）104”
Combo2.AddItem “班卓琴（美洲）105”
Combo2.AddItem “三昧线（日本）106”
Combo2.AddItem “十三弦筝（日本）107”
Combo2.AddItem “卡林巴108”
Combo2.AddItem “风笛109”
Combo2.AddItem “民族提琴110”
Combo2.AddItem “唢呐111”
Combo2.AddItem “叮当铃112”
Combo2.AddItem “阿哥哥鼓113”
Combo2.AddItem “钢鼓114”
Combo2.AddItem “木鱼115”
Combo2.AddItem “太鼓116”
Combo2.AddItem “古高音鼓117”
Combo2.AddItem “合成鼓118”
Combo2.AddItem “铜钹119”
Combo2.AddItem “磨弦120”
Combo2.AddItem “呼吸声121”
Combo2.AddItem “海浪声122”
Combo2.AddItem “鸟鸣123”
Combo2.AddItem “电话铃124”
Combo2.AddItem “直升机125”
Combo2.AddItem “鼓掌声126”
Combo2.AddItem “枪声127”

Combo2.ListIndex = 0

End Sub

Private Sub HScroll1_Change()
Sta = HScroll1.Value
Label4.Caption = Diao(Sta Mod 12)
End Sub

Private Sub HScroll2_Change()
sudu = HScroll2.Value
End Sub

Private Sub Picture1_DragOver(Index As Integer, Source As Control, x As Single, Y As Single, State As Integer)
'完成发音
Static OldNote As Integer
If (OldNote <> Index) Then
Call note_off(0, OldNote + Sta)
Call note_on(0, Index + Sta, sudu) '参数分别为通道编号，音调，速度
OldNote = Index
isOgain = False
End If
End Sub

Private Function Diao(i As Integer) As String
Select Case i
Case 0
Diao = “C”
Case 1
Diao = “C#”
Case 2
Diao = “D”
Case 3
Diao = “D#”
Case 4
Diao = “E”
Case 5
Diao = “F”
Case 6
Diao = “F#”
Case 7
Diao = “G”
Case 8
Diao = “G#”
Case 9
Diao = “A”
Case 10
Diao = “A#”
Case 11
Diao = “B”
End Select
End Function

Private Sub Command4_Click()
Dim s As String
Dim notes() As String
Dim i As Integer
Dim midiNote As Integer
Dim duration As Double
k = Int(Text3.Text)
s = Text1.Text
notes = Split(s, “,”)

For i = LBound(notes) To UBound(notes)
    Dim note As String
    note = notes(i)
    midiNote = ParseNote(note)
    duration = durationFactor(note)
    
    If midiNote > 0 Then
        Call note_on(0, midiNote + Sta, sudu)
        Sleep k * duration
        Call note_off(0, midiNote + Sta)
    Else
        Sleep k * duration
    End If
Next

End Sub

Private Sub Command5_Click()
Dim s As String
Dim notes() As String
Dim i As Integer
Dim midiNote As Integer
Dim duration As Double
k = Int(Text3.Text)
s = Text2.Text
notes = Split(s, “,”)

For i = LBound(notes) To UBound(notes)
    Dim note As String
    note = notes(i)
    midiNote = ParseNote(note)
    duration = durationFactor(note)
    
    If midiNote > 0 Then
        Call note_on(0, midiNote + Sta, sudu)
        Sleep k * duration
        Call note_off(0, midiNote + Sta)
    Else
        Sleep k * duration
    End If
Next

End Sub

Private Function durationFactor(note As String) As Double
Dim factor As Double
factor = 1 '默认值为1（四分音符）

' 处理斜杠
Dim slashCount As Integer
slashCount = 0
Dim pos As Integer
pos = InStr(note, "/")
Do While pos > 0
    slashCount = slashCount + 1
    pos = InStr(pos + 1, note, "/")
Loop
factor = factor / (2 ^ slashCount)

' 处理延音线
Dim dashCount As Integer
dashCount = 0
pos = InStr(note, "-")
Do While pos > 0
    If pos > InStr(note, "/") Then
        dashCount = dashCount + 1
    End If
    pos = InStr(pos + 1, note, "-")
Loop
factor = factor * (2 ^ dashCount)

' 处理附点
Dim dotCount As Integer
dotCount = 0
pos = InStr(note, ".")
Do While pos > 0
    If pos > InStr(note, "-") Then
        dotCount = dotCount + 1
    End If
    pos = InStr(pos + 1, note, ".")
Loop
For i = 1 To dotCount
    factor = factor * 1.5
Next i

durationFactor = factor

End Function