www.pudn.com > midi_drum.zip > FrmSong.frm
VERSION 5.00
Begin VB.Form FrmSong
BorderStyle = 1 'Fixed Single
ClientHeight = 3615
ClientLeft = 1935
ClientTop = 1635
ClientWidth = 5400
Icon = "FrmSong.frx":0000
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
NegotiateMenus = 0 'False
ScaleHeight = 241
ScaleMode = 3 'Pixel
ScaleWidth = 360
ShowInTaskbar = 0 'False
Begin VB.Frame Fra2
Height = 1485
Left = 3645
TabIndex = 11
Top = 2010
Width = 1635
Begin VB.CheckBox ChkLoop
Caption = "&Loop Song"
Height = 195
Left = 165
OLEDropMode = 1 'Manual
TabIndex = 3
Top = 255
Width = 1080
End
Begin VB.CommandButton CmdSongStop
Caption = "&Stop"
Enabled = 0 'False
Height = 375
Left = 165
OLEDropMode = 1 'Manual
TabIndex = 5
Top = 945
Width = 1305
End
Begin VB.CommandButton CmdSongRun
Caption = "&Play"
Height = 375
Left = 165
OLEDropMode = 1 'Manual
TabIndex = 4
Top = 585
Width = 1305
End
End
Begin VB.Frame Fra1
Height = 1905
Left = 3645
TabIndex = 7
Top = 30
Width = 1635
Begin VB.CommandButton CmdDelete
Caption = "&Delete"
Height = 375
Left = 165
OLEDropMode = 1 'Manual
TabIndex = 2
Top = 1365
Width = 1305
End
Begin VB.CommandButton CmdReplace
Caption = "&Replace"
Height = 375
Left = 165
OLEDropMode = 1 'Manual
TabIndex = 1
Top = 1005
Width = 1305
End
Begin VB.CommandButton CmdAdd
Caption = "&Add"
Height = 375
Left = 165
OLEDropMode = 1 'Manual
TabIndex = 0
Top = 645
Width = 1305
End
Begin VB.VScrollBar VsbSongPtrn
Height = 195
Left = 1200
Max = 1
Min = 100
TabIndex = 8
TabStop = 0 'False
Top = 285
Value = 1
Width = 240
End
Begin VB.Label Lbl
Appearance = 0 'Flat
AutoSize = -1 'True
Caption = "Pattern:"
Height = 195
Index = 2
Left = 165
LinkTimeout = 0
TabIndex = 10
Top = 285
Width = 555
End
Begin VB.Label LblSongPtrn
BackColor = &H00000000&
BorderStyle = 1 'Fixed Single
Caption = "001"
ForeColor = &H00FFFF00&
Height = 255
Left = 840
LinkTimeout = 0
OLEDropMode = 1 'Manual
TabIndex = 9
Top = 255
Width = 630
End
End
Begin VB.ListBox LstSong
BackColor = &H00000000&
ForeColor = &H00FFFF00&
Height = 3375
ItemData = "FrmSong.frx":000C
Left = 120
List = "FrmSong.frx":000E
OLEDropMode = 1 'Manual
TabIndex = 6
Top = 120
Width = 3390
End
End
Attribute VB_Name = "FrmSong"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Author: Stuart Pennington.
' Project: Midi Percussion Sequencer (Drum Machine).
' Test Platform: Windows 98SE
' Processor: P2 300MHz.
Private bSongPlaying As Boolean
Private Sub Form_Load()
Dim C%
Icon = FrmMicroKit.Icon
Caption = "MicroKit - Song Mode"
' Populate The List Box With Song Data (If There Is Any).
For C = 0 To 99
If Song(C) > 0 Then
LstSong.AddItem "Part Number: " & Format(C + 1, "000") & " ---> Pattern Number: " & Format(Song(C), "000")
End If
Next
' Did The User Want The Song To Loop?
ChkLoop.Value = Abs(bLoopSong)
' Position Form.
PositionForm Me
End Sub
Private Sub CmdSongRun_Click()
' If The List Box Is Empty Then There's Nothing To Play.
If LstSong.ListCount = 0 Then
Beep
Exit Sub
End If
' Update Interface.
CmdSongRun.Enabled = 0
CmdSongStop.Enabled = 1
CmdSongStop.SetFocus
VsbSongPtrn.Enabled = 0
CmdAdd.Enabled = 0
CmdReplace.Enabled = 0
CmdDelete.Enabled = 0
DoEvents
' Indicate That SONG Is Playing.
bSongPlaying = True
' Initialize Song Monitor Variables.
SongStartPos = (Song(0) - 1) * 16
SongEndPos = SongStartPos + 15
SongPos = SongStartPos
SongPtr = 0
' Create High Res (Multi Media) Timer To Do The Sequencing.
TimerID = timeSetEvent(NewTempo, BestResolution, AddressOf SongProc, 0, 1)
' We Are Now Sequencing The Song Patterns.
End Sub
Public Sub CmdSongStop_Click()
' Kill High Res Timer.
timeKillEvent TimerID
' Return Timer ID To Zero.
TimerID = 0
' Silence Any Midi Note That May Have "Stuck".
midiOutReset hMidiOut
' Indicate That The Song Is Nolonger Playing.
bSongPlaying = False
' Update Interface.
VsbSongPtrn.Enabled = 1
CmdAdd.Enabled = 1
CmdReplace.Enabled = 1
CmdDelete.Enabled = 1
CmdSongStop.Enabled = 0
CmdSongRun.Enabled = 1
CmdSongRun.SetFocus
DoEvents
End Sub
Private Sub CmdAdd_Click()
' Purpose: Adds A Pattern Number To The List Box And
' Updates The Song Playback Array.
Dim Msg$
With LstSong
If .ListCount = 100 Then
Msg = "Sorry, A maximum of 100 entries has been reached."
MsgBox Msg, vbExclamation, "MicroKit - Error"
Exit Sub
End If
.AddItem "Part Number: " & Format(.ListCount + 1, "000") & " ---> Pattern Number: " & LblSongPtrn.Caption
.Selected(.ListCount - 1) = True
End With
UpdateSongArray
End Sub
Private Sub UpdateSongArray()
' Purpose: Updates The Song PlayBack Array.
Dim K%
Erase Song
For K = 0 To LstSong.ListCount - 1
Song(K) = Val(Right(LstSong.List(K), 3)) ' Fill It With The Pattern Number's.
Next
' Data Has Changed.
bDirty = True
End Sub
Private Sub CmdReplace_Click()
' Purpose: Allows A User To Change Any Pattern Number For Another
' Anywhere In The List Box And Updates The Song Playback Array.
With LstSong
' If The List Box Is Empty There's Nothing To Do.
If .ListCount = 0 Or .Text = "" Then
Beep
Exit Sub
End If
' Replace The Pattern Number For The New Number Yhe User Has Chosen.
.List(.ListIndex) = "Part Number: " & Format(.ListIndex + 1, "000") & " ---> Pattern Number: " & LblSongPtrn.Caption
End With
UpdateSongArray
End Sub
Private Sub CmdDelete_Click()
' Purpose: Removes A Pattern From The List Box And Resorts It's Content's.
Dim K%, S%, E%
With LstSong
If .ListCount = 0 Or .Text = "" Then
Beep
Exit Sub
End If
S = .ListIndex + 1
E = .ListCount
If S < E Then
S = S - 1
E = E - 1
For K = S To E
.List(K) = Left(.List(K), 22) & Right(.List(K + 1), 19)
Next
End If
.RemoveItem .ListCount - 1
End With
' Update Song Play Back Array.
UpdateSongArray
End Sub
Private Sub VsbSongPtrn_Change()
LblSongPtrn.Caption = Format(VsbSongPtrn.Value, "000")
End Sub
Private Sub ChkLoop_Click()
' Toggle Song Looping.
bLoopSong = CBool(ChkLoop.Value)
bDirty = True
End Sub
Private Sub Form_Unload(Cancel%)
If bSongPlaying Then CmdSongStop_Click
End Sub