Multimédia la Compil' 2/Sybex_Multimedia_La_Compil_2.iso/cooltool/mfedit/mfedit.frm

Text File | 1995-04-20 | 36KB | 1,178 lines

VERSION 2.00
Begin Form Form1
   AutoRedraw      =   -1  'True
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "MFEDIT"
   ClientHeight    =   5355
   ClientLeft      =   720
   ClientTop       =   2070
   ClientWidth     =   9240
   Height          =   6045
   Icon            =   MFEDIT.FRX:0000
   Left            =   660
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5355
   ScaleWidth      =   9240
   Top             =   1440
   Width           =   9360
   Begin Frame Frame3
      BackColor       =   &H00C0C0C0&
      Caption         =   "Playback Rate"
      Height          =   855
      Left            =   7080
      TabIndex        =   12
      Top             =   2220
      Width           =   2055
      Begin HSlider PlaybackRateSlider
         BackColor       =   &H00C0C0C0&
         BevelInner      =   1  'Raised
         BevelOuter      =   0  'None
         BevelWidth      =   2
         BorderWidth     =   2
         Gap             =   3
         Height          =   435
         LargeChange     =   10
         Left            =   120
         LinkControl     =   "MIDIOutput1"
         LinkProperty    =   "PlaybackRate"
         Max             =   100
         Min             =   -100
         ThumbHeight     =   340
         ThumbStyle      =   2  'Pointed Down
         ThumbWidth      =   120
         TickColor       =   &H00000000&
         TickCount       =   20
         TickLength      =   4
         TickMarks       =   2  'Bottom
         TickWidth       =   1
         Top             =   300
         TrackBevel      =   2  'Inset
         TrackWidth      =   2
         Value           =   0
         Width           =   1815
      End
   End
   Begin Frame Frame5
      BackColor       =   &H00C0C0C0&
      Caption         =   "Playback Controls"
      Height          =   2115
      Left            =   7080
      TabIndex        =   30
      Top             =   3180
      Width           =   2055
      Begin CommandButton CmdStop
         Caption         =   "Stop"
         Height          =   435
         Left            =   120
         TabIndex        =   31
         Top             =   1500
         Width           =   1815
      End
      Begin CommandButton CmdRecord
         Caption         =   "Record"
         Height          =   435
         Left            =   120
         TabIndex        =   32
         Top             =   900
         Width           =   1815
      End
      Begin CommandButton CmdPlay
         Caption         =   "Play"
         Height          =   435
         Left            =   120
         TabIndex        =   33
         Top             =   300
         Width           =   1815
      End
   End
   Begin Frame Frame4
      BackColor       =   &H00C0C0C0&
      Caption         =   "MIDI File Settings"
      Height          =   2175
      Left            =   7080
      TabIndex        =   36
      Top             =   -30
      Width           =   2055
      Begin Label LabelTicks
         Alignment       =   2  'Center
         BackColor       =   &H00000000&
         Caption         =   "Tick"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   9.75
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         ForeColor       =   &H0000FF00&
         Height          =   255
         Left            =   240
         TabIndex        =   37
         Top             =   1800
         Width           =   1635
      End
      Begin Label LabelTimeSignature
         Alignment       =   2  'Center
         BackColor       =   &H00000000&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Time Signature"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   9.75
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         ForeColor       =   &H0000FF00&
         Height          =   315
         Left            =   240
         TabIndex        =   34
         Top             =   540
         Width           =   1635
      End
      Begin Label LabelTempo
         Alignment       =   2  'Center
         BackColor       =   &H00000000&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Tempo"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   9.75
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         ForeColor       =   &H0000FF00&
         Height          =   315
         Left            =   240
         TabIndex        =   35
         Top             =   1140
         Width           =   1635
      End
      Begin Label Label7
         Alignment       =   2  'Center
         BackColor       =   &H00C0C0C0&
         Caption         =   "Time Signature"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   9.75
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   40
         Top             =   300
         Width           =   1815
      End
      Begin Label Label8
         Alignment       =   2  'Center
         BackColor       =   &H00C0C0C0&
         Caption         =   "Tempo"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   9.75
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   39
         Top             =   900
         Width           =   1815
      End
      Begin Label Label9
         Alignment       =   2  'Center
         BackColor       =   &H00C0C0C0&
         Caption         =   "Ticks Per Quarter Note"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   38
         Top             =   1560
         Width           =   1815
      End
   End
   Begin MIDIFile MIDIFile1
      Filename        =   ""
      Left            =   1440
      ReadOnly        =   0   'False
      Top             =   5340
   End
   Begin MIDIInput MIDIInput1
      DeviceID        =   0
      Left            =   1860
      MaxSysexSize    =   32000
      MessageEventEnable=   0   'False
      Top             =   5340
   End
   Begin PictureBox Picture1
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   435
      Left            =   60
      ScaleHeight     =   435
      ScaleWidth      =   6915
      TabIndex        =   19
      Top             =   30
      Width           =   6915
      Begin CheckBox MidiThruCheck
         BackColor       =   &H00C0C0C0&
         Caption         =   "Midi Thru"
         Height          =   255
         Left            =   2820
         TabIndex        =   22
         Top             =   60
         Value           =   1  'Checked
         Width           =   1155
      End
      Begin ComboBox InputDevCombo
         Height          =   300
         Left            =   60
         Style           =   2  'Dropdown List
         TabIndex        =   18
         Top             =   60
         Width           =   2535
      End
      Begin ComboBox OutputDevCombo
         Height          =   300
         Left            =   4140
         Style           =   2  'Dropdown List
         TabIndex        =   20
         Top             =   60
         Width           =   2535
      End
   End
   Begin Frame Frame2
      BackColor       =   &H00C0C0C0&
      Caption         =   "Tracks"
      ForeColor       =   &H00000000&
      Height          =   4755
      Left            =   60
      TabIndex        =   13
      Top             =   540
      Width           =   3195
      Begin ListBox TrackList
         Height          =   2955
         Left            =   120
         TabIndex        =   17
         Top             =   300
         Width           =   2955
      End
      Begin CommandButton CmdInsertTrack
         Caption         =   "Insert New Track"
         Height          =   435
         Left            =   120
         TabIndex        =   16
         Top             =   4260
         Width           =   2955
      End
      Begin CommandButton CmdDeleteTrack
         Caption         =   "Delete Current Track"
         Height          =   435
         Left            =   120
         TabIndex        =   15
         Top             =   3780
         Width           =   2955
      End
      Begin CommandButton CmdQueueTrack
         Caption         =   "Queue Current Track"
         Height          =   435
         Left            =   120
         TabIndex        =   14
         Top             =   3300
         Width           =   2955
      End
   End
   Begin MIDIOutput MIDIOutput1
      DeviceID        =   0
      Left            =   2280
      Top             =   5340
      VolumeLeft      =   0
      VolumeRight     =   0
   End
   Begin CommonDialog CMDialog1
      CancelError     =   -1  'True
      DefaultExt      =   "mid"
      DialogTitle     =   "Open MIDI File"
      Filter          =   "(*.mid) MIDI files|*.mid|"
      Left            =   2700
      Top             =   5340
   End
   Begin Frame Frame1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Messages"
      Height          =   4755
      Left            =   3300
      TabIndex        =   4
      Top             =   540
      Width           =   3675
      Begin PictureBox Picture2
         BackColor       =   &H00C0C0C0&
         BorderStyle     =   0  'None
         Height          =   1875
         Left            =   120
         ScaleHeight     =   1875
         ScaleWidth      =   3495
         TabIndex        =   23
         Top             =   2820
         Width           =   3495
         Begin TextBox MessageEdit
            Height          =   285
            Left            =   1020
            TabIndex        =   29
            Top             =   60
            Width           =   555
         End
         Begin TextBox Data1Edit
            Height          =   285
            Left            =   1020
            TabIndex        =   28
            Top             =   420
            Width           =   555
         End
         Begin TextBox Data2Edit
            Height          =   285
            Left            =   2700
            TabIndex        =   27
            Top             =   420
            Width           =   555
         End
         Begin TextBox TimeEdit
            Height          =   285
            Left            =   1020
            TabIndex        =   26
            Top             =   780
            Width           =   1035
         End
         Begin TextBox BufferEdit
            Height          =   285
            Left            =   1020
            TabIndex        =   25
            Top             =   1140
            Width           =   2415
         End
         Begin TextBox MsgTextEdit
            Height          =   285
            Left            =   1020
            TabIndex        =   24
            Top             =   1500
            Width           =   2415
         End
         Begin Label Label1
            Alignment       =   1  'Right Justify
            BackColor       =   &H00C0C0C0&
            Caption         =   "Message:"
            Height          =   255
            Left            =   60
            TabIndex        =   6
            Top             =   60
            Width           =   855
         End
         Begin Label Label2
            Alignment       =   1  'Right Justify
            BackColor       =   &H00C0C0C0&
            Caption         =   "Data1:"
            Height          =   255
            Left            =   60
            TabIndex        =   7
            Top             =   420
            Width           =   855
         End
         Begin Label Label3
            Alignment       =   1  'Right Justify
            BackColor       =   &H00C0C0C0&
            Caption         =   "Data2:"
            Height          =   255
            Left            =   1740
            TabIndex        =   8
            Top             =   420
            Width           =   855
         End
         Begin Label Label4
            Alignment       =   1  'Right Justify
            BackColor       =   &H00C0C0C0&
            Caption         =   "Buffer:"
            Height          =   255
            Left            =   60
            TabIndex        =   9
            Top             =   1140
            Width           =   855
         End
         Begin Label Label5
            Alignment       =   1  'Right Justify
            BackColor       =   &H00C0C0C0&
            Caption         =   "Time:"
            Height          =   255
            Left            =   60
            TabIndex        =   10
            Top             =   780
            Width           =   855
         End
         Begin Label Label6
            BackColor       =   &H00C0C0C0&
            Caption         =   "MsgText:"
            Height          =   255
            Left            =   120
            TabIndex        =   11
            Top             =   1500
            Width           =   795
         End
      End
      Begin CheckBox InsertRecordingCheck
         BackColor       =   &H00C0C0C0&
         Caption         =   "Insert Recording"
         Height          =   255
         Left            =   1620
         TabIndex        =   21
         Top             =   2520
         Width           =   1755
      End
      Begin CommandButton CmdDeleteMessage
         Caption         =   "Delete"
         Height          =   315
         Left            =   2700
         TabIndex        =   0
         Top             =   2160
         Width           =   855
      End
      Begin CommandButton CmdInsertMessage
         Caption         =   "Insert"
         Height          =   315
         Left            =   1440
         TabIndex        =   1
         Top             =   2160
         Width           =   855
      End
      Begin CommandButton CmdModifyMessage
         Caption         =   "Modify"
         Height          =   315
         Left            =   120
         TabIndex        =   2
         Top             =   2160
         Width           =   855
      End
      Begin CheckBox HexCheck
         BackColor       =   &H00C0C0C0&
         Caption         =   "Hexadecimal"
         Height          =   255
         Left            =   180
         TabIndex        =   3
         Top             =   2520
         Value           =   1  'Checked
         Width           =   1455
      End
      Begin ListBox MessageList
         Height          =   1785
         Left            =   120
         TabIndex        =   5
         Top             =   300
         Width           =   3435
      End
   End
   Begin Menu FileMenu
      Caption         =   "&File"
      Begin Menu FileNew
         Caption         =   "&New"
         Shortcut        =   ^N
      End
      Begin Menu FileOpen
         Caption         =   "&Open..."
         Shortcut        =   ^O
      End
      Begin Menu FileSep1
         Caption         =   "-"
      End
      Begin Menu FileSave
         Caption         =   "&Save"
         Shortcut        =   ^S
      End
      Begin Menu FileSaveAs
         Caption         =   "Save &As..."
      End
      Begin Menu FileSep2
         Caption         =   "-"
      End
      Begin Menu FileExit
         Caption         =   "E&xit"
      End
   End
End
Option Explicit

Dim lVolume As Integer
Dim rVolume As Integer


Dim msPerTick(50) As Long
Dim ticksPerMs(50) As Long

Dim fModified As Integer
Dim fGotFirst As Integer
Dim fRecording As Integer

Dim CurrentTime As Double
Dim PreviousTime As Double
Dim InCurrentTime As Double
Dim InPreviousTime As Double

Dim TempoTime(50) As Long

Dim TempoSetting(50) As Long
Dim TotalTempoChanges As Integer

Dim Lyric(1000) As String

Sub CloseInputDevice ()
    '
    ' Close if open
    '
    If MIDIInput1.State >= MIDISTATE_OPEN Then
        MIDIInput1.Action = MIDIIN_CLOSE
    End If
End Sub

Sub CloseOutputDevice ()
    '
    ' Restore volume before closing
    '
    If MIDIOutput1.State >= MIDISTATE_OPEN Then
        If (MIDIOutput1.HasLRVolume) Then
            MIDIOutput1.VolumeLeft = lVolume
            MIDIOutput1.VolumeRight = rVolume
        ElseIf (MIDIOutput1.HasVolume) Then
            MIDIOutput1.VolumeLeft = lVolume
        End If
        '
        ' Close
        '
        MIDIOutput1.Action = MIDIOUT_CLOSE
    End If
End Sub

Sub CmdDeleteMessage_Click ()
    MIDIFile1.Action = MIDIFILE_DELETE_MESSAGE
    fModified = True
    DisplayTrack (TrackList.ListIndex + 1)
End Sub

Sub CmdDeleteTrack_Click ()
    Dim t As Integer

    MIDIFile1.TrackNumber = TrackList.ListIndex + 1
    MIDIFile1.Action = MIDIFILE_DELETE_TRACK
    fModified = True
    t = TrackList.ListIndex
    DisplayTrackList
    If (t > TrackList.ListCount - 1) Then
        t = t - 1
    End If
    TrackList.ListIndex = t
End Sub

Sub CmdInsertMessage_Click ()
    MIDIFile1.Message = FetchNumber(CStr(MessageEdit.Text))
    MIDIFile1.Data1 = FetchNumber(CStr(Data1Edit.Text))
    MIDIFile1.Data2 = FetchNumber(CStr(Data2Edit.Text))
    MIDIFile1.Time = FetchNumber(CStr(TimeEdit.Text))
    MIDIFile1.Action = MIDIFILE_INSERT_MESSAGE
    fModified = True
    DisplayTrack (TrackList.ListIndex + 1)
End Sub

Sub CmdInsertTrack_Click ()
    Dim t As Integer

    MIDIFile1.TrackNumber = TrackList.ListIndex + 1
    MIDIFile1.Action = MIDIFILE_INSERT_TRACK
    fModified = True
    t = TrackList.ListIndex
    DisplayTrackList
    TrackList.ListIndex = t + 1
End Sub

Sub CmdModifyMessage_Click ()
    Dim m As Integer

    MIDIFile1.Message = FetchNumber(CStr(MessageEdit.Text))
    MIDIFile1.Data1 = FetchNumber(CStr(Data1Edit.Text))
    MIDIFile1.Data2 = FetchNumber(CStr(Data2Edit.Text))
    MIDIFile1.Time = FetchNumber(CStr(TimeEdit.Text))
    MIDIFile1.Buffer = BufferEdit.Text
    MIDIFile1.MsgText = MsgTextEdit.Text
    MIDIFile1.Action = MIDIFILE_MODIFY_MESSAGE
    m = MIDIFile1.MessageNumber
    fModified = True
    DisplayTrack (TrackList.ListIndex + 1)
    If (m > MIDIFile1.MessageCount) Then
        m = m - 1
    End If
    MessageList.ListIndex = m
End Sub

Sub CmdPlay_Click ()
    StartPlay
End Sub

Sub CmdQueueTrack_Click ()
    QueueTrack (TrackList.ListIndex + 1)
    On Error Resume Next
    TrackList.ListIndex = TrackList.ListIndex + 1
    On Error GoTo 0
End Sub

Sub CmdRecord_Click ()
    InsertRecordingCheck.Value = 1
    StartPlay
    StartRecording
End Sub

Sub CmdStop_Click ()
    StopPlay
    StopRecording
End Sub

Sub DisplayTrack (t As Integer)
    Dim i As Integer

    Screen.MousePointer = 11
    MessageList.Clear
    MIDIFile1.TrackNumber = t
    For i = 1 To MIDIFile1.MessageCount
        If (i > 500) Then
            Exit For
        End If
        MIDIFile1.MessageNumber = i

        '
        'Meta Event
        '
        If (MIDIFile1.Message = 255) Then
            Select Case MIDIFile1.Data1
                Case 0 'Sequence number
                    MessageList.AddItem "Sequence number " & Hex$(MIDIFile1.Data2) & " : " & MIDIFile1.MsgText
                Case 1 'Text
                    MessageList.AddItem "Text " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case 2 'Copyright
                    MessageList.AddItem "Copyright " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case 3 'track name
                    MessageList.AddItem "Track Name " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case 4 'instrument name
                    MessageList.AddItem "Instrument Name " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case 5 'Lyric
                    MessageList.AddItem "Lyric " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case 6 'Marker
                    MessageList.AddItem "Marker " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
                Case 7 'Cue point
                    MessageList.AddItem "Cue point " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
'                Case &H51 '81
                    MessageList.AddItem Str(MIDIFile1.Time) & " Tempo " & Int(60000000 / MIDIFile1.Tempo)
'                    Label4.Caption = Int(60000000 / MIDIFile1.Tempo)
'                    HSliderTempo.Value = Int(60000000 / MIDIFile1.Tempo)
'                Case &H58 '88
                    MessageList.AddItem Str(MIDIFile1.Time) & " Time Signature " & MIDIFile1.Numerator + "/" & (MIDIFile1.Denominator ^ 2)
'                    lblTimeSig.Caption = MIDIFile1.Numerator & "/" & MIDIFile1.Denominator ^ 2
                Case Else
                    MessageList.AddItem "Sysex " & Hex$(MIDIFile1.Data1)
            End Select
        Else
            MessageList.AddItem Hex$(MIDIFile1.Message)
        End If
    Next
    Screen.MousePointer = 0
End Sub

Sub DisplayTrackList ()
    Dim m As Integer
    Dim t As Integer

    TrackList.Clear
    For t = 1 To MIDIFile1.NumberOfTracks
        TrackList.AddItem GetTrackName(t)
    Next

    GetTempoChanges
    GetTimeSignature
End Sub

Function FetchNumber (s As String) As Integer
    If (HexCheck.Value) Then
        FetchNumber = Val("&H" & s)
    Else
        FetchNumber = Val(s)
    End If
End Function

Sub FileExit_Click ()
    If (OkToExit()) Then
        End
    End If
End Sub

Sub FileNew_Click ()
    Dim wRtn As Integer
    Dim ts As Variant

    If (fModified) Then
        wRtn = MsgBox("Discard changes to current file?", 36)
        If (wRtn <> 6) Then
            Exit Sub
        End If
    End If
    MIDIFile1.Filename = "Untitled.mid"
    Form1.Caption = "Untitled.mid"
    On Error Resume Next
    ts = FileDateTime("Untitled.mid")
    wRtn = Err
    On Error GoTo 0
    If (wRtn = 0) Then
        wRtn = MsgBox("Untitled.mid already exists, do you want to recreate it?", 36)
        If (wRtn = 6) Then
            Kill "Untitled.mid"
            wRtn = 1
        Else
            wRtn = 0
        End If
    Else
        wRtn = 1
    End If
    If (wRtn) Then
        MIDIFile1.Action = MIDIFILE_CREATE
        MIDIFile1.Action = MIDIFILE_SAVE
    Else
        MIDIFile1.Action = MIDIFILE_OPEN
    End If
    DisplayTrackList
    TrackList.ListIndex = 0
    fModified = 0
End Sub

Sub FileOpen_Click ()
    On Error Resume Next
    CMDialog1.DialogTitle = "Open MIDI File"
    CMDialog1.Flags = &H1000&
    CMDialog1.Action = 1
    If (Err) Then
        Exit Sub
    End If
    MIDIFile1.Filename = CMDialog1.Filename
    MIDIFile1.Action = MIDIFILE_OPEN
    DisplayTrackList
    TrackList.ListIndex = 1
    fModified = 0
End Sub

Sub FileSave_Click ()
    MIDIFile1.Action = MIDIFILE_SAVE
End Sub

Sub FileSaveAs_Click ()
    If (SaveAs()) Then
        Form1.Caption = CMDialog1.Filename
    End If
End Sub

Sub Form_Load ()
    Dim i As Integer

    '
    ' Fill output device combo box
    '
    For i = -1 To MIDIOutput1.DeviceCount - 1
        MIDIOutput1.DeviceID = i
        OutputDevCombo.AddItem MIDIOutput1.ProductName
    Next
    '
    ' Select first in list
    '
    MIDIOutput1.DeviceID = -1
    OutputDevCombo.ListIndex = 0
    '
    ' Fill input device combo box
    '
    For i = 0 To MIDIInput1.DeviceCount - 1
        MIDIInput1.DeviceID = i
        InputDevCombo.AddItem MIDIInput1.ProductName
    Next
    '
    ' Select first in list
    '
    MIDIInput1.DeviceID = -1
    InputDevCombo.ListIndex = 0
    fModified = 0
    Form1.Show
    HighLight Picture1, 1
    HighLight Picture2, 1
    HighLight Frame1, 1
    HighLight Frame2, 1
End Sub

Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
    If (OkToExit() <> True) Then
        Cancel = True
    End If
End Sub

Sub Form_Unload (Cancel As Integer)
    CloseOutputDevice
    CloseInputDevice
End Sub

Function FormatNumber (n As Long) As String
    If (HexCheck.Value) Then
        FormatNumber = Hex$(n)
    Else
        FormatNumber = Format(n)
    End If
End Function

Sub GetTempoChanges ()
    Dim m As Integer
    Dim TempoChangeCount As Integer
    Dim CurrentTime As Long

    Screen.MousePointer = 11

    TotalTempoChanges = 0

    MIDIFile1.TrackNumber = 1

    For m = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = m

        'Meta Tempo Event
        If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = &H51 Then
            'Keep track of the total number of tempo changes in this MIDI file
            TotalTempoChanges = TotalTempoChanges + 1

            'This is the tempo
            TempoSetting(TotalTempoChanges) = MIDIFile1.Tempo

            'Calculate msPerTick at this tempo -- this is used when playing back MIDI input
            msPerTick(TotalTempoChanges) = TempoSetting(TotalTempoChanges) / 1000 / MIDIFile1.TicksPerQuarterNote

            'Calculate ticksPerMs at this tempo -- this is used when recoding MIDI input
            ticksPerMs(TotalTempoChanges) = MIDIFile1.TicksPerQuarterNote / TempoSetting(TotalTempoChanges) * 1000

            TempoTime(TotalTempoChanges) = TempoTime(TotalTempoChanges - 1) + MIDIFile1.Time * msPerTick(TotalTempoChanges)

            'Display the first tempo
            LabelTempo.Caption = Int(60000000 / TempoSetting(1))
            'Display TickperQuarterNote
            LabelTicks.Caption = MIDIFile1.TicksPerQuarterNote
        End If
    Next
End Sub

Sub GetTimeSignature ()
    Dim m As Integer

    MIDIFile1.TrackNumber = 1

    For m = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = m

        'Meta Event Key Signature
        If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = &H58 Then
            LabelTimeSignature.Caption = MIDIFile1.Numerator & "/" & MIDIFile1.Denominator ^ 2
        End If
    Next
End Sub

Function GetTrackName (Track As Integer) As String
    Dim i As Integer

    MIDIFile1.TrackNumber = Track

    For i = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = i
        '
        'Meta Event
        '
        If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = 3 Then
            If (MIDIFile1.MsgText = "") Then
                GetTrackName = "Track" & Str(Track) & " (null)"
            Else
                GetTrackName = MIDIFile1.MsgText
            End If
            Exit Function
        End If
    Next
    GetTrackName = "Track" & Str(Track)
End Function

Sub InputDevCombo_Click ()
    '
    ' Stop and Close currently opened device (if any)
    '
    StopRecording
End Sub

Sub MessageList_Click ()
    MIDIFile1.MessageNumber = MessageList.ListIndex + 1
    TimeEdit.Text = FormatNumber(CLng(MIDIFile1.Time))
    MessageEdit.Text = FormatNumber(CLng(MIDIFile1.Message))
    Data1Edit.Text = FormatNumber(CLng(MIDIFile1.Data1))
    Data2Edit.Text = FormatNumber(CLng(MIDIFile1.Data2))
    BufferEdit.Text = MIDIFile1.Buffer
    MsgTextEdit.Text = MIDIFile1.MsgText

End Sub

Sub MIDIInput1_Message ()
    Dim InMessage As Integer
    Dim InData1 As Integer
    Dim InData2 As Integer
    Dim Y As Integer

    If (fGotFirst = False) Then
        InPreviousTime = MIDIInput1.Time
        fGotFirst = True
        fRecording = True
    End If
    '
    'This do while loop allows you to take all the messages that are
    'waiting in the message queue.
    '
    Do While MIDIInput1.MessageCount > 0
        '
        'This is the incoming MIDI data
        '
        InMessage = MIDIInput1.Message
        InData1 = MIDIInput1.Data1
        InData2 = MIDIInput1.Data2
        '
        ' Copy input to output?
        '
        If (MidiThruCheck.Value) Then
            '
            'Tell MIDIOutput1 to send the MIDI data
            '
            MIDIOutput1.Message = InMessage
            MIDIOutput1.Data1 = InData1
            MIDIOutput1.Data2 = InData2
            MIDIOutput1.Action = MIDIOUT_SEND
        End If

        If (InsertRecordingCheck.Value) And InMessage < 254 Then

            ' Copy message parameters
            MIDIFile1.Message = InMessage
            MIDIFile1.Data1 = InData1
            MIDIFile1.Data2 = InData2

            ' Calculate time in ticks
            InCurrentTime = MIDIInput1.Time
            MIDIFile1.Time = (InCurrentTime - InPreviousTime) * msPerTick(1)
            InPreviousTime = InCurrentTime

            ' insert message into MIDI file
            MIDIFile1.Action = MIDIFILE_INSERT_MESSAGE
        End If
        '
        'Remove the MIDI data from the MIDI IN queue
        '
        MIDIInput1.Action = MIDIIN_REMOVE
    Loop
End Sub

Sub MIDIOutput1_Error (ErrorCode As Integer, ErrorMessage As String)
    MsgBox ErrorMessage
End Sub

Sub MIDIOutput1_MessageSent (MessageTag As Long)
    LabelTempo.Caption = Str$(Int(60000000 / TempoSetting(MessageTag)))
End Sub

Sub MIDIOutput1_QueueEmpty ()
    StopPlay
End Sub

Function OkToExit () As Integer
    Dim wRtn As Integer

    If (fModified) Then
        wRtn = MsgBox("Save file before exiting?", 36)
        If (wRtn = 6) Then
            If (MIDIFile1.Filename = "Untitled.mid") Then
                If (SaveAs() = False) Then
                   OkToExit = False
                   Exit Function
                End If
            Else
                MIDIFile1.Action = MIDIFILE_SAVE
            End If
        End If
    End If
    OkToExit = True
End Function

Sub OpenInputDevice ()
    MIDIInput1.DeviceID = InputDevCombo.ListIndex
    MIDIInput1.Action = MIDIIN_OPEN
End Sub

Sub OpenOutputDevice ()
    '
    ' Restore defaults
    '
    PlaybackRateSlider = 0
    '
    ' Open selected device
    '
    MIDIOutput1.DeviceID = OutputDevCombo.ListIndex - 1
    MIDIOutput1.Action = MIDIOUT_OPEN
    '
    ' Save volume if opened ok
    '
    If (MIDIOutput1.HMidiDevice <> 0) Then
        '
        ' If device supports volume, save starting volume
        '
        If (MIDIOutput1.HasLRVolume) Then
            lVolume = MIDIOutput1.VolumeLeft
            rVolume = MIDIOutput1.VolumeRight
        ElseIf (MIDIOutput1.HasVolume) Then
            lVolume = MIDIOutput1.VolumeLeft
        End If
    End If
End Sub

Sub OutputDevCombo_Click ()
    '
    ' Stop and Close currently opened device (if any)
    '
    StopPlay
End Sub

Sub QueueTrack (Track As Integer)
    Dim m As Integer
    Dim n As Integer
    Dim i As Double
    Dim TempoChangeCount As Integer
    Dim msTickTime As Integer
    Dim TimerTagCount As Integer

    PreviousTime = 0
    CurrentTime = 0
    TimerTagCount = 0

    Screen.MousePointer = 11

    TempoChangeCount = 1

    MIDIFile1.TrackNumber = Track

    For m = 1 To MIDIFile1.MessageCount
        MIDIFile1.MessageNumber = m

        'Meta Event
        If (MIDIFile1.Message <> 255) Then
            'PreviousTime is = to the total ms into the song for this track
            '
            'Int(MIDIFile1.Time * msPerTick(TempoChangeCount)) is = to the total ms
            'that need to pass before playing the next event
            '
            CurrentTime = PreviousTime + MIDIFile1.Time * msPerTick(TempoChangeCount)

            'if the time value of TempoTime(TempoChangeCount) is less than or equal
            'to the current time, a tempo change is needed.
            '
            'Note that msPerTick() is set in Sub GetTempoChanges () at the time a new MIDI
            'file is loaded.
            If TotalTempoChanges > TempoChangeCount And TempoTime(TempoChangeCount) <= CurrentTime Then

                'Use MessageTag property in MIDIOutput1 fire an event at the time the
                'tempo changes so that we can change the LabelTempo.Caption.
                '
                'See: Sub MIDIOutput1_MessageSent for actual updating of LabelTempo.Caption
                MIDIOutput1.MessageTag = TempoChangeCount
                TempoChangeCount = TempoChangeCount + 1
            End If

            'Time in ms to send this event
            MIDIOutput1.Time = CurrentTime

            'Keep track of the CurrentTime for the next event we queue
            PreviousTime = CurrentTime

            ' Put message data in control
            MIDIOutput1.Message = MIDIFile1.Message
            MIDIOutput1.Data1 = MIDIFile1.Data1
            MIDIOutput1.Data2 = MIDIFile1.Data2

            ' Add to output queue
            MIDIOutput1.Action = MIDIOUT_QUEUE
        End If
    DoEvents
    Next
    Screen.MousePointer = 0
End Sub

Function SaveAs () As Integer
    CMDialog1.DialogTitle = "Save MIDI File As"
    On Error Resume Next
    CMDialog1.Flags = &H2&
    CMDialog1.Action = 2
    If (Err) Then
        SaveAs = False
        Exit Function
    End If
    On Error GoTo 0
    MIDIFile1.Filename = CMDialog1.Filename
    MIDIFile1.Action = MIDIFILE_SAVE_AS
    SaveAs = True
End Function

Sub StartPlay ()
    OpenOutputDevice
    MIDIOutput1.Action = MIDIOUT_START
    CmdPlay.Enabled = False
    CmdRecord.Enabled = False
    CmdStop.Enabled = True
End Sub

Sub StartRecording ()
    OpenInputDevice

    MIDIInput1.Action = MIDIIN_START
    'InPreviousTime = MIDIInput1.Time

    CmdPlay.Enabled = False
    CmdRecord.Enabled = False
    CmdStop.Enabled = True
    fGotFirst = False
End Sub

Sub StopPlay ()
    MIDIOutput1.Action = MIDIOUT_STOP
    CloseOutputDevice
    CmdPlay.Enabled = True
    CmdRecord.Enabled = True
    CmdStop.Enabled = False
End Sub

Sub StopRecording ()
    MIDIInput1.Action = MIDIIN_STOP
    CloseInputDevice
    If (MidiThruCheck) Then
        CloseOutputDevice
    End If
    CmdPlay.Enabled = True
    CmdRecord.Enabled = True
    CmdStop.Enabled = False
    fRecording = False
    If (InsertRecordingCheck) Then
        DisplayTrack (TrackList.ListIndex + 1)
    End If
End Sub

Sub TrackList_Click ()
    DisplayTrack (TrackList.ListIndex + 1)
End Sub