Post by esr on Aug 23, 2019 9:08:40 GMT 1
Hallo Kollegen,
kann mir irgendjemand weiterhelfen. Ich bin gerade dabei mir einen kleinen MIDI-Controller in GFA Basic zu erstellen und scheitere gerade bei den MIDI-IN API Funktionen. - AUch lassen sich VB5 Listings nicht einfach in GFA Basic umsetzen, da hier Funktionen versteckt sind, die GFA Basic nicht kennt. - Leider bin ich noch nicht so lange bei GFA Basic dabei und kenne auch nicht alle Befehle, sodass ich mir die Routinen nicht einfach umschreiben kann! - Wer kann hier vielleicht helfen, oder hat sich schon einmal damit beschäftigt!
Ich möchte gerne mit einer externen Midi-Keyboard Tastertur einzelne Tonfolgen oder Funktionen in meinem GFA Basic Programm ansprechen wollen. - Bei Atari war das ganz einfach, bei GFA BAsic, scheint es aber eine Herausforderung zu sein!
Midi-In API Funktionen habe ich gefunden, aber mit Ausleseroutinen komme ich nicht weiter.
Bei VB5 gibt es zum Beispiel Deklarationen mit DELEGATE etc. Ich komme aber auch hiermit nicht klar.
Andere Listings benutzen den Befehl: AdressOf Unterroutine im Befehlsaufruf. - Wie kann man dieses entsprechend in GFA Basic durchführen?
-------------------------------
rc = midiInOpen(hMidi, mDev, AddressOf MidiInCallBack, 0&, CALLBACK_FUNCTION) <==== Eintrag AddressOf gibt es bei GFA nicht
Und dann geht es in diese Unterroutine:
Sub MidiInCallBack(ByVal hMidiIn As Long, ByVal wMsg As Integer, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
-------------------------------
Hat irgendjemand vielleicht ein funktionierendes Beispiel für Midi-IN?
Midi-Out ist nicht das Thema. => Dieses funktioniert und hierzu gibt es auch Beispiele!
Ich habe folgendes Visual Basic Programm gefunden. Gibt es vielleicht jemand, der dieses für GFA BAsic übersetzen und dem Forum zur Verfügung stellen kann?! - Es wäre wirklich eine schöne Sache und würde GFA Basic einen weiteren Sinn verschaffen!
Hier das Listing:
Attribute VB_Name = "MidiIn"
Option Explicit
'
' This code is copyright M. R. Le Voi Systems Consultants (c) 1999
' Use at your own risk. Nothing warranted to work on your PC
'
' Microsoft Declares
'
Public Declare Function MidiInClose Lib "winmm.dll" Alias "midiInClose" (ByVal hMidiIn As Long) As Long
Public Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Public Declare Function midiInAddBuffer Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInGetErrorText Lib "winmm.dll" Alias "midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function midiInMessage Lib "winmm.dll" (ByVal hMidiIn As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Public Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function midiInPrepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInUnprepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Public Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Public Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
'
Public Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
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 midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public 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
Public Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Public Declare Function midiOutPrepareHeader Lib "winmm.dll" (ByVal hMidiOut As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutUnprepareHeader Lib "winmm.dll" (ByVal hMidiOut As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Public Declare Function midiOutLongMsg Lib "winmm.dll" (ByVal hMidiOut As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
'
Public Const MM_MIM_OPEN = &H3C1
Public Const MM_MIM_CLOSE = &H3C2
Public Const MM_MIM_DATA = &H3C3
Public Const MM_MIM_LONGDATA = &H3C4
Public Const MM_MIM_ERROR = &H3C5
Public Const MM_MIM_LONGERROR = &H3C6
Public Const MM_MIM_MOREDATA = &H3CC
'
Public Const MHDR_DONE = &H1
Public Const MHDR_INQUEUE = &H4
Public Const MHDR_PREPARED = &H2
Public Const MHDR_VALID = &H7
'
' Callback + MOREDATA flag
'
Public Const CALLBACK_FUNCTION = &H30000 + &H20&
Public Const MAXPNAMELEN = 32
'
Public Type MIDIHDR
lpData As Long
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
lpNext As Long
Reserved As Long
End Type
'
Public Type MIDIINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
'
Type MIDIOUTCAPS
wMid As Integer ' Manufacturer ID
wPid As Integer ' Product ID
vDriverVersion As Long ' Driver version
szPname As String * 32 ' Product name (NULL terminated string)
wTechnology As Integer ' Device type
wVoices As Integer ' n. of voices (internal synth only)
wNotes As Integer ' max n. of notes (internal synth only)
wChannelMask As Integer ' n. of Midi channels (internal synth only)
dwSupport As Long ' Supported extra controllers (volume, etc)
End Type
Public Declare Function GetVersion Lib "kernel32" () As Long
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByVal lpVersionInformation As Long) As Long
' Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByVal lpVersionInformation As OSVERSIONINFO) As Long
'
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(0 To 127) As Byte ' Maintenance string for PSS usage
End Type
'
' My Declares
'
Public Const MAXMSG = 30000 ' Maximum number of input messages
Public Const MAXSYX = 61000 ' Maximum SYSEX to be received
' SYXSIZE is optimised for speed (ie it is small) and for
' Roland GS (ie 138 byte bulk dump packets) under Win 95/98.
' Make it 512 for NT 4.0 as there is a bug in MidiYoke as at
' 1st May 1999. If the buffer is too small, you get invalid data!
' Public Const SYXSIZE = 512 for NT 4.0 and 138 for Win 95/98
Public Const SYXSIZE95 = 138
Global SYXSIZE As Integer ' SYSEX Receive packet size
' Make NUMHDRS 2 for NT 4.0 and 199 for Win 95/98!
' NT will not multitask - Win 95/98 wants lots of small buffers!
' Public Const NUMHDRS = 2 for NT 4.0 and 199 for Win 95/98
Public Const NUMHDRS95 = 199
Global NUMHDRS As Integer ' Number of MIDIHDRs to be queued
'
Public Type SYXIN
SyxData(0 To SYXSIZE95 - 1) As Byte ' Make sure this is big enough?
MyHdr As Long ' address of this MIDIHDR
End Type
'
Public Type SYXCOUNTERS
SyxStart As Long ' Start of SYSEX in SyxString
SyxLength As Integer ' Length of this message
HdrCount As Integer ' Which MIDIHDR was used
End Type
'
' Global Variables
'
Global vntRet As Variant
Global hMidi As Long, hMidiOut As Long
Global mDev As Long, mDevOut As Long
Global InCount As Integer, LastCount As Integer
Global InMsg(1 To MAXMSG) As Long ' MSG Type
Global InParam1(1 To MAXMSG) As Long ' Param1
Global InVector(1 To MAXMSG) As SYXCOUNTERS
Global InSyx As Integer, SyxCount As Long, ErrFlag As Integer
Global HdrCount As Integer, SaveCount As Integer, MoreData As Long
' Global mHdrs(0 To NUMHDRS95) As MIDIHDR
Global mHdrs() As MIDIHDR
' Global mHdrData(0 To NUMHDRS95) As SYXIN
Global mHdrData() As SYXIN
' Global SyxString(0 To MAXSYX + SYXSIZE95) As Byte
Global SyxString() As Byte
Global OsInfo As OSVERSIONINFO
Global SendHdrCount As Long, SendHdrLength As Long
Sub SetMidiDevice()
Dim zz As Integer
Dim InCaps As MIDIINCAPS, OutCaps As MIDIOUTCAPS
Dim MidiDevice As String, MidiDevOut As String
Dim DevCount As Integer
mDev = 0: mDevOut = 0
' Use a piece of the Driver Name for matching
MidiDevice = "loop" ' loopMIDI
MidiDevOut = "UA" ' UA-101
'
DevCount = midiInGetNumDevs()
frmMain.InCombo.Clear
For zz = 0 To DevCount - 1
vntRet = midiInGetDevCaps(zz, InCaps, Len(InCaps))
If vntRet <> 0 Then
MsgBox "midiInGetDevCaps Error: " & vntRet
Exit For
End If
frmMain.InCombo.AddItem InCaps.szPname
If InStr(UCase(InCaps.szPname), UCase(MidiDevice)) <> 0 Then
mDev = zz
End If
Next zz
If frmMain.InCombo.ListCount > 0 Then
frmMain.InCombo.ListIndex = mDev
End If
' If mDev = 0 Then MsgBox ("No driver match for " & MidiDevice)
'
frmMain.OutCombo.Clear
DevCount = midiOutGetNumDevs()
For zz = 0 To DevCount - 1
vntRet = midiOutGetDevCaps(zz, OutCaps, Len(OutCaps))
If vntRet <> 0 Then
MsgBox "midiOutGetDevCaps Error: " & vntRet
Exit For
End If
frmMain.OutCombo.AddItem OutCaps.szPname
If InStr(UCase(OutCaps.szPname), UCase(MidiDevOut)) <> 0 Then
mDevOut = zz
End If
Next zz
frmMain.OutCombo.ListIndex = mDevOut
' If mDevOut = 0 Then MsgBox ("No driver match for " & MidiDevOut)
End Sub
Sub SysExAdd(Num As Integer)
Dim rc As Long
Dim Length As Integer
Dim sysexreturn As Variant
' This sub prepares a MIDIHDR for SYSEX RECEIVE
mHdrs(Num).lpData = VarPtr(mHdrData(Num).SyxData(0)) ' Undocumented feature!
mHdrs(Num).dwBufferLength = SYXSIZE
mHdrs(Num).dwBytesRecorded = 0
mHdrs(Num).dwUser = 0
mHdrs(Num).dwFlags = 0
'
rc = midiInPrepareHeader(hMidi, mHdrs(Num), LenB(mHdrs(Num)))
If rc <> 0 Then
Call MidiErr("Prepare header", rc)
Exit Sub
End If
' mHdrs(Num).dwFlags = 2 at this point ie prepared
rc = midiInAddBuffer(hMidi, mHdrs(Num), LenB(mHdrs(Num)))
If rc <> 0 Then
Call MidiErr("AddBuffer", rc)
Exit Sub
End If
' mHdrs(Num).dwFlags = 6 at this point ie prepared and queued
'
' Now keep track of which MIDIHDR I am just in case
mHdrData(Num).MyHdr = VarPtr(mHdrs(Num).lpData)
rc = 0 ' just so we can breakpoint
End Sub
Sub MidiInCallBack(ByVal hMidiIn As Long, ByVal wMsg As Integer, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
Dim rc As Long, xx As Long
'
' This is the CALLBACK routine for MIDI IN - Do NOT change!
'
' Always put the following in callback routines
'
On Error Resume Next
' Don't put any other code in this Sub!!!
' VB will probably lock up!!!
' In particular, anything that requires VB services will fail
' eg update a window, a text string etc.
If wMsg = MM_MIM_DATA Or wMsg = MM_MIM_MOREDATA Then ' this is short data
' Warning! This code works using MID files being
' piped to MIDI In via MIDI Yoke.
'
' I do NOT expect this to work unchanged if you use
' a keyboard as MIDI IN as it will probably send MIDI
' messages like Active Sensing etc.
'
' You have been warned!
If 1 = 1 Then ' frmMain.Check3.Value = 1 Then ' track midi messages - try to track all messages!
' if
InCount = InCount + 1
If InCount = (MAXMSG + 1) Then InCount = 1
InMsg(InCount) = wMsg
InParam1(InCount) = dwParam1
End If
rc = midiOutShortMsg(hMidiOut, dwParam1)
If wMsg = MM_MIM_MOREDATA Then MoreData = MoreData + 1
Exit Sub
End If
If wMsg = MM_MIM_LONGDATA Then ' This is SYSEX
InCount = InCount + 1
If InCount = (MAXMSG + 1) Then InCount = 1
InMsg(InCount) = wMsg
' dwParam1 is the address of this MIDIHDR
'
' Win 95 logic appears NOT to work under NT 4.0!
' Win 98 uses MIDIHDRs in turn and multi-tasks
' ie it can start filling the next HDR
' while still filling the first HDR.
' This prevents slowdown but is a bugger
' to code around!
' Win NT appears to always use the last header added
' and does not appear to multi-task
If mHdrData(HdrCount).MyHdr <> dwParam1 Then
' We must be under NT 4.0!
For xx = 0 To NUMHDRS
HdrCount = xx
If mHdrData(HdrCount).MyHdr = dwParam1 Then Exit For
Next xx
End If
If mHdrData(HdrCount).MyHdr = dwParam1 Then
InVector(InCount).HdrCount = HdrCount
SendHdrCount = HdrCount
SendHdrLength = mHdrs(HdrCount).dwBytesRecorded
InVector(InCount).SyxStart = SyxCount
InVector(InCount).SyxLength = mHdrs(HdrCount).dwBytesRecorded
' Stack SYSEX away for later processing!
For xx = 0 To mHdrs(HdrCount).dwBytesRecorded
SyxString(SyxCount + xx) = mHdrData(HdrCount).SyxData(xx)
Next xx
SyxCount = SyxCount + mHdrs(HdrCount).dwBytesRecorded
If SyxCount >= MAXSYX Then SyxCount = 0 ' Prevent Overrun!
' The following works but something goes strange
If mHdrs(HdrCount).dwBytesRecorded <> 0 Then
If frmMain.Check4.Value = 1 Then ' Send SYSEX to device
' Next line does not work reliably under WIN2K ;-(
'rc = midiOutLongMsg(hMidiOut, mHdrs(HdrCount), LenB(mHdrs(HdrCount)))
' This works ;-)
LongMidiMsg (SendHdrLength)
End If
' This resets dwflags from 3 to 6!
SysExAdd (HdrCount) ' this now works
End If
HdrCount = HdrCount + 1
If HdrCount = NUMHDRS + 1 Then HdrCount = 0
Else
ErrFlag = ErrFlag + 1 ' this should not happen!
End If
End If
End Sub
Sub MidiErr(mOpt As String, rc As Long)
Dim msgText As String * 132
vntRet = midiInGetErrorText(rc, msgText, 128)
MsgBox "Operation: " & mOpt & Chr(13) & Chr(10) & msgText
End Sub
Sub LongMidiMsg(AnyNumber As Long)
Dim mHdr As MIDIHDR
Dim rc As Long
' This is the same logic as the LongMidiMessage subroutine
' but it is called from the MIDI IN Callback routine
' Hence, it is cutdown to essentials!
mHdr.lpData = VarPtr(mHdrData(SendHdrCount).SyxData(0)) ' Undocumented feature!
mHdr.dwBufferLength = SendHdrLength
mHdr.dwBytesRecorded = 0 ' Only used for MIDI in
mHdr.dwUser = 0
mHdr.dwFlags = 0
' this next line has caused an error on one user's machine under VB5 - who knows why?
rc = midiOutPrepareHeader(hMidiOut, mHdr, LenB(mHdr))
rc = midiOutLongMsg(hMidiOut, mHdr, LenB(mHdr))
rc = midiOutUnprepareHeader(hMidiOut, mHdr, LenB(mHdr))
End Sub
Sub OpenMidiPort()
Dim rc As Long, xx As Integer
InCount = 0: LastCount = 0: MoreData = 0: ErrFlag = 0
InSyx = 0: SyxCount = 0: HdrCount = 0: SaveCount = 0
rc = midiInOpen(hMidi, mDev, AddressOf MidiInCallBack, 0&, CALLBACK_FUNCTION)
' Notice the extra parameter, AddressOf [FunctionName]
If rc <> 0 Then
Call MidiErr("Open", rc)
Exit Sub
End If
'
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI IN Open" & vbCrLf
rc = midiInStart(hMidi)
If rc <> 0 Then
Call MidiErr("Start", rc)
Exit Sub
End If
'
' frmMain.TxtMidi.text = frmMain.TxtMidi.text & "MIDI IN Start" & vbCrLf
rc = MIDIOutOpen(hMidiOut, mDevOut, 0&, 0&, 0&)
If rc <> 0 Then
Call MidiErr("Open Out", rc)
Exit Sub
End If
'
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI OUT Open" & vbCrLf
'
For xx = 0 To NUMHDRS ' Add SYSEX Input Buffers
SysExAdd (xx)
Next xx
' If frmMain.NtCheck.Value = 1 Then HdrCount = NUMHDRS
End Sub
Sub CloseMidiPort()
Dim rc As Long, xx As Integer
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "Please wait ..." & vbCrLf
DoEvents
rc = midiInStop(hMidi)
If rc <> 0 Then
Call MidiErr("Stop", rc)
End If
'
rc = midiInReset(hMidi)
If rc <> 0 Then
Call MidiErr("Reset", rc)
End If
' frmMain.TxtMidi.text = frmMain.TxtMidi.text & "MIDI IN Stop/Reset" & vbCrLf
'
For xx = 0 To NUMHDRS
rc = midiInUnprepareHeader(hMidi, mHdrs(xx), LenB(mHdrs(xx)))
If rc <> 0 Then
If xx = 0 Then Call MidiErr("Unprepare", rc)
End If
Next xx
'
rc = MidiInClose(hMidi)
If rc <> 0 Then
Call MidiErr("Close", rc)
End If
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI IN Close" & vbCrLf
'
rc = midiOutClose(hMidiOut)
If rc <> 0 Then
Call MidiErr("Close Out", rc)
End If
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI OUT Close" & vbCrLf
End Sub
Auf entsprechende Feedbacks, bin ich sehr gespannt!
Vielen Dank vorab.
kann mir irgendjemand weiterhelfen. Ich bin gerade dabei mir einen kleinen MIDI-Controller in GFA Basic zu erstellen und scheitere gerade bei den MIDI-IN API Funktionen. - AUch lassen sich VB5 Listings nicht einfach in GFA Basic umsetzen, da hier Funktionen versteckt sind, die GFA Basic nicht kennt. - Leider bin ich noch nicht so lange bei GFA Basic dabei und kenne auch nicht alle Befehle, sodass ich mir die Routinen nicht einfach umschreiben kann! - Wer kann hier vielleicht helfen, oder hat sich schon einmal damit beschäftigt!
Ich möchte gerne mit einer externen Midi-Keyboard Tastertur einzelne Tonfolgen oder Funktionen in meinem GFA Basic Programm ansprechen wollen. - Bei Atari war das ganz einfach, bei GFA BAsic, scheint es aber eine Herausforderung zu sein!
Midi-In API Funktionen habe ich gefunden, aber mit Ausleseroutinen komme ich nicht weiter.
Bei VB5 gibt es zum Beispiel Deklarationen mit DELEGATE etc. Ich komme aber auch hiermit nicht klar.
Andere Listings benutzen den Befehl: AdressOf Unterroutine im Befehlsaufruf. - Wie kann man dieses entsprechend in GFA Basic durchführen?
-------------------------------
rc = midiInOpen(hMidi, mDev, AddressOf MidiInCallBack, 0&, CALLBACK_FUNCTION) <==== Eintrag AddressOf gibt es bei GFA nicht
Und dann geht es in diese Unterroutine:
Sub MidiInCallBack(ByVal hMidiIn As Long, ByVal wMsg As Integer, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
-------------------------------
Hat irgendjemand vielleicht ein funktionierendes Beispiel für Midi-IN?
Midi-Out ist nicht das Thema. => Dieses funktioniert und hierzu gibt es auch Beispiele!
Ich habe folgendes Visual Basic Programm gefunden. Gibt es vielleicht jemand, der dieses für GFA BAsic übersetzen und dem Forum zur Verfügung stellen kann?! - Es wäre wirklich eine schöne Sache und würde GFA Basic einen weiteren Sinn verschaffen!
Hier das Listing:
Attribute VB_Name = "MidiIn"
Option Explicit
'
' This code is copyright M. R. Le Voi Systems Consultants (c) 1999
' Use at your own risk. Nothing warranted to work on your PC
'
' Microsoft Declares
'
Public Declare Function MidiInClose Lib "winmm.dll" Alias "midiInClose" (ByVal hMidiIn As Long) As Long
Public Declare Function midiInGetDevCaps Lib "winmm.dll" Alias "midiInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIINCAPS, ByVal uSize As Long) As Long
Public Declare Function midiInAddBuffer Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInGetErrorText Lib "winmm.dll" Alias "midiInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function midiInGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function midiInMessage Lib "winmm.dll" (ByVal hMidiIn As Long, ByVal msg As Long, ByVal dw1 As Long, ByVal dw2 As Long) As Long
Public Declare Function midiInOpen Lib "winmm.dll" (lphMidiIn As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function midiInPrepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInUnprepareHeader Lib "winmm.dll" (ByVal hMidiIn As Long, lpMidiInHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiInStart Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Public Declare Function midiInStop Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
Public Declare Function midiInReset Lib "winmm.dll" (ByVal hMidiIn As Long) As Long
'
Public Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
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 midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public 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
Public Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Public Declare Function midiOutPrepareHeader Lib "winmm.dll" (ByVal hMidiOut As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutUnprepareHeader Lib "winmm.dll" (ByVal hMidiOut As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
Public Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Public Declare Function midiOutLongMsg Lib "winmm.dll" (ByVal hMidiOut As Long, lpMidiOutHdr As MIDIHDR, ByVal uSize As Long) As Long
'
Public Const MM_MIM_OPEN = &H3C1
Public Const MM_MIM_CLOSE = &H3C2
Public Const MM_MIM_DATA = &H3C3
Public Const MM_MIM_LONGDATA = &H3C4
Public Const MM_MIM_ERROR = &H3C5
Public Const MM_MIM_LONGERROR = &H3C6
Public Const MM_MIM_MOREDATA = &H3CC
'
Public Const MHDR_DONE = &H1
Public Const MHDR_INQUEUE = &H4
Public Const MHDR_PREPARED = &H2
Public Const MHDR_VALID = &H7
'
' Callback + MOREDATA flag
'
Public Const CALLBACK_FUNCTION = &H30000 + &H20&
Public Const MAXPNAMELEN = 32
'
Public Type MIDIHDR
lpData As Long
dwBufferLength As Long
dwBytesRecorded As Long
dwUser As Long
dwFlags As Long
lpNext As Long
Reserved As Long
End Type
'
Public Type MIDIINCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
'
Type MIDIOUTCAPS
wMid As Integer ' Manufacturer ID
wPid As Integer ' Product ID
vDriverVersion As Long ' Driver version
szPname As String * 32 ' Product name (NULL terminated string)
wTechnology As Integer ' Device type
wVoices As Integer ' n. of voices (internal synth only)
wNotes As Integer ' max n. of notes (internal synth only)
wChannelMask As Integer ' n. of Midi channels (internal synth only)
dwSupport As Long ' Supported extra controllers (volume, etc)
End Type
Public Declare Function GetVersion Lib "kernel32" () As Long
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByVal lpVersionInformation As Long) As Long
' Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByVal lpVersionInformation As OSVERSIONINFO) As Long
'
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(0 To 127) As Byte ' Maintenance string for PSS usage
End Type
'
' My Declares
'
Public Const MAXMSG = 30000 ' Maximum number of input messages
Public Const MAXSYX = 61000 ' Maximum SYSEX to be received
' SYXSIZE is optimised for speed (ie it is small) and for
' Roland GS (ie 138 byte bulk dump packets) under Win 95/98.
' Make it 512 for NT 4.0 as there is a bug in MidiYoke as at
' 1st May 1999. If the buffer is too small, you get invalid data!
' Public Const SYXSIZE = 512 for NT 4.0 and 138 for Win 95/98
Public Const SYXSIZE95 = 138
Global SYXSIZE As Integer ' SYSEX Receive packet size
' Make NUMHDRS 2 for NT 4.0 and 199 for Win 95/98!
' NT will not multitask - Win 95/98 wants lots of small buffers!
' Public Const NUMHDRS = 2 for NT 4.0 and 199 for Win 95/98
Public Const NUMHDRS95 = 199
Global NUMHDRS As Integer ' Number of MIDIHDRs to be queued
'
Public Type SYXIN
SyxData(0 To SYXSIZE95 - 1) As Byte ' Make sure this is big enough?
MyHdr As Long ' address of this MIDIHDR
End Type
'
Public Type SYXCOUNTERS
SyxStart As Long ' Start of SYSEX in SyxString
SyxLength As Integer ' Length of this message
HdrCount As Integer ' Which MIDIHDR was used
End Type
'
' Global Variables
'
Global vntRet As Variant
Global hMidi As Long, hMidiOut As Long
Global mDev As Long, mDevOut As Long
Global InCount As Integer, LastCount As Integer
Global InMsg(1 To MAXMSG) As Long ' MSG Type
Global InParam1(1 To MAXMSG) As Long ' Param1
Global InVector(1 To MAXMSG) As SYXCOUNTERS
Global InSyx As Integer, SyxCount As Long, ErrFlag As Integer
Global HdrCount As Integer, SaveCount As Integer, MoreData As Long
' Global mHdrs(0 To NUMHDRS95) As MIDIHDR
Global mHdrs() As MIDIHDR
' Global mHdrData(0 To NUMHDRS95) As SYXIN
Global mHdrData() As SYXIN
' Global SyxString(0 To MAXSYX + SYXSIZE95) As Byte
Global SyxString() As Byte
Global OsInfo As OSVERSIONINFO
Global SendHdrCount As Long, SendHdrLength As Long
Sub SetMidiDevice()
Dim zz As Integer
Dim InCaps As MIDIINCAPS, OutCaps As MIDIOUTCAPS
Dim MidiDevice As String, MidiDevOut As String
Dim DevCount As Integer
mDev = 0: mDevOut = 0
' Use a piece of the Driver Name for matching
MidiDevice = "loop" ' loopMIDI
MidiDevOut = "UA" ' UA-101
'
DevCount = midiInGetNumDevs()
frmMain.InCombo.Clear
For zz = 0 To DevCount - 1
vntRet = midiInGetDevCaps(zz, InCaps, Len(InCaps))
If vntRet <> 0 Then
MsgBox "midiInGetDevCaps Error: " & vntRet
Exit For
End If
frmMain.InCombo.AddItem InCaps.szPname
If InStr(UCase(InCaps.szPname), UCase(MidiDevice)) <> 0 Then
mDev = zz
End If
Next zz
If frmMain.InCombo.ListCount > 0 Then
frmMain.InCombo.ListIndex = mDev
End If
' If mDev = 0 Then MsgBox ("No driver match for " & MidiDevice)
'
frmMain.OutCombo.Clear
DevCount = midiOutGetNumDevs()
For zz = 0 To DevCount - 1
vntRet = midiOutGetDevCaps(zz, OutCaps, Len(OutCaps))
If vntRet <> 0 Then
MsgBox "midiOutGetDevCaps Error: " & vntRet
Exit For
End If
frmMain.OutCombo.AddItem OutCaps.szPname
If InStr(UCase(OutCaps.szPname), UCase(MidiDevOut)) <> 0 Then
mDevOut = zz
End If
Next zz
frmMain.OutCombo.ListIndex = mDevOut
' If mDevOut = 0 Then MsgBox ("No driver match for " & MidiDevOut)
End Sub
Sub SysExAdd(Num As Integer)
Dim rc As Long
Dim Length As Integer
Dim sysexreturn As Variant
' This sub prepares a MIDIHDR for SYSEX RECEIVE
mHdrs(Num).lpData = VarPtr(mHdrData(Num).SyxData(0)) ' Undocumented feature!
mHdrs(Num).dwBufferLength = SYXSIZE
mHdrs(Num).dwBytesRecorded = 0
mHdrs(Num).dwUser = 0
mHdrs(Num).dwFlags = 0
'
rc = midiInPrepareHeader(hMidi, mHdrs(Num), LenB(mHdrs(Num)))
If rc <> 0 Then
Call MidiErr("Prepare header", rc)
Exit Sub
End If
' mHdrs(Num).dwFlags = 2 at this point ie prepared
rc = midiInAddBuffer(hMidi, mHdrs(Num), LenB(mHdrs(Num)))
If rc <> 0 Then
Call MidiErr("AddBuffer", rc)
Exit Sub
End If
' mHdrs(Num).dwFlags = 6 at this point ie prepared and queued
'
' Now keep track of which MIDIHDR I am just in case
mHdrData(Num).MyHdr = VarPtr(mHdrs(Num).lpData)
rc = 0 ' just so we can breakpoint
End Sub
Sub MidiInCallBack(ByVal hMidiIn As Long, ByVal wMsg As Integer, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
Dim rc As Long, xx As Long
'
' This is the CALLBACK routine for MIDI IN - Do NOT change!
'
' Always put the following in callback routines
'
On Error Resume Next
' Don't put any other code in this Sub!!!
' VB will probably lock up!!!
' In particular, anything that requires VB services will fail
' eg update a window, a text string etc.
If wMsg = MM_MIM_DATA Or wMsg = MM_MIM_MOREDATA Then ' this is short data
' Warning! This code works using MID files being
' piped to MIDI In via MIDI Yoke.
'
' I do NOT expect this to work unchanged if you use
' a keyboard as MIDI IN as it will probably send MIDI
' messages like Active Sensing etc.
'
' You have been warned!
If 1 = 1 Then ' frmMain.Check3.Value = 1 Then ' track midi messages - try to track all messages!
' if
InCount = InCount + 1
If InCount = (MAXMSG + 1) Then InCount = 1
InMsg(InCount) = wMsg
InParam1(InCount) = dwParam1
End If
rc = midiOutShortMsg(hMidiOut, dwParam1)
If wMsg = MM_MIM_MOREDATA Then MoreData = MoreData + 1
Exit Sub
End If
If wMsg = MM_MIM_LONGDATA Then ' This is SYSEX
InCount = InCount + 1
If InCount = (MAXMSG + 1) Then InCount = 1
InMsg(InCount) = wMsg
' dwParam1 is the address of this MIDIHDR
'
' Win 95 logic appears NOT to work under NT 4.0!
' Win 98 uses MIDIHDRs in turn and multi-tasks
' ie it can start filling the next HDR
' while still filling the first HDR.
' This prevents slowdown but is a bugger
' to code around!
' Win NT appears to always use the last header added
' and does not appear to multi-task
If mHdrData(HdrCount).MyHdr <> dwParam1 Then
' We must be under NT 4.0!
For xx = 0 To NUMHDRS
HdrCount = xx
If mHdrData(HdrCount).MyHdr = dwParam1 Then Exit For
Next xx
End If
If mHdrData(HdrCount).MyHdr = dwParam1 Then
InVector(InCount).HdrCount = HdrCount
SendHdrCount = HdrCount
SendHdrLength = mHdrs(HdrCount).dwBytesRecorded
InVector(InCount).SyxStart = SyxCount
InVector(InCount).SyxLength = mHdrs(HdrCount).dwBytesRecorded
' Stack SYSEX away for later processing!
For xx = 0 To mHdrs(HdrCount).dwBytesRecorded
SyxString(SyxCount + xx) = mHdrData(HdrCount).SyxData(xx)
Next xx
SyxCount = SyxCount + mHdrs(HdrCount).dwBytesRecorded
If SyxCount >= MAXSYX Then SyxCount = 0 ' Prevent Overrun!
' The following works but something goes strange
If mHdrs(HdrCount).dwBytesRecorded <> 0 Then
If frmMain.Check4.Value = 1 Then ' Send SYSEX to device
' Next line does not work reliably under WIN2K ;-(
'rc = midiOutLongMsg(hMidiOut, mHdrs(HdrCount), LenB(mHdrs(HdrCount)))
' This works ;-)
LongMidiMsg (SendHdrLength)
End If
' This resets dwflags from 3 to 6!
SysExAdd (HdrCount) ' this now works
End If
HdrCount = HdrCount + 1
If HdrCount = NUMHDRS + 1 Then HdrCount = 0
Else
ErrFlag = ErrFlag + 1 ' this should not happen!
End If
End If
End Sub
Sub MidiErr(mOpt As String, rc As Long)
Dim msgText As String * 132
vntRet = midiInGetErrorText(rc, msgText, 128)
MsgBox "Operation: " & mOpt & Chr(13) & Chr(10) & msgText
End Sub
Sub LongMidiMsg(AnyNumber As Long)
Dim mHdr As MIDIHDR
Dim rc As Long
' This is the same logic as the LongMidiMessage subroutine
' but it is called from the MIDI IN Callback routine
' Hence, it is cutdown to essentials!
mHdr.lpData = VarPtr(mHdrData(SendHdrCount).SyxData(0)) ' Undocumented feature!
mHdr.dwBufferLength = SendHdrLength
mHdr.dwBytesRecorded = 0 ' Only used for MIDI in
mHdr.dwUser = 0
mHdr.dwFlags = 0
' this next line has caused an error on one user's machine under VB5 - who knows why?
rc = midiOutPrepareHeader(hMidiOut, mHdr, LenB(mHdr))
rc = midiOutLongMsg(hMidiOut, mHdr, LenB(mHdr))
rc = midiOutUnprepareHeader(hMidiOut, mHdr, LenB(mHdr))
End Sub
Sub OpenMidiPort()
Dim rc As Long, xx As Integer
InCount = 0: LastCount = 0: MoreData = 0: ErrFlag = 0
InSyx = 0: SyxCount = 0: HdrCount = 0: SaveCount = 0
rc = midiInOpen(hMidi, mDev, AddressOf MidiInCallBack, 0&, CALLBACK_FUNCTION)
' Notice the extra parameter, AddressOf [FunctionName]
If rc <> 0 Then
Call MidiErr("Open", rc)
Exit Sub
End If
'
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI IN Open" & vbCrLf
rc = midiInStart(hMidi)
If rc <> 0 Then
Call MidiErr("Start", rc)
Exit Sub
End If
'
' frmMain.TxtMidi.text = frmMain.TxtMidi.text & "MIDI IN Start" & vbCrLf
rc = MIDIOutOpen(hMidiOut, mDevOut, 0&, 0&, 0&)
If rc <> 0 Then
Call MidiErr("Open Out", rc)
Exit Sub
End If
'
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI OUT Open" & vbCrLf
'
For xx = 0 To NUMHDRS ' Add SYSEX Input Buffers
SysExAdd (xx)
Next xx
' If frmMain.NtCheck.Value = 1 Then HdrCount = NUMHDRS
End Sub
Sub CloseMidiPort()
Dim rc As Long, xx As Integer
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "Please wait ..." & vbCrLf
DoEvents
rc = midiInStop(hMidi)
If rc <> 0 Then
Call MidiErr("Stop", rc)
End If
'
rc = midiInReset(hMidi)
If rc <> 0 Then
Call MidiErr("Reset", rc)
End If
' frmMain.TxtMidi.text = frmMain.TxtMidi.text & "MIDI IN Stop/Reset" & vbCrLf
'
For xx = 0 To NUMHDRS
rc = midiInUnprepareHeader(hMidi, mHdrs(xx), LenB(mHdrs(xx)))
If rc <> 0 Then
If xx = 0 Then Call MidiErr("Unprepare", rc)
End If
Next xx
'
rc = MidiInClose(hMidi)
If rc <> 0 Then
Call MidiErr("Close", rc)
End If
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI IN Close" & vbCrLf
'
rc = midiOutClose(hMidiOut)
If rc <> 0 Then
Call MidiErr("Close Out", rc)
End If
frmMain.txtMidi.Text = frmMain.txtMidi.Text & "MIDI OUT Close" & vbCrLf
End Sub
Auf entsprechende Feedbacks, bin ich sehr gespannt!
Vielen Dank vorab.