救急！·救急！！高手请赐教！！在vb 中如何调用系统发音函数呢

API,
From1
'*程序编号∶033
'*功    能∶MIDI电子琴
'*日    期∶4/25/1999
'************************************************************
Option ExplicitPrivate Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)
Private sudu As Integer
Private Const VK_LBUTTON& = &H1
Private isOgain As Boolean   '是否重复按键
Private Sta As Integer
Private oldidx As IntegerPrivate Sub ComDevies_Click()
   Dim dl As Integer
   dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End SubPrivate Sub Command1_Click()
   Unload Me
End SubPrivate Sub Command2_Click()
    Open App.Path & "\haap.txt" For Input As #1
    ComDevies.ListIndex = 0
    ComSounds.ListIndex = 9
    HScroll1.Value = 32
    Timer2.Enabled = True
    Command2.Enabled = False
End SubPrivate Sub ComSounds_Click()
       Call program_change(0, 0, ComSounds.ListIndex)
End SubPrivate Sub Form_KeyPress(KeyAscii As Integer)
Dim idx As Integer
    KeyAscii = Asc(UCase(Chr(KeyAscii)))
    Select Case KeyAscii
        Case vbKey1: idx = 41
        Case vbKey2: idx = 43
        Case vbKey3: idx = 45
        Case vbKey4: idx = 47
        Case vbKey5: idx = 48
        Case vbKey6: idx = 50
        Case vbKey7: idx = 52
        Case vbKeyQ: idx = 29
        Case vbKeyW: idx = 31
        Case vbKeyE: idx = 33
        Case vbKeyR: idx = 35
        Case vbKeyT: idx = 36
        Case vbKeyY: idx = 38
        Case vbKeyU: idx = 40
        Case vbKeyA: idx = 17
        Case vbKeyS: idx = 19
        Case vbKeyD: idx = 21
        Case vbKeyF: idx = 23
        Case vbKeyG: idx = 24
        Case vbKeyH: idx = 26
        Case vbKeyJ: idx = 28
        Case vbKeyZ: idx = 5
        Case vbKeyX: idx = 7
        Case vbKeyC: idx = 9
        Case vbKeyV: idx = 11
        Case vbKeyB: idx = 12
        Case vbKeyN: idx = 14
        Case vbKeyM: idx = 16
        Case vbKeyEscape, vbKeySpace: idx = -1
    End Select
    If idx = -1 Then
        Label1_MouseMove 1, 1, 1, 1
        Exit Sub
    End If
    If idx <> 0 Then
        isOgain = (oldidx = idx)
        oldidx = idx
        KeyAscii = 0
        Picture1_DragOver idx, Picture1(idx), 1, 1, 1
        idx = idx + 24
        If idx > 64 Then idx = 64
        Picture1_DragOver idx, Picture1(idx), 1, 1, 1
    End If
End SubPrivate Sub Form_Load()
   Dim Retu As Boolean
   Dim i As Integer

    Retu = Midi_OutDevsToList(ComDevies)
    ComDevies.ListIndex = 0
    Call fill_sound_list    For i = 0 To 64
       Picture1(i).DragMode = 1
       Picture1(i).Tag = Picture1(i).BackColor
    Next
    HScroll1.Value = 36
    HScroll2.Value = 127
End Sub
Private Sub fill_sound_list()
Dim s As String    Open App.Path & "\genmidi.txt" For Input As #1
    Do While Not EOF(1)
        Line Input #1, s
        ComSounds.AddItem s
    Loop
    ComSounds.ListIndex = 0
    Close #1
End SubPrivate Sub Form_Unload(Cancel As Integer)
    midi_OutClose
    End
End SubPrivate Sub HScroll1_Change()
   Sta = HScroll1.Value
   Label2.Caption = Diao(Sta Mod 12)
End SubPrivate Sub HScroll2_Change()
     sudu = HScroll2.Value
End Sub'Private Sub HScroll3_Change()
'     Label6.Caption = HScroll3.Value
'End SubPrivate Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
     Dim i As Integer
       For i = 0 To 64       '关闭所有的发音
            Call note_off(0, i + Sta)
            Picture1(i).BackColor = Picture1(i).Tag
      Next
End SubPrivate Sub mnu_Close_Click()
Unload Me
End SubPrivate Sub Picture1_DragOver(Index As Integer, Source As Control, x As Single, Y As Single, State As Integer)
'完成发音
Dim i As Integer
Static OldNote As Integer
    If (OldNote <> Index) Or (isOgain = True) Then
        Call note_off(0, OldNote + Sta)
        Call note_on(0, Index + Sta, sudu)    '参数分别为通道编号，音调，速度
        OldNote = Index
        isOgain = False
        Picture1(Index).BackColor = &HFF8080
        For i = 0 To 64
            If i <> Index Then Picture1(i).BackColor = Picture1(i).Tag
        Next
    End If
End Sub
Private Sub Timer1_Timer()
   Dim MyKey As Integer
   MyKey% = GetKeyState(VK_LBUTTON)
   If MyKey% And &H4000 Then
       isOgain = False
   Else
       isOgain = True
   End If
End SubPrivate Sub Timer2_Timer()
Dim s As String
Dim Index As Integer
        Line Input #1, s
        s = Trim(s)
        If s = "End" Then
            Close #1
            Timer2.Enabled = False
            Command2.Enabled = True
            Label1_MouseMove 0, 0, 1, 1
            Exit Sub
        End If
        Index = Val(s)
        If Index < 100 Then
              Index = Index + 7
              Picture1_DragOver Index, Picture1(Index), 1, 1, 1
              Index = Index + 24
              Picture1_DragOver Index, Picture1(Index), 1, 1, 1
        End If
        isOgain = True
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
还有Module1:
Module1:
ption ExplicitPrivate 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 LongPrivate Const MAXERRORLENGTH = 128       '  max error text length (including NULL)Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
'MIDIOUTCAPS结构描述了Musical Instrument Digital Interface(MIDI)输入设备的性能
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 TypeDim hMidi As LongPublic 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
Public Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer    midi_OutClose
    midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)
    If Not midi_error = 0 Then
        Call midi_outerr(midi_error)
    End If
    MIDI_OutOpen = (hMidi <> 0)
End Function
Public Sub midi_OutClose()
Dim midi_error As Integer    If hMidi <> 0 Then
        midi_error = midiOutClose(hMidi)
         If Not midi_error = 0 Then
            Call midi_outerr(midi_error)
         End If
        hMidi = 0
    End If
End Sub
Public Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)
    Call midi_outshort(&H90 + ch, kk, v)
End SubPublic Sub note_off(ch As Integer, ByVal kk As Integer)
    Call midi_outshort(&H80 + ch, kk, 0)
End SubSub 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)
    If Not midi_error = 0 Then
        Call midi_outerr(midi_error)
    End If
End Sub
Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
    Call control_change(ch, 0, cc0nr)
    Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub
Sub control_change(ch As Integer, ccnr As Integer, ByVal v As Integer)
    Call midi_outshort(&HB0 + ch, ccnr, v)
End SubSub midisetrpn(ch As Integer, pmsb As Integer, plsb As Integer, msb As Integer, lsb As Integer)
    Call midi_outshort(ch, &H65, pmsb)
    Call midi_outshort(ch, &H64, plsb)
    Call midi_outshort(ch, &H6, msb)
    Call midi_outshort(ch, &H26, lsb)
End Sub
Sub midi_outerr(ByVal midi_error As Integer)
Dim s As String
Dim x As Integer    s = Space(MAXERRORLENGTH)
    x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
    MsgBox sEnd Sub

调试易

救急！·救急！！高手请赐教！！在vb 中如何调用系统发音函数呢

解决方案 »