MIDI播放器，支持更换音色库（SoundFont）

你好，能把你这个软件源码给我一个么，先谢谢你哈，我的邮箱是196927156@qq.com

顶

庆祝新年发源码：
Option Explicit
Dim HS1 As Long
Dim HSF As Long
Dim Midi As String
Dim TotalLen As Long
Dim CurPos As Long
Function GetFileName(ByVal fp As String) As String
GetFileName = Mid(fp, InStrRev(fp, "\") + 1)
End Function
Private Sub Command1_Click()
On Error GoTo 234
With Dialog1
.CancelError = True
.InitDir = App.Path
.filter = "MIDI 文件 (mid/midi/rmi/kar)|*.mid;*.midi;*.rmi;*.kar"
.ShowOpen
Midi = .filename
End With
If (HS1) Then
Call BASS_StreamFree(HS1)
End If
HS1 = BASS_MIDI_StreamCreateFile(BASSFALSE, StrPtr(Midi), 0, 0, BASS_SAMPLE_LOOP, 1)
If HS1 = 0 Then
Command1.Caption = "无效的MIDI文件"
Else
Command1.Caption = GetFileName(Midi)
Dim SF As BASS_MIDI_FONT
Call BASS_MIDI_StreamGetFonts(HS1, SF, 1)
HSF = SF.font
CurPos = 0
TotalLen = BASS_ChannelGetLength(HS1, BASS_POS_BYTE)
Call BASS_ChannelPlay(HS1, BASSFALSE)
End If
234:
End Sub
Private Sub Command2_Click()
On Error GoTo 123
With Dialog1
.CancelError = True
.InitDir = App.Path
.filter = "音色库|*.sf2"
.ShowOpen
Dim NewFont As Long
NewFont = BASS_MIDI_FontInit(.filename, 0)
If (NewFont) Then
Dim SF As BASS_MIDI_FONT
SF.font = NewFont
SF.preset = -1
SF.bank = 0
Call BASS_MIDI_StreamSetFonts(0, SF, 1)
Call BASS_MIDI_StreamSetFonts(HS1, SF, 1)
Call BASS_MIDI_FontFree(HSF)
HSF = NewFont
Dim info As BASS_MIDI_FONTINFO
If (BASS_MIDI_FontGetInfo(HSF, info)) Then
Command2.Caption = VBStrFromAnsiPtr(info.name)
End If
End If
End With
123:
End Sub
Private Sub Form_Load()
If BASS_Init(-1, 44100, 0, Me.hWnd, 0) = 0 Then
MsgBox "初始化失败"
End
End If
Dim SF As BASS_MIDI_FONT
If (BASS_MIDI_StreamGetFonts(0, SF, 1)) Then
HSF = SF.font
Dim info As BASS_MIDI_FONTINFO
If (BASS_MIDI_FontGetInfo(HSF, info)) Then
Command2.Caption = VBStrFromAnsiPtr(info.name)
Else
Command2.Caption = "默认音色库"
End If
Else
Command2.Caption = "NO SOUNDFONT（点击加载音色库）"
End If
Shape1.Left = Line1.X1
End Sub
Private Sub Form_Paint()
Me.CurrentX = 0
Me.CurrentY = 0
Me.Print "Work by A1Duke"
End Sub
Private Sub Form_Unload(Cancel As Integer)
If (HS1) Then
Call BASS_ChannelStop(HS1)
Call BASS_StreamFree(HS1)
End If
Call BASS_Free
End Sub

你好远近闻名，谢谢你发的源码，我还有个请求行么，我看了你这个源码，好像还有两模块吧，能不能也一起贴出来或发我邮箱，再次谢谢你哈，也祝你新年快乐万事如意！我的qq：196927156，如果可以的话请加我好友，也好直接向你请教，谢谢！

早发啊。你魂淡。你的Bass文件bas

Declare Function BASS_MIDI_StreamCreateFile64 Lib "bassmidi.dll" Alias "BASS_MIDI_StreamCreateFile" (ByVal mem As Long, ByVal file As Any, ByVal offset As Long, ByVal offsethi As Long, ByVal length As Long, ByVal lengthhi As Long, ByVal flags As Long, ByVal freq As Long) As Long
Function BASS_MIDI_StreamCreateFile(ByVal mem As Long, ByVal file As Long, ByVal offset As Long, ByVal length As Long, ByVal flags As Long, ByVal freq As Long) As Long
BASS_MIDI_StreamCreateFile = BASS_MIDI_StreamCreateFile64(mem, file, offset, 0, length, 0, flags Or BASS_UNICODE, freq)
End Function
Declare Function BASS_MIDI_StreamSetFonts Lib "bassmidi.dll" (ByVal handle As Long, fonts As Any, ByVal count As Long) As Long
Declare Function BASS_MIDI_StreamGetFonts Lib "bassmidi.dll" (ByVal handle As Long, fonts As Any, ByVal count As Long) As Long
Declare Function BASS_MIDI_FontInit Lib "bassmidi.dll" (ByVal file As Any, ByVal flags As Long) As Long
Declare Function BASS_MIDI_FontFree Lib "bassmidi.dll" (ByVal handle As Long) As Long
Declare Function BASS_MIDI_FontGetInfo Lib "bassmidi.dll" (ByVal handle As Long, ByRef info As BASS_MIDI_FONTINFO) As Long
Type BASS_MIDI_FONT
font As Long ' soundfont
preset As Long ' preset number (-1=all)
bank As Long
End Type
Type BASS_MIDI_FONTINFO
name As Long
copyright As Long
comment As Long
presets As Long ' number of presets/instruments
samsize As Long ' total size (in bytes) of the sample data
samload As Long ' amount of sample data currently loaded
samtype As Long ' sample format (CTYPE) if packed
End Type

谢谢你A1Duke，你发的代码我已经编辑通过了，呵呵，有什么方法能让系统音源和加载的音源可以相互切换么，我做的是用电脑键盘进行演奏的电子琴！

楼主你的源代码是什么？我们老师叫我们做一个系统或者一个程序 我觉得你这个很实用，但是我一点都没学过，希望你把源代码给我 最好不要出错 因为我不会改《谢谢

赞赞哒。。。