home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
tool
/
sound
/
vb_mid
/
vb_midi.bas
< prev
next >
Wrap
BASIC Source File
|
1995-02-05
|
27KB
|
746 lines
Option Explicit
'Midi Device Handles
Global hMidiIn As Integer
Global hMidiOut As Integer
Global Const NO_HANDLE = -1 'Device not enabled
'Number of Midi Devices
Global nInDevices As Integer 'Number of total available Midi In Devices
Global nOutDevices As Integer 'Number of total available Midi Out Devices
'MTC sync variables
Global nQfIdExpected As Integer 'Must be set to &H0 to start reading MTC
Global bInSync As Integer 'Indicates MTC is beeing correctly received
Global nNewMtc As Integer 'Number of new different MTC messages arrived (to resync)
'MTC timing variables
Global nFramesPerSecond As Integer '24,25,30
Global nMtcMode As Integer '0=24, 1=25, 2=30 drop frame, 3=30 no drop
Global fMsPerQF As Single 'Ms. per Quarter Frame (250/nFramesPerSecond)
Global fMsPerFrame As Single 'Ms. per Frame (1000/nFramesPerSecond)
Global nMtcTotalFrames As Long 'Current MTC Time in Frames.
Global lMtcTime As Long 'Current MTC Time in Milliseconds
'Global flags (set in Options Menu or similar)
Global bMidiThru As Integer 'Send all Midi In messages to Midi Out
Global bMTCThru As Integer 'Send all MTC In messages to Midi Out
Global bMTCOut As Integer 'While Play or Rec in internal mode, send MTC to Midi Out
Global bMtcModeError As Integer'Indicates that received MTC frame mode is not correct
Global bDebug As Integer 'If true, print received MTC in debug window
'Sync mode variable and constants
Global nSyncMode As Integer 'Internal=System Time / External=MTC
Global Const SYNC_INTERNAL = 0
Global Const SYNC_EXTERNAL = 1
'return value from API Functions
Global vntRet As Variant
'Standard Midi Files variables
'Parameters saved in first track of Standard Midi Files
Global fTicksPerBeat As Single 'ticks per beat
Global fTempo As Single 'microseconds per beat
'Timing calculation variables
Global fMsPerTick As Single 'milliseconds per tick
Global fTicksPerMs As Single 'ticks per millisecond
'To calculate real time in Standard Midi Files
' fMsPerTick = (fTempo / 1000) / fTicksPerBeat
' fTicksPerMs = (fTicksPerBeat / fTempo) * 1000
'MIDI CONSTANTS
'Channel messages Status (Midi channel [0...15] must be added)
Global Const NOTE_OFF = &H80
Global Const NOTE_ON = &H90
Global Const POLY_KEY_PRESS = &HA0
Global Const CONTROLLER_CHANGE = &HB0
Global Const PROGRAM_CHANGE = &HC0
Global Const CHANNEL_PRESSURE = &HD0
Global Const PITCH_BEND = &HE0
'Controller Number (Byte following CONTROLLER_CHANGE Status)
Global Const MOD_WHEEL = 1
Global Const BREATH_CONTROLLER = 2
Global Const FOOT_CONTROLLER = 4
Global Const PORTAMENTO_TIME = 5
Global Const MAIN_VOLUME = 7
Global Const BALANCE = 8
Global Const PAN = 10
Global Const EXPRESS_CONTROLLER = 11
Global Const DAMPER_PEDAL = 64
Global Const PORTAMENTO = 65
Global Const SOSTENUTO = 66
Global Const SOFT_PEDAL = 67
Global Const HOLD_2 = 69
Global Const EXTERNAL_FX_DEPTH = 91
Global Const TREMELO_DEPTH = 92
Global Const CHORUS_DEPTH = 93
Global Const DETUNE_DEPTH = 94
Global Const PHASER_DEPTH = 95
Global Const DATA_INCREMENT = 96
Global Const DATA_DECREMENT = 97
'Channel independent Status (MIDI channel is irrelevant)
Global Const SYSEX = &HF0 'System exclusive block Status
Global Const MTC_QFRAME = &HF1 'MTC Quarter Frame Message Status
Global Const EOX = &HF7 'End of System exclusive block
Global Const MIDI_CLOCK = &HF8 'Midi sync clock
Global Const MIDI_START = &HFA 'Start playing
Global Const MIDI_CONTINUE = &HFB 'Continue playng after stop
Global Const MIDI_STOP = &HFC 'Stop playing
Global Const ACTIVE_SENSE = &HFE 'Some devices send this byte to indicate they're on
'SYSTEM Errors
Global Const MMSYSERR_BASE = 0 ' first error number
Global Const MMSYSERR_NOERROR = (MMSYSERR_BASE + 0) ' no error
Global Const MMSYSERR_ERROR = (MMSYSERR_BASE + 1) ' unspecified error
Global Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' bad device ID
Global Const MMSYSERR_NOTENABLED = (MMSYSERR_BASE + 3) ' device not enabled
Global Const MMSYSERR_ALLOCATED = (MMSYSERR_BASE + 4) ' device already allocated
Global Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' invalid device handle
Global Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no driver
Global Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' out of memory
Global Const MMSYSERR_NOTSUPPORTED = (MMSYSERR_BASE + 8) ' function not supported
Global Const MMSYSERR_BADERRNUM = (MMSYSERR_BASE + 9) ' bad error num (out of range)
Global Const MMSYSERR_INVALFLAG = (MMSYSERR_BASE + 10) ' invalid flag
Global Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter
Global Const MMSYSERR_LASTERROR = (MMSYSERR_BASE + 11) ' last error number
'MIDI Errors
Global Const MIDIERR_BASE = 64 ' first error number
Global Const MIDIERR_UNPREPARED = (MIDIERR_BASE + 0) ' header unprepared
Global Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still playing
Global Const MIDIERR_NOMAP = (MIDIERR_BASE + 2) ' no MIDI mapper
Global Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware busy
Global Const MIDIERR_NODEVICE = (MIDIERR_BASE + 4) ' device not present
Global Const MIDIERR_INVALIDSETUP = (MIDIERR_BASE + 5) ' invalid setup
Global Const MIDIERR_LASTERROR = (MIDIERR_BASE + 5) ' last error number
'Possible hooked MIDI Messages
'MIDI Input Messages
Global Const MIM_OPEN = &H3C1
Global Const MIM_CLOSE = &H3C2
Global Const MIM_DATA = &H3C3 'that's what we're interested in!
Global Const MIM_LONGDATA = &H3C4
Global Const MIM_ERROR = &H3C5
Global Const MIM_LONGERROR = &H3C6
'MIDI Output Messages
Global Const MOM_OPEN = &H3C7
Global Const MOM_CLOSE = &H3C8
Global Const MOM_DONE = &H3C9
'SEVERAL MIDI FLAGS, IDS, CONSTANTS, ETC...
'MIDI Mapper device ID
Global Const MIDIMAPPER = (-1)
Global Const MIDI_MAPPER = (-1)
'flags for wFlags in midiOutCachePatches(), midiOutCacheDrumPatches()
Global Const MIDI_CACHE_ALL = 1
Global Const MIDI_CACHE_BESTFIT = 2
Global Const MIDI_CACHE_QUERY = 3
Global Const MIDI_UNCACHE = 4
'flags used in midiInOpen() and midiOutOpen() to specify dwCallback type.
Global Const CALLBACK_TYPEMASK = &H70000 ' mask type
Global Const CALLBACK_NULL = &H0& ' no callback
Global Const CALLBACK_WINDOW = &H10000 ' dwCallback is HWND (window)
Global Const CALLBACK_TASK = &H20000 ' dwCallback is HTASK (task)
Global Const CALLBACK_FUNCTION = &H30000 ' dwCallback is FARPROC (function)
'IDs used in MIDIOUTCAPS, MIDIINCAPS
'Manufacturer IDs (wMid)
Global Const MM_MICROSOFT = 1 ' Microsoft Corp.
'Product IDs (wPid)
Global Const MM_MIDI_MAPPER = 1 ' MIDI Mapper
Global Const MM_WAVE_MAPPER = 2 ' Wave Mapper
Global Const MM_SNDBLST_MIDIOUT = 3 ' Sound Blaster MIDI output port
Global Const MM_SNDBLST_MIDIIN = 4 ' Sound Blaster MIDI input port
Global Const MM_SNDBLST_SYNTH = 5 ' Sound Blaster internal synthesizer
Global Const MM_SNDBLST_WAVEOUT = 6 ' Sound Blaster waveform output
Global Const MM_SNDBLST_WAVEIN = 7 ' Sound Blaster waveform input
Global Const MM_ADLIB = 9 ' Ad Lib-compatible synthesizer
Global Const MM_MPU401_MIDIOUT = 10 ' MPU401-compatible MIDI output port
Global Const MM_MPU401_MIDIIN = 11 ' MPU401-compatible MIDI input port
Global Const MM_PC_JOYSTICK = 12 ' Joystick adapter
'flags for wTechnology in MIDIOUTCAPS
Global Const MOD_MIDIPORT = 1 ' Hardware Midi Port
Global Const MOD_SYNTH = 2 ' Generic internal synthesizer
Global Const MOD_SQSYNTH = 3 ' Square wawe internal synthesizer
Global Const MOD_FMSYNTH = 4 ' FM internal synthesizer
Global Const MOD_MAPPER = 5 ' Midi Mapper
'flags for dwSupport in MIDIOUTCAPS
Global Const MIDICAPS_VOLUME = &H1 ' supports volume control
Global Const MIDICAPS_LRVOLUME = &H2 ' supports independent left/right control
Global Const MIDICAPS_CACHE = &H4 ' supports patch cache
'Midi Output Device capacity structure
Type MidiOutCaps
wMid As Integer ' Manufacturer ID
wPid As Integer ' Product ID
vDriverVersion As Integer ' 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
'Midi Input Device capacity structure
Type MidiInCaps
wMid As Integer ' Manufacturer ID
wPid As Integer ' Product ID
vDriverVersion As Integer ' Driver version
szPname As String * 32 ' Product name (NULL terminated string)
End Type
'flags for dwFlags in MIDIHDR
Global Const MHDR_DONE = &H1 ' bit indicates task done
Global Const MHDR_PREPARED = &H2 ' bit indicates header prepared
Global Const MHDR_INQUEUE = &H4 ' bit reserved for driver use
'MIDI Data Block Header (SYSEX)
Type MIDIHDR
lpData As Long ' pointer to a block of data
dwBufferLength As Long ' Buffer Length
dwBytesRecorded As Long ' n. of recorded Bytes (only for Input)
dwUser As Long ' reserved for user
dwFlags As Long ' flags (see previous definitions)
lpNext As Long ' reserved for driver
reserved As Long ' reserved for driver
End Type
'DECLARE API MIDI FUNCTIONS
'MIDI IN Functions
Declare Function midiInGetNumDevs% Lib "MMSYSTEM.DLL" ()
Declare Function midiInGetDevCaps% Lib "MMSYSTEM.DLL" (ByVal uDeviceID%, lpCaps As MidiInCaps, ByVal uSize%)
Declare Function midiInGetErrorText% Lib "MMSYSTEM.DLL" (ByVal uError%, ByVal lpText$, ByVal uSize%)
Declare Function midiInOpen% Lib "MMSYSTEM.DLL" (lphMidiIn As Integer, ByVal uDeviceID%, ByVal dwCallback&, ByVal dwInstance&, ByVal dwFlags&)
Declare Function midiInClose% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%)
Declare Function midiInPrepareHeader% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%, lpMidiInHdr As MIDIHDR, ByVal uSize%)
Declare Function midiInUnprepareHeader% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%, lpMidiInHdr As MIDIHDR, ByVal uSize%)
Declare Function midiInAddBuffer% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%, lpMidiInHdr As MIDIHDR, ByVal uSize%)
Declare Function midiInStart% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%)
Declare Function midiInStop% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%)
Declare Function midiInReset% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%)
Declare Function midiInGetID% Lib "MMSYSTEM.DLL" (ByVal hMidiIn%, lpuDeviceID%)
Declare Function midiInMessage& Lib "MMSYSTEM.DLL" (ByVal hMidiIn%, ByVal uMessage%, ByVal dw1&, ByVal dw2&)
'MIDI OUT Functions
Declare Function midiOutGetNumDevs% Lib "MMSYSTEM.DLL" ()
Declare Function midiOutGetDevCaps% Lib "MMSYSTEM.DLL" (ByVal uDeviceID%, lpCaps As MidiOutCaps, ByVal uSize%)
Declare Function midiOutGetVolume% Lib "MMSYSTEM.DLL" (ByVal uDeviceID%, lpdwVolume&)
Declare Function midiOutSetVolume% Lib "MMSYSTEM.DLL" (ByVal uDeviceID%, ByVal dwVolume&)
Declare Function midiOutGetErrorText% Lib "MMSYSTEM.DLL" (ByVal uError%, ByVal lpText$, ByVal uSize%)
Declare Function midiOutOpen% Lib "MMSYSTEM.DLL" (lphMidiOut As Integer, ByVal uDeviceID%, ByVal dwCallback&, ByVal dwInstance&, ByVal dwFlags&)
Declare Function midiOutClose% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%)
Declare Function midiOutPrepareHeader% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, lpMidiOutHdr As MIDIHDR, ByVal uSize%)
Declare Function midiOutUnprepareHeader% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, lpMidiOutHdr As MIDIHDR, ByVal uSize%)
Declare Function midiOutShortMsg% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, ByVal dwMsg&)
Declare Function midiOutLongMsg% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, lpMidiOutHdr As MIDIHDR, ByVal uSize%)
Declare Function midiOutReset% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%)
Declare Function midiOutCachePatches% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, ByVal uBank%, lpwPatchArray%, ByVal uFlags%)
Declare Function midiOutCacheDrumPatches% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, ByVal uPatch%, lpwKeyArray%, ByVal uFlags%)
Declare Function midiOutGetID% Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, lpuDeviceID%)
Declare Function midiOutMessage& Lib "MMSYSTEM.DLL" (ByVal hMidiOut%, ByVal uMessage%, ByVal dw1&, ByVal dw2&)
'DECLARE MISCELLANEOUS API FUNCTIONS
'High Resolution System Time (milliseconds)
Declare Function timeGetTime& Lib "MMSYSTEM.DLL" ()
'Read/Write private INI Files
Declare Function GetPrivateProfileString% Lib "kernel" (ByVal Sname$, ByVal Kname$, ByVal Def$, ByVal Ret$, ByVal Size%, ByVal Fname$)
Declare Function WritePrivateProfileString% Lib "kernel" (ByVal Sname$, ByVal Kname$, ByVal Set1$, ByVal Fname$)
'Returns Ini file value (string)
Function Ini_Read$ (ByVal sIniName As String, ByVal sSection As String, ByVal sParamName As String)
Dim sRetString As String
Dim sDefString As String
Dim i As Integer
sRetString = String$(255, Chr(0)) 'clear buffers
sDefString = String$(255, Chr(0))
vntRet = GetPrivateProfileString(sSection, sParamName, sDefString, sRetString, Len(sRetString), sIniName)
For i = 1 To 255
If Mid$(sRetString, i, 1) = Chr(0) Then 'API strings are zero ended
If i = 1 Then
sRetString = ""
Else
sRetString = Left$(sRetString, i - 1)
End If
Exit For
End If
Next i
Ini_Read = sRetString
End Function
Sub Ini_Write (ByVal sIniName As String, ByVal sSection As String, ByVal sParamName As String, ByVal sParamValue As String)
vntRet = WritePrivateProfileString(sSection, sParamName, sParamValue, sIniName)
End Sub
Sub Midi_ErrorAlert (ByVal iMidiError As Integer)
Dim sMsg As String
Select Case iMidiError
Case MMSYSERR_BADDEVICEID
sMsg = "Bad Device ID! "
Case MMSYSERR_NOTENABLED
sMsg = "Device not enabled!"
Case MMSYSERR_ALLOCATED
sMsg = "Device already allocated!"
Case MMSYSERR_INVALHANDLE
sMsg = "Invalid Device Handle!"
Case MMSYSERR_NODRIVER
sMsg = "Driver not found!"
Case MMSYSERR_NOMEM = (MMSYSERR_BASE + 7)
sMsg = "Out of memory!"
Case MIDIERR_STILLPLAYING
sMsg = "Device still playing!"
Case MIDIERR_NOMAP
sMsg = "MIDI Mapper device not found!"
Case MIDIERR_NOTREADY
sMsg = "Hardware not ready! "
Case MIDIERR_NODEVICE
sMsg = "Device not present!"
Case Else
sMsg = "Unexpected error!"
End Select
MsgBox sMsg, 48, "MIDI ERROR"
End Sub
Sub Midi_Panic ()
'not very standard but it works with all the computers I've tested
'Those are the usual device handles used by Windows to open and close MIDI ports
'Call it only if an application stops without closing the MIDI devices.
'Otherwise you'll have to reboot your system.
vntRet = midiInClose(966)
vntRet = midiInClose(986)
vntRet = midiInClose(1006)
vntRet = midiInClose(1026)
vntRet = midiOutClose(966)
vntRet = midiOutClose(986)
vntRet = midiOutClose(1006)
vntRet = midiOutClose(1026)
hMidiIn = NO_HANDLE
hMidiOut = NO_HANDLE
End Sub
Sub Midi_Populate_Lists (lstInList As Control, lstOutList As Control)
Dim i As Integer
Dim InCaps As MidiInCaps, OutCaps As MidiOutCaps
nInDevices = midiInGetNumDevs()
lstInList.List(0) = "Device not enabled"
For i = 0 To nInDevices - 1
vntRet = midiInGetDevCaps(i, InCaps, Len(InCaps))
If vntRet <> 0 Then
Call Midi_ErrorAlert(vntRet)
Exit For
End If
lstInList.List(i + 1) = InCaps.szPname
Next i
nOutDevices = midiOutGetNumDevs()
lstOutList.List(0) = "Device not enabled"
For i = -1 To nOutDevices - 1 'Midi Mapper = -1
vntRet = midiOutGetDevCaps(i, OutCaps, Len(OutCaps))
If vntRet <> 0 Then
Call Midi_ErrorAlert(vntRet)
Exit For
End If
lstOutList.List(i + 2) = OutCaps.szPname
Next i
End Sub
Sub MidiIn_Close ()
'If a MIDI In device was opened...
If hMidiIn <> NO_HANDLE Then
'Cancel MidiHook activity
frmMidiHook.MidiHook.Message(MIM_DATA) = False
'Stop Midi In activity
vntRet = midiInStop(hMidiIn)
If vntRet <> 0 Then Call Midi_ErrorAlert(vntRet)
'Close Midi In device
vntRet = midiInClose(hMidiIn)
If vntRet <> 0 Then Call Midi_ErrorAlert(vntRet)
'Set Midi In handle to not enabled state
hMidiIn = NO_HANDLE
End If
End Sub
Sub MidiIn_Open (ByVal nDevice)
'Close possible opened Midi In devices
Call MidiIn_Close
'Open Midi In device
vntRet = midiInOpen(hMidiIn, nDevice, frmMidiHook.hWnd, 0, CALLBACK_WINDOW)
'An error occurred
If vntRet <> 0 Then
'Close all usual Midi Device Handles
Call Midi_Panic
'Try to open again
vntRet = midiInOpen(hMidiIn, nDevice, frmMidiHook.hWnd, 0, CALLBACK_WINDOW)
'Error again!
If vntRet <> 0 Then
'No solution
Call Midi_ErrorAlert(vntRet)
hMidiIn = NO_HANDLE
Exit Sub
End If
End If
'Set frmMidiHook as a Callback Window
frmMidiHook.MidiHook.HwndHook = frmMidiHook.hWnd
'Set MidiHook Control to intercept only Midi In Data Messages
frmMidiHook.MidiHook.Message(MIM_DATA) = True
'Start Midi In activity
vntRet = midiInStart(hMidiIn)
If vntRet <> 0 Then
Call Midi_ErrorAlert(vntRet)
End If
End Sub
Sub MidiOut_Close ()
'If a MIDI Out device was opened...
If hMidiOut <> NO_HANDLE Then
'Close Midi Out device
vntRet = midiOutClose(hMidiOut)
If vntRet <> 0 Then
Call Midi_ErrorAlert(vntRet)
End If
'Set Midi Out handle to not enabled state
hMidiOut = NO_HANDLE
End If
End Sub
'Returns True if succesfull, False if unsuccesfull
Function MidiOut_ControlChange& (iChannel As Integer, iControlNumber As Integer, iControlValue As Integer)
Dim lMsg As Long
lMsg = (CONTROLLER_CHANGE + iChannel) + (256& * iControlNumber) + (65536 * iControlValue)
MidiOut_ControlChange = MidiOut_Msg(lMsg)
End Function
'Returns True if succesfull, False if unsuccesfull
Function MidiOut_Msg% (ByVal lMsg As Long)
If hMidiOut = NO_HANDLE Then
Call Dlg_Alert("Device not enabled!")
MidiOut_Msg = False
Exit Function
End If
MidiOut_Msg = True
vntRet = midiOutShortMsg(hMidiOut, lMsg)
If vntRet <> 0 Then
Call Midi_ErrorAlert(vntRet)
MidiOut_Msg = False
Exit Function
End If
'You may show here a screen representation of Midi Data Out.
'*********************************************
'SPECIFIC TO THIS APPLICATION
If bVisualData = True Then
If frmVBSeq.picDataOut.BackColor = LED_OFF Then
frmVBSeq.picDataOut.BackColor = LED_ON
End If
lDataOutTime = timeGetTime()
End If
'*********************************************
End Function
'Returns True if succesfull, False if unsuccesfull
Function MidiOut_Mtc (ByVal nQfID As Integer, ByVal nHours As Integer, ByVal nMinutes As Integer, ByVal nSeconds As Integer, ByVal nFrames As Integer)
Dim lMidiMessage As Long
Dim iMtcData As Integer
Dim iLoNib As Integer
If hMidiOut = NO_HANDLE Then
Call Dlg_Alert("Device not enabled!")
MidiOut_Mtc = False
Exit Function
End If
Select Case nQfID
Case 0: 'send frames lo Nibble
iLoNib = nFrames And &HF 'Bit0 to Bit3 of Frames
Case 1: 'send frames hi Nibble
iLoNib = (nFrames And &H10) / 16 'Bit4 of Frames
Case 2: 'send seconds lo Nibble
iLoNib = nSeconds And &HF 'Bit0 to Bit3 of Seconds
Case 3: 'send seconds hi Nibble
iLoNib = (nSeconds And &H30) / 16 'Bit4 and Bit5 of Seconds
Case 4: 'send minutes lo Nibble
iLoNib = nMinutes And &HF 'Bit0 to Bit3 of Minutes
Case 5: 'send minutes hi Nibble
iLoNib = (nMinutes And &H30) / 16 'Bit4 and Bit5 of Minutes
Case 6: 'send hours lo Nibble
iLoNib = nHours And &HF 'Bit0 to Bit3 of Hours
Case 7: 'send hours hi Nibble and MTC frame mode
iLoNib = (nHours And &H10) / 16 'Bit0 = Bit 4 of Hours
iLoNib = iLoNib + nMtcMode * 2 'Bit1 and Bit2 = nMtcMode (0,1,2,3)
End Select
'Hi Nibble = nQfID
iMtcData = nQfID * 16 + iLoNib
'Packed MTC Message -> Byte0 = Status / Byte1 = Data1 / Byte2 = 0
lMidiMessage = MTC_QFRAME + (iMtcData * 256&)
MidiOut_Mtc = True
vntRet = midiOutShortMsg(hMidiOut, lMidiMessage) 'send it out
If vntRet <> 0 Then
Call Midi_ErrorAlert(vntRet)
MidiOut_Mtc = False
Exit Function
End If
'You may show here a screen representation of MTC Out.
'*****************************************************************
'SPECIFIC TO THIS APPLICATION
If bVisualMtc = True Then
If frmVBSeq.picMtcOut.BackColor = LED_OFF Then
frmVBSeq.picMtcOut.BackColor = LED_ON
End If
lMtcOutTime = timeGetTime()
End If
'*****************************************************************
End Function
'Returns True if succesfull, False if unsuccesfull
Function MidiOut_NoteOff& (iChannel As Integer, iNoteNumber As Integer, iKeyvel As Integer)
Dim lMsg As Long
lMsg = (NOTE_OFF + iChannel) + (256& * iNoteNumber) + (65536 * iKeyvel)
MidiOut_NoteOff = MidiOut_Msg(lMsg)
End Function
'Returns True if succesfull, False if unsuccesfull
Function MidiOut_NoteOn& (iChannel As Integer, iNoteNumber As Integer, iKeyvel As Integer)
Dim lMsg As Long
lMsg = (NOTE_ON + iChannel) + (256& * iNoteNumber) + (65536 * iKeyvel)
MidiOut_NoteOn = MidiOut_Msg(lMsg)
End Function
Sub MidiOut_Open (ByVal nDevice)
'Close possible opened Midi Out Devices
Call MidiOut_Close
'Open Midi Out device
vntRet = midiOutOpen(hMidiOut, nDevice, 0, 0, 0)
If vntRet <> 0 Then
'Close all usual Midi Device Handles
Call Midi_Panic
'Try to open again
vntRet = midiOutOpen(hMidiOut, nDevice, 0, 0, 0)
'If error persists
If vntRet <> 0 Then
'No solution
Call Midi_ErrorAlert(vntRet)
hMidiOut = NO_HANDLE
End If
End If
End Sub
'Returns True if succesfull, False if unsuccesfull
Function MidiOut_ProgramChange& (iChannel As Integer, iProgramNumber As Integer)
Dim lMsg As Long
lMsg = (PROGRAM_CHANGE + iChannel) + (256& * iProgramNumber)
MidiOut_ProgramChange = MidiOut_Msg(lMsg)
End Function
Sub Mtc_Adjust (nHours As Integer, nMinutes As Integer, nSeconds As Integer, nFrames As Integer)
While nFrames >= nFramesPerSecond
nFrames = nFrames - nFramesPerSecond
nSeconds = nSeconds + 1
Wend
While nSeconds >= 60
nSeconds = nSeconds - 60
nMinutes = nMinutes + 1
Wend
While nMinutes >= 60
nMinutes = nMinutes - 60
nHours = nHours + 1
Wend
While nHours >= 24
nHours = nHours - 24
Wend
While nFrames < 0
nFrames = nFrames + nFramesPerSecond
nSeconds = nSeconds - 1
Wend
While nSeconds < 0
nSeconds = nSeconds + 60
nMinutes = nMinutes - 1
Wend
While nMinutes < 0
nMinutes = nMinutes + 60
nHours = nHours - 1
Wend
While nHours < 0
nHours = nHours + 24
Wend
End Sub
Sub Mtc_Frames_to_HMSF (ByVal lTotalFrames As Long, iHours As Integer, iMinutes As Integer, iSeconds As Integer, iFrames As Integer)
Dim lNum As Long
lNum = lTotalFrames
iFrames = lNum Mod nFramesPerSecond
lNum = Int(lNum / nFramesPerSecond)
iSeconds = lNum Mod 60
lNum = Int(lNum / 60)
iMinutes = lNum Mod 60
iHours = Int(lNum / 60)
End Sub
Function Mtc_HMSF_To_Frames& (ByVal iHours As Integer, ByVal iMinutes As Integer, ByVal iSeconds As Integer, ByVal iFrames As Integer)
Dim lTotalFrames As Long
lTotalFrames = (iHours * 3600& + iMinutes * 60& + iSeconds) * nFramesPerSecond + iFrames
Mtc_HMSF_To_Frames = lTotalFrames
End Function
Function Mtc_HMSF_To_Ms& (ByVal iHours As Integer, ByVal iMinutes As Integer, ByVal iSeconds As Integer, ByVal iFrames As Integer)
Dim lTotalMs As Long
lTotalMs = (iHours * 3600000) + (iMinutes * 60000) + (iSeconds * 1000&) + (iFrames * (1000& / nFramesPerSecond))
Mtc_HMSF_To_Ms = lTotalMs
End Function
Sub Mtc_Ms_To_HMSF (ByVal lTotalMs As Long, iHours As Integer, iMinutes As Integer, iSeconds As Integer, iFrames As Integer)
Dim lNum As Long
lNum = CLng(lTotalMs / fMsPerFrame) 'Rounded total N. of Frames
iFrames = lNum Mod nFramesPerSecond
lNum = Int(lNum / nFramesPerSecond)
iSeconds = lNum Mod 60
lNum = Int(lNum / 60)
iMinutes = lNum Mod 60
iHours = Int(lNum / 60)
End Sub
Function Mtc_SetMode$ (iMode As Integer)
Dim sMsg As String
nMtcMode = iMode
Select Case iMode
Case 0:
fMsPerQF = 250! / 24! 'must be single float
fMsPerFrame = 1000! / 24!
nFramesPerSecond = 24
sMsg = "24 f/s"
Case 1:
fMsPerQF = 250! / 25!
fMsPerFrame = 1000! / 25!
nFramesPerSecond = 25
sMsg = "25 f/s"
Case 2:
fMsPerQF = 250! / 29.96!
fMsPerFrame = 1000! / 29.96!
nFramesPerSecond = 30
sMsg = "30 f/s drop"
'
'Not supported in this version!!!!
'
'30 f/s drop frame mode is rarely used in MIDI applications.
'In this mode, selected frames are dropped to sync to
'american video 29.96 frame per second rate.
'Midihook_Message event procedure should take care of those
'dropped frames in its timing calculations.
'The procedure actually interprets dropped frames as discontinuous MTC!
'The MTC Functions and Subroutines should also be updated.
'
'
Case 3:
fMsPerQF = 250! / 30!
fMsPerFrame = 1000! / 30!
nFramesPerSecond = 30
sMsg = "30 f/s no drop"
End Select
Mtc_SetMode = sMsg
End Function