home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
tool
/
sound
/
vb_mid
/
vb_seq.bas
< prev
next >
Wrap
BASIC Source File
|
1995-02-05
|
29KB
|
955 lines
Option Explicit
'Type of recorded Midi Message
Type udtMidiMsg
TimeStamp As Long 'Associated time in milliseconds
MidiData As Long 'Usually: (Status + Channel) + (&H100& * Data1) + (&H10000 * Data2)
End Type
'RecBuffer parameters
Global aRecBuffer() As udtMidiMsg 'dynamic array of recorded messages
Global nRecCounter As Long 'N. of recorded messages
Global nRecErrors As Long 'N. of lost Midi In Messages
'Timing variables
Global lInitTime As Long 'timeGetTime() when Play or Rec starts (in Internal Sync)
Global lOffsetTime As Long 'Display Time when Play or Rec starts (in Internal Sync)
'Flags to track Play and Rec activity
Global bStop As Integer 'if True indicates Stop Mode
Global bPlay As Integer 'if True indicates Play Mode
Global bRec As Integer 'if True indicates Rec Mode
'For Clock displaying purposes (incremented by one frame every frame)
Global nDisplayHours As Integer
Global nDisplayMinutes As Integer
Global nDisplaySeconds As Integer
Global nDisplayFrames As Integer
'For MTC Out purposes (incremented by two frames every two frames)
Global nHoursCounter As Integer
Global nMinutesCounter As Integer
Global nSecondsCounter As Integer
Global nFramesCounter As Integer
'Name of the last saved or opened file
Global sFilename As String
'Visualize flags
Global bVisualClock As Integer 'Visualize clock display
Global bVisualData As Integer 'Visualize Midi Data Flow
Global bVisualMtc As Integer 'Visualize MTC flow
'To track Midi flow visualisation
Global lMtcInTime As Long 'Time when MtcIn led was switched on
Global lMtcOutTime As Long 'Time when MtcOut led was switched on
Global lDataInTime As Long 'Time when DataIn led was switched on
Global lDataOutTime As Long 'Time when DataOut led was switched on
'Sequencer parameters
Global nSeqChannel As Integer
Global aSeqProgram(15) As Integer
'Indicates Mouse state in Rewind and Forward MouseDown events
Global bMouseDown As Integer
'Led colors
Global Const LED_OFF = &H80&
Global Const LED_ON = &H80FF&
'GENERAL CONSTANTS
'MousePointer
Global Const DEFAULT = 0
Global Const HOURGLASS = 11
'Keycodes
Global Const KEY_ESCAPE = &H1B
Global Const KEY_NUMPAD0 = &H60
Global Const KEY_RETURN = &HD
Global Const KEY_MULTIPLY = &H6A
Global Const KEY_SPACE = &H20
Global Const KEY_F12 = &H7B
'Special keys
Global Const SHIFT_MASK = 1
Global Const CTRL_MASK = 2
Global Const ALT_MASK = 4
' MsgBox parameters
Global Const MB_OK = 0 ' OK button only
Global Const MB_YESNO = 4 ' Yes and No buttons
Global Const MB_ICONQUESTION = 32 ' Warning query
Global Const MB_ICONEXCLAMATION = 48 ' Warning message
' MsgBox return values
Global Const IDOK = 1 ' OK button pressed
Global Const IDYES = 6 ' Yes button pressed
Global Const IDNO = 7 ' No button pressed
'Colors
Global Const WHITE = &HFFFFFF
Global Const DARKBLUE = &H800000
' DragOver
Global Const ENTER = 0
Global Const LEAVE = 1
Sub Display_Erase ()
If frmVBSeq.lblHours <> "--" Then frmVBSeq.lblHours = "--"
If frmVBSeq.lblMinutes <> "--" Then frmVBSeq.lblMinutes = "--"
If frmVBSeq.lblSeconds <> "--" Then frmVBSeq.lblSeconds = "--"
If frmVBSeq.lblFrames <> "--" Then frmVBSeq.lblFrames = "--"
End Sub
Sub Display_Show ()
Dim sDisplay As String
sDisplay = Format$(nDisplayHours, "00")
If frmVBSeq.lblHours <> sDisplay Then frmVBSeq.lblHours = sDisplay
sDisplay = Format$(nDisplayMinutes, "00")
If frmVBSeq.lblMinutes <> sDisplay Then frmVBSeq.lblMinutes = sDisplay
sDisplay = Format$(nDisplaySeconds, "00")
If frmVBSeq.lblSeconds <> sDisplay Then frmVBSeq.lblSeconds = sDisplay
sDisplay = Format$(nDisplayFrames, "00")
If frmVBSeq.lblFrames <> sDisplay Then frmVBSeq.lblFrames = sDisplay
End Sub
Sub Dlg_Alert (sMsg As String)
Beep
MsgBox sMsg, MB_OK + MB_ICONEXCLAMATION, "ALERT"
End Sub
Function Dlg_YesNo (sMsg1 As String) As Integer
Dim sMsg2 As String
sMsg2 = "Make your decission"
Beep
If MsgBox(sMsg1, MB_YESNO + MB_ICONQUESTION, sMsg2) = IDYES Then
Dlg_YesNo = True
Else
Dlg_YesNo = False
End If
End Function
'Returns True if File must be deleted / False if File must not
Function File_Delete% (sPath As String)
Dim i As Integer
Dim sName As String
Dim FNum As Integer
If Len(sPath) <= 1 Or Mid$(sPath, Len(sPath), 1) = "\" Then
Call Dlg_Alert(sFilename & Chr(10) & "Bad file name!")
frmVBSeq.dlgFileDialog.Filename = "*.SNG"
sFilename = "?"
File_Delete = False
Exit Function
End If
For i = Len(sPath) To 1 Step -1
If Mid$(sPath, i, 1) = "\" Then
sName = Mid$(sPath, i + 1, Len(sPath) - i)
Exit For
End If
Next i
FNum = FreeFile
On Error Resume Next
Open sPath For Input As FNum
'No error -> File already exists
If Err = 0 Then
If Dlg_YesNo(sName & " already exists!" & Chr(10) & "Replace it...?") = True Then
'overwrite it
File_Delete = True
Else
'abort save
File_Delete = False
End If
'File not found
ElseIf Err = 53 Then
'doesn't need to be deleted
'keep on saving
File_Delete = True
'Bad File Name
ElseIf Err = 64 Or Err = 52 Then
Call Dlg_Alert(sName & Chr(10) & "Bad file name!")
frmVBSeq.dlgFileDialog.Filename = "*.SNG"
sFilename = "?"
'abort save
File_Delete = False
'Unexpected error
Else
Call Dlg_Alert("Error #" & Err & Chr(10) & Error$)
frmVBSeq.dlgFileDialog.Filename = "*.SNG"
sFilename = "?"
'abort save
File_Delete = False
End If
Close FNum
End Function
Sub File_Open ()
Dim FNum As Integer
Dim nLen As Integer
Dim i As Integer
'If buffer not empty confirm loss of data
If nRecCounter > 0 Then
If Dlg_YesNo("Erase recorded MIDI messages?") = False Then Exit Sub
End If
On Error GoTo Open_Error_Handler
'Activate cancel error
frmVBSeq.dlgFileDialog.CancelError = True
'Set File Dialog parameters
frmVBSeq.dlgFileDialog.Filter = "Custom MIDI song (*.SNG)|*.SNG|Standard MIDI file (*.MID)|*.MID|All (*.*)|*.*"
frmVBSeq.dlgFileDialog.FilterIndex = 1
frmVBSeq.dlgFileDialog.DialogTitle = "Open File"
frmVBSeq.dlgFileDialog.Action = 1 '1 = Open file dialog
frmVBSeq.Refresh
'Get path and file name to be opened
sFilename = frmVBSeq.dlgFileDialog.Filename
nLen = Len(sFilename)
For i = nLen To 1 Step -1
If Mid$(sFilename, i, 1) = "\" Then Exit For
Next i
sFilename = Right$(sFilename, nLen - i)
Screen.MousePointer = HOURGLASS
If Right$(sFilename, 4) = ".SNG" Then
FNum = FreeFile
Open frmVBSeq.dlgFileDialog.Filename For Input As FNum
Input #FNum, nRecCounter
If nRecCounter > 0 Then
ReDim aRecBuffer(nRecCounter + 1024 - (nRecCounter Mod 1024))
For i = 0 To nRecCounter - 1
Input #FNum, aRecBuffer(i).TimeStamp
Input #FNum, aRecBuffer(i).MidiData
Next i
End If
'Display recorded messages counter
frmVBSeq.lblRecMesNum = CStr(nRecCounter)
Close #FNum
ElseIf Right$(sFilename, 4) = ".MID" Then
Call Dlg_Alert("Not implemented!")
Else
Call Dlg_Alert("Wrong file format!")
End If
Open_Exit:
Screen.MousePointer = DEFAULT
Exit Sub
Open_Error_Handler:
If Err = 32755 Then 'Cancel
Resume Open_Exit
Else
Call Dlg_Alert("Error #" & Err & Chr(10) & Error$)
Close #FNum
Resume Open_Exit
End If
End Sub
Sub File_Save ()
Dim sFname As String
Dim FNum As Integer
Dim i As Integer
Dim nStartName As Integer
Dim nLen As Integer
'Exit if buffer empty
If nRecCounter = 0 Then
Call Dlg_Alert("Nothing to save!")
Exit Sub
End If
On Error GoTo Save_Error_Handler
'Activate cancel error
frmVBSeq.dlgFileDialog.CancelError = True
'Set File Dialog parameters
frmVBSeq.dlgFileDialog.Filter = "Custom MIDI song (*.SNG)|*.SNG|Standard MIDI file (*.MID)|*.MID|All (*.*)|*.*"
frmVBSeq.dlgFileDialog.FilterIndex = 1
frmVBSeq.dlgFileDialog.DialogTitle = "Save File"
frmVBSeq.dlgFileDialog.Action = 2 '2 = Savefile Dialog
frmVBSeq.Refresh
'Get path and file name to be saved
sFname = frmVBSeq.dlgFileDialog.Filename
'Check Filename suffix (must be .SNG)
If Right$(sFname, 4) <> ".SNG" Then 'And Right$(sFname, 4) <> ".MID"
nLen = Len(sFname)
For i = nLen To 1 Step -1
If Mid$(sFname, i, 1) = "\" Then Exit For
Next i
nStartName = i
If nStartName = 0 Then nStartName = 1 'for safety
For i = nLen To nStartName Step -1
If Mid$(sFname, i, 1) = "." Then 'Is there a wrong suffix?
sFname = Left$(sFname, i - 1) 'Remove suffix
Exit For
End If
Next i
'add suffix
sFname = sFname & ".SNG"
End If
'Check if file exists and user wants to replace it
If File_Delete(sFname) = False Then Exit Sub
nLen = Len(sFname)
For i = nLen To 1 Step -1
If Mid$(sFname, i, 1) = "\" Then Exit For
Next i
sFilename = Right$(sFname, nLen - i)
FNum = FreeFile
Open sFname For Output As FNum
Screen.MousePointer = HOURGLASS
Write #FNum, nRecCounter
If nRecCounter > 0 Then
For i = 0 To nRecCounter - 1
Write #FNum, aRecBuffer(i).TimeStamp, aRecBuffer(i).MidiData
Next i
End If
Save_Exit1:
Close #FNum
Save_Exit2:
Screen.MousePointer = DEFAULT
Exit Sub
Save_Error_Handler:
If Err = 64 Or Err = 20477 Then
Call Dlg_Alert(sFname & Chr(10) & "Bad file name!")
frmVBSeq.dlgFileDialog.Filename = "*.SNG"
sFilename = "?"
Resume Save_Exit2
ElseIf Err = 32755 Then 'Cancel
Resume Save_Exit2
Else
Call Dlg_Alert("Error #" & Err & Chr(10) & Error$)
Resume Save_Exit1
End If
End Sub
Function Get_Next& (lTime As Long)
Dim lCount As Long
Get_Next = -1&
If nRecCounter = 0& Then Exit Function
For lCount = 0& To nRecCounter - 1&
If aRecBuffer(lCount).TimeStamp >= lTime Then
Get_Next = lCount
Exit For
End If
vntRet = DoEvents()
Next lCount
End Function
Function KeytoNum (KeyCode As Integer) As Integer
Select Case KeyCode
Case Asc("0") To Asc("9")
KeytoNum = KeyCode - Asc("0")
Case KEY_NUMPAD0 To KEY_NUMPAD0 + 9
KeytoNum = KeyCode - KEY_NUMPAD0
Case Else
KeytoNum = -1
End Select
End Function
Function Label_Decrement% (lblLabel As Label, nMin As Integer, nOffset As Integer)
Dim nValue As Integer, bFirst As Integer
bMouseDown = True
bFirst = True
Do While bMouseDown = True
nValue = Val(lblLabel.Caption)
If nValue > nMin Then
nValue = nValue - nOffset
If nValue < nMin Then nValue = nMin
lblLabel.Caption = CStr(nValue)
lblLabel.Refresh
End If
If bFirst = True Then 'For key repeat purposes
Wait_DoEvents (200)
bFirst = False
Else
Wait_DoEvents (10)
End If
Loop
Label_Decrement = nValue
End Function
Function Label_Increment% (lblLabel As Label, nMax As Integer, nOffset As Integer)
Dim nValue As Integer, bFirst As Integer
bMouseDown = True
bFirst = True
Do While bMouseDown = True
nValue = Val(lblLabel)
If nValue < nMax Then
nValue = nValue + nOffset
If nValue > nMax Then nValue = nMax
lblLabel.Caption = CStr(nValue)
lblLabel.Refresh
End If
If bFirst = True Then 'For key repeat purposes
Wait_DoEvents (200)
bFirst = False
Else
Wait_DoEvents (10)
End If
Loop
Label_Increment = nValue
End Function
Sub Play_External ()
Dim lPlayPointer As Long
Dim lNextTime As Long
Dim lNextData As Long
Dim nOldMtcFrames As Long
Dim bPlayError As Integer
'If already playing or recording -> do nothing
If bStop = False Then Exit Sub
'Change tracking buttons appearance to Play position.
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayDn.Picture
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopUp.Picture
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecUp.Picture
'Set corresponding flags
bRec = False
bStop = False
bPlay = True
'reset play error flag
bPlayError = False
'Reset play variables to ready to start play values
nNewMtc = 0 'new MTC not yet received
nQfIdExpected = &H0 'first quarter frame message to be taked in account
lPlayPointer = -1 'nothing to play yet
'Set Mtc variables to out of sync values
bInSync = False
nMtcTotalframes = -1
lMtcTime = -1
nOldMtcFrames = -1
Do While bStop = False
If bInSync = False Then
'Erase clock to indicate that we're out of sync
Display_Erase
nMtcTotalframes = -1
lMtcTime = -1
nOldMtcFrames = -1
Else
'Check if MTC has changed
If nNewMtc > 0 Then
'a new MTC could arrive while we're trying to resync
'so make sure that we're in sync before exiting loop
Do
'resync as many times as necessary
lPlayPointer = Get_Next(lMtcTime + 250) '500 ms. preroll
nNewMtc = nNewMtc - 1
vntRet = DoEvents() 'to allow new MTC messages to be hooked
Loop While nNewMtc > 0 'exit loop when we're in sync
'Get_Next() function returns -1 if there's nothing to play, thus...
If lPlayPointer >= 0 Then
'parameters of next message to be played
lNextTime = aRecBuffer(lPlayPointer).TimeStamp
lNextData = aRecBuffer(lPlayPointer).MidiData
End If
End If
'Play everything that should be played
Do While lPlayPointer >= 0 And lMtcTime >= lNextTime
If MidiOut_Msg(lNextData) = False Then
'if a MIDI OUT error occurred -> stop playing
bPlayError = True
Exit Do
End If
'to allow new MTC messages to be hooked
vntRet = DoEvents()
'Increase array pointer
lPlayPointer = lPlayPointer + 1
If lPlayPointer >= nRecCounter Then
'nothing else to be played
lPlayPointer = -1
Else
'parameters of next message to be played
lNextTime = aRecBuffer(lPlayPointer).TimeStamp
lNextData = aRecBuffer(lPlayPointer).MidiData
End If
Loop
'Can't continue
If bPlayError = True Then Exit Do
'Set new clock values if necessary
If bVisualClock = True Then
If nMtcTotalframes <> nOldMtcFrames Then
'convert frame counter to clock values
Call Mtc_Frames_to_HMSF(nMtcTotalframes, nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
'show new values
Call Display_Show
nOldMtcFrames = nMtcTotalframes
End If
End If
End If
'to allow Stop button to be pressed and new MTC messages to be hooked
vntRet = DoEvents()
Loop
'In case visualize Clock was disabled set it to last received MTC time
If nMtcTotalframes = -1 Then nMtcTotalframes = 0
Call Mtc_Frames_to_HMSF(nMtcTotalframes, nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
'Change tracking buttons appearance back to Stop position
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopDn.Picture
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayUp.Picture
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecUp.Picture
'Set flags accordingly
bStop = True
bPlay = False
bRec = False
End Sub
Sub Play_Internal ()
Dim lSystemTime As Long
Dim lPlayingTime As Long
Dim fEllapsedTime As Single
Dim fLastQfTime As Single
Dim lPlayPointer As Long
Dim lNextTime As Long
Dim lNextData As Long
Dim nQfCounter As Integer
Dim lQfTotalCounter As Long
Dim bPlayError As Integer
'If already playing or recording -> do nothing
If bStop = False Then Exit Sub
'Change tracking buttons appearance to Play position.
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayDn.Picture
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopUp.Picture
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecUp.Picture
'Set corresponding flags
bRec = False
bStop = False
bPlay = True
'Check if Display Clock values are correct and show them.
nDisplayHours = Val(frmVBSeq.lblHours)
nDisplayMinutes = Val(frmVBSeq.lblMinutes)
nDisplaySeconds = Val(frmVBSeq.lblSeconds)
nDisplayFrames = Val(frmVBSeq.lblFrames)
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
'Assign Smpte internal counters to match Clock values.
nHoursCounter = nDisplayHours
nMinutesCounter = nDisplayMinutes
nSecondsCounter = nDisplaySeconds
nFramesCounter = nDisplayFrames
'Initial Offset = Clock values at Start playing (in milliseconds)
lOffsetTime = Mtc_HMSF_To_Ms(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
'Get next array index to be played
lPlayPointer = Get_Next(lOffsetTime) 'if there's nothing to play returns -1
If lPlayPointer >= 0 Then
lNextTime = aRecBuffer(lPlayPointer).TimeStamp
lNextData = aRecBuffer(lPlayPointer).MidiData
End If
'Reset Quarter frame counters
nQfCounter = 0
lQfTotalCounter = 0
'Reset Play error flag
bPlayError = False
'Set timing variables
lInitTime = timeGetTime() 'Actual high resolution system time in ms.
fLastQfTime = lInitTime 'To calculate time ellapsed since last quarter frame
Do While bStop = False
'actual system time
lSystemTime = timeGetTime()
'actual playing time
lPlayingTime = lOffsetTime + (lSystemTime - lInitTime)
'Play everything that should be played
Do While lPlayPointer >= 0 And lPlayingTime >= lNextTime
If MidiOut_Msg(lNextData) = False Then
'if a MIDI OUT error occurred -> stop playing
bPlayError = True
Exit Do
End If
'Increase array pointer
lPlayPointer = lPlayPointer + 1
If lPlayPointer >= nRecCounter Then
'nothing else to be played
lPlayPointer = -1
Else
'parameters of next message to be played
lNextTime = aRecBuffer(lPlayPointer).TimeStamp
lNextData = aRecBuffer(lPlayPointer).MidiData
End If
Loop
'Can't continue
If bPlayError = True Then Exit Do
'A new quarter frame interval ellapsed?
fEllapsedTime = CSng(lSystemTime) - fLastQfTime
If fEllapsedTime >= fMsPerQF Then
'Yes, send next MTC quarter frame message out (if requested)
If bMtcOut = True Then
If MidiOut_Mtc(nQfCounter, nHoursCounter, nMinutesCounter, nSecondsCounter, nFramesCounter) = False Then
'if a MIDI OUT error occurred -> stop playing
Exit Do
End If
End If
'To start counting next quarter frame interval
lQfTotalCounter = lQfTotalCounter + 1
'Operation must be float to avoid rounding errors
fLastQfTime = CSng(lInitTime) + fMsPerQF * CSng(lQfTotalCounter)
'increase MTC out quarter frame counter
nQfCounter = nQfCounter + 1
If nQfCounter = 4 Then
'One whole frame interval has ellapsed (4 quarter frames)
'Thus increase Display Frame Counter (Clock) if necessary
If bVisualClock = True Then
nDisplayFrames = nDisplayFrames + 1
'Check if parameters are correct and display new clock values
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
End If
ElseIf nQfCounter = 8 Then
If bVisualClock = True Then
'Another whole frame interval has elapsed (4 quarter frames more)
'Actualize clock values as before
nDisplayFrames = nDisplayFrames + 1
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
End If
'One complete MTC message takes 2 frames to be sent.
'As MTC hours, minutes, seconds or frames can not be changed in the middle
'of sending the MTC message, we must increase SMPTE Frame Counter
'only every 2 Frames (after a whole MTC message is completed)
nFramesCounter = nFramesCounter + 2
'Check if parameters are correct
Call Mtc_Adjust(nHoursCounter, nMinutesCounter, nSecondsCounter, nFramesCounter)
'wrap around MTC out quarter frame counter
nQfCounter = 0
End If
End If
DoEvents 'allows bStop to be changed by pressing Stop button or Space key
Loop
'If visualize Clock was disabled set it to last MTC time
If bVisualClock = False Then
'Assign Clock values to match MTC internal counters.
nDisplayHours = nHoursCounter
nDisplayMinutes = nMinutesCounter
nDisplaySeconds = nSecondsCounter
nDisplayFrames = nFramesCounter
'Check if Display Clock values are correct and show them.
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
End If
'Change tracking buttons appearance back to Stop position
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopDn.Picture
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayUp.Picture
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecUp.Picture
'Set flags accordingly
bStop = True
bPlay = False
bRec = False
End Sub
Sub Rec_External ()
Dim nOldMtcFrames As Long
'Change tracking buttons appearance to Play position.
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecDn.Picture
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayDn.Picture
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopUp.Picture
'Set corresponding flags
bRec = True
bStop = False
bPlay = False
'Reset Recorded messages caption
frmVBSeq.lblRecMesNum = "0"
'Prepare Rec buffer array
nRecCounter = 0
Erase aRecBuffer
'Reset rec variables to ready to start rec values
nNewMtc = 0 'new MTC not yet received
nQfIdExpected = &H0 'first quarter frame message identifier expected
'Set Mtc variables to out of sync values
bInSync = False
nMtcTotalframes = -1
lMtcTime = -1
nOldMtcFrames = -1
Do While bStop = False
If bInSync = False Then
'Erase clock to indicate that we're out of sync
Display_Erase
nMtcTotalframes = -1
lMtcTime = -1
nOldMtcFrames = -1
Else
If bVisualClock = True Then
'Set new clock values if necessary
If nMtcTotalframes <> nOldMtcFrames Then
'convert frame counter to clock values
Call Mtc_Frames_to_HMSF(nMtcTotalframes, nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
'show new values
Call Display_Show
nOldMtcFrames = nMtcTotalframes
End If
End If
End If
'to allow Stop button to be pressed and new MTC messages to be hooked
vntRet = DoEvents()
Loop
'If Visualize Clock was disabled set it to last received MTC time
If nMtcTotalframes = -1 Then nMtcTotalframes = 0
Call Mtc_Frames_to_HMSF(nMtcTotalframes, nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
'Change tracking buttons appearance back to Stop position
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopDn.Picture
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayUp.Picture
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecUp.Picture
'Set flags accordingly
bStop = True
bPlay = False
bRec = False
'Display recorded messages counter
frmVBSeq.lblRecMesNum = CStr(nRecCounter)
End Sub
Sub Rec_Internal ()
Dim fEllapsedTime As Long
Dim fLastQfTime As Long
Dim nQfCounter As Integer
Dim lQfTotalCounter As Long
Dim nHoursCounter As Integer
Dim nMinutesCounter As Integer
Dim nSecondsCounter As Integer
Dim nFramesCounter As Integer
'Change tracking buttons appearance to Rec position.
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecDn.Picture
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayDn.Picture
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopUp.Picture
'Set corresponding flags
bRec = True
bStop = False
bPlay = False
'Check if Display Clock values are correct and show them.
nDisplayHours = Val(frmVBSeq.lblHours)
nDisplayMinutes = Val(frmVBSeq.lblMinutes)
nDisplaySeconds = Val(frmVBSeq.lblSeconds)
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
'Assign Smpte internal counters to match Clock values
nHoursCounter = nDisplayHours
nMinutesCounter = nDisplayMinutes
nSecondsCounter = nDisplaySeconds
nFramesCounter = nDisplayFrames
'Reset Recorded messages caption
frmVBSeq.lblRecMesNum = "0"
'Prepare Rec buffer array
nRecCounter = 0
Erase aRecBuffer
'Reset Quarter frame counters
lQfTotalCounter = 0
nQfCounter = 0
'Set timing variables used by MidiHook to timestamp incoming Midi Data
'Initial Offset = Display Clock values at Start playing (in milliseconds)
lOffsetTime = Mtc_HMSF_To_Ms(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
'Actual system time in milliseconds
lInitTime = timeGetTime()
'system time at last quarter frame message
fLastQfTime = lInitTime
Do While bStop = False
'time ellapsed since last quarter frame message
fEllapsedTime = CSng(timeGetTime()) - fLastQfTime
If fEllapsedTime >= fMsPerQF Then
'A quarter frame time has elapsed
'Send next MTC quarter frame message out
If bMtcOut = True Then
If MidiOut_Mtc(nQfCounter, nHoursCounter, nMinutesCounter, nSecondsCounter, nFramesCounter) = False Then
'if a MIDI OUT error occurred -> stop playing
Exit Do
End If
End If
'To start counting next quarter frame interval
lQfTotalCounter = lQfTotalCounter + 1
'Operation must be float to avoid rounding errors
fLastQfTime = CSng(lInitTime) + fMsPerQF * CSng(lQfTotalCounter)
'increase MTC out quarter frame counter
nQfCounter = nQfCounter + 1 'increase local quarter frame counter
If nQfCounter = 4 Then
If bVisualClock = True Then
'One frame has elapsed (4 quarter frames)
'Thus increase Display Frame Counter (Clock)
nDisplayFrames = nDisplayFrames + 1
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
vntRet = DoEvents() 'to allow Midi In Data to be hooked
End If
ElseIf nQfCounter = 8 Then
If bVisualClock = True Then
'Another frame has elapsed
'Increase Display Frame Counter
nDisplayFrames = nDisplayFrames + 1
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
vntRet = DoEvents() 'to allow Midi In Data to be hooked
End If
'One complete MTC message takes 2 frames to be sent.
'As MTC hours, minutes, seconds or frames can not be changed in the middle
'of sending the MTC message, we must increase SMPTE Frame Counter
'only every 2 Frames (after a whole MTC message is completed)
nFramesCounter = nFramesCounter + 2
Call Mtc_Adjust(nHoursCounter, nMinutesCounter, nSecondsCounter, nFramesCounter)
'wrap around MTC out quarter frame counter
nQfCounter = 0
End If
End If
vntRet = DoEvents() 'to allow Midi In Data to be hooked and trap Stop button click
Loop
'If Visualize Clock was disabled set it to last SMPTE time
If bVisualClock = False Then
'Assign Clock values to match Smpte internal counters.
nDisplayHours = nHoursCounter
nDisplayMinutes = nMinutesCounter
nDisplaySeconds = nSecondsCounter
nDisplayFrames = nFramesCounter + 1
'Check if Display Clock values are correct and show them.
Call Mtc_Adjust(nDisplayHours, nDisplayMinutes, nDisplaySeconds, nDisplayFrames)
Call Display_Show
End If
'Change tracking buttons appearance back to Stop position
frmVBSeq.cmdStop.Picture = frmVBSeq.cmdStopDn.Picture
frmVBSeq.cmdPlay.Picture = frmVBSeq.cmdPlayUp.Picture
frmVBSeq.cmdRec.Picture = frmVBSeq.cmdRecUp.Picture
'Set flags accordingly
bStop = True
bPlay = False
bRec = False
'Display recorded messages counter
frmVBSeq.lblRecMesNum = CStr(nRecCounter)
End Sub
Sub Wait_DoEvents (lDelay As Long)
Dim lSystemTime As Long
lSystemTime = timeGetTime()
Do
DoEvents
Loop Until timeGetTime() - lSystemTime >= lDelay
End Sub