LISTING PROGRAM

1. FORM PIANO Private Declare Sub ReleaseCapture Lib "user32" () Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hrgn As Long, ByVal bRedraw As Boolean) As Long

Dim KeyState(0 To 255) As Byte Dim KeyState1(0 To 255) As Byte Dim LastKey As Integer Dim Keys Dim DrumKeys Dim Drums

Dim Banks(0 To 4) As Integer Dim BaseKey As Integer

Dim InstrSelect As Integer Dim DrumSelect As Integer Dim Volume As Integer Dim Record As Boolean

Dim BeatSelect As Integer

Universitas Sumatera Utara

Dim BeatPtr As Integer Dim BeatMode As Integer Dim BeatNext As Integer

Private Sub Command1_Click()

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If LastKey KeyCode Then LastKey = KeyCode If KeyCode >= vbKeyF1 And KeyCode = vbKeyF5 And KeyCode 0 Then Load mnuBeat(i) mnuBeat(i).Caption = Beats(i).Name Next mnuBeat_Click 0 BeatMode = -1 BeatNext = -2

'load instrument Open App.Path & "\instrument.txt" For Input As #1

Universitas Sumatera Utara

For i = 0 To 127 Line Input #1, S t = Split(S, vbTab) If i > 0 Then Load mnuPiano(i) mnuPiano(i).Caption = t(1) Next Line Input #1, S For i = 35 To 66 Line Input #1, S t = Split(S, vbTab) If i > 35 Then Load mnuDrum(i - 35) mnuDrum(i - 35).Caption = t(1) Next Close #1 Volume = 127 mnuPiano_Click Banks(0) End Sub

Private Sub Form_Unload(Cancel As Integer) MidiClose

'save config On Error GoTo SkipSaveConfig Open App.Path & "\config.dat" For Output As #1 Print #1, DeviceID Print #1, Banks(0), Banks(1), Banks(2), Banks(3)

Universitas Sumatera Utara

Print #1, Drums(0), Drums(1), Drums(2), Drums(3), Drums(4), Drums(5), Drums(6), Drums(7), Drums(8), Drums(9), Drums(10), Drums(11) Close #1

SkipSaveConfig: End Sub

Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) FormDrag Me End Sub

Private Sub lblBank_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) lblBank(Index).BackColor = vbYellow If Button = vbRightButton Then mnuMain(0).Tag = CStr(Index) PopupMenu mnuMain(0) mnuMain(0).Tag = "" lblBank(Index).BackColor = &H808080 Else mnuPiano_Click Banks(Index) End If End Sub

Private Sub lblBank_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) lblBank(Index).BackColor = &H808080 End Sub

Universitas Sumatera Utara

Private Sub lblBaseKey_Click() PopupMenu mnuMain(4) End Sub

Private Sub lblBeat_Click() lblBeat.BackColor = vbYellow PopupMenu mnuMain(2) lblBeat.BackColor = &H808080 End Sub

Private Sub lblBeatCtrl_Click(Index As Integer) Select Case Index Case 0: BeatNext = 0 Case 1: BeatNext = 2 Case 2: BeatNext = 3 Case 3: BeatNext = 4 Case 4: BeatNext = -1 End Select If Index < 4 And BeatMode < 0 Then BeatMode = BeatNext: BeatNext = -2 End Sub

Private Sub lblBeatCtrl_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) lblBeatCtrl(Index).BackColor = vbYellow End Sub

Private Sub lblBeatCtrl_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) lblBeatCtrl(Index).BackColor = &H808080

Universitas Sumatera Utara

End Sub

Private Sub lblDevice_Click() lblDevice.ForeColor = vbYellow PopupMenu mnuMain(3) lblDevice.ForeColor = &HC0C0C0 End Sub

Private Sub lblDrums_Click(Index As Integer) DrumSelect = Index PopupMenu mnuMain(1) End Sub

Private Sub lblExit_Click() Unload Me End Sub

Private Sub lblInstrument_Click() lblInstrument.BackColor = vbYellow PopupMenu mnuMain(0) lblInstrument.BackColor = &H808080 End Sub

Private Sub lblRate_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) lblRate.Tag = "1" lblRate_MouseMove Button, Shift, X, Y End Sub

Universitas Sumatera Utara

Private Sub lblRate_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If lblRate.Tag = "1" Then Y = Y - lblRatePtr.Height / 2 If Y < 0 Then Y = 0 If Y > lblRate.Height - lblRatePtr.Height Then Y = lblRate.Height - lblRatePtr.Height lblRatePtr.Top = lblRate.Top + Y tmrBeat.Interval = 100 * (Y / (lblRate.Height lblRatePtr.Height)) + Val(lblRatePtr.Tag) End If End Sub

Private Sub lblRate_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) lblRate.Tag = "0" End Sub

Private Sub lblVolume_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If lblVolume.Tag = "1" Then X = X - lblVolumePtr.Width / 2 If X < 0 Then X = 0 If X > lblVolume.Width - lblVolumePtr.Width Then X = lblVolume.Width - lblVolumePtr.Width lblVolumePtr.Left = lblVolume.Left + X Volume = 127 * (X / (lblVolume.Width lblVolumePtr.Width)) End If End Sub

Universitas Sumatera Utara

Private Sub lblVolume_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) lblVolume.Tag = "1" lblVolume_MouseMove Button, Shift, X, Y End Sub

Private Sub lblVolume_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) lblVolume.Tag = "0" End Sub

Private Sub mnuBaseKey_Click(Index As Integer) BaseKey = Index lblBaseKey = mnuBaseKey(Index).Caption MidiClose MidiOpen End Sub

Private Sub mnuBeat_Click(Index As Integer) BeatSelect = Index BeatPtr = 0 BeatMode = 0 lblBeat.Caption = mnuBeat(Index).Caption lblRatePtr.Tag = CStr(Beats(Index).Rate) tmrBeat.Interval = Beats(Index).Rate End Sub

Private Sub mnuDevice_Click(Index As Integer) MidiClose DeviceID = Index

Universitas Sumatera Utara

MidiOpen mnuPiano_Click InstrSelect End Sub

Private Sub mnuDrum_Click(Index As Integer) Drums(DrumSelect) = Index + 35 End Sub

Private Sub mnuPiano_Click(Index As Integer) InstrSelect = Index If mnuMain(0).Tag "" Then Banks(Val(mnuMain(0).Tag)) = Index

ChangeInstrument 0, Index lblInstrument.Caption = mnuPiano(Index).Caption End Sub

Public Sub CheckKeys() For i = 0 To UBound(Keys) N = Keys(i) If KeyState(N) KeyState1(N) Then KeyState(N) = KeyState1(N) Debug.Print N, KeyState(N) If KeyState(N) = 1 Then shpKeys(i).BackColor = IIf(shpKeys(i).Height < 500, RGB(100, 100, 100), RGB(200, 200, 200)) StartNote 0, i + BaseKey + 48, Volume Else If shpKeys(i).Height < 500 Then

Universitas Sumatera Utara

shpKeys(i).BackColor = vbBlack Else shpKeys(i).BackColor = vbWhite End If StopNote 0, i + BaseKey + 48 End If End If Next

For i = 0 To UBound(DrumKeys) N = DrumKeys(i) If KeyState(N) KeyState1(N) Then KeyState(N) = KeyState1(N) If KeyState(N) = 1 Then shpDrums(i).BackColor = &H808080 StartNote 9, Drums(i), 127 Else shpDrums(i).BackColor = &HC0C0C0 StopNote 9, Drums(i) End If End If Next End Sub

Public Sub FormDrag(TheForm As Form) ReleaseCapture Call SendMessage(TheForm.hwnd, &HA1, 2, 0&) End Sub

Universitas Sumatera Utara

Private Sub tmrBeat_Timer() If BeatMode >= 0 Then t = Beats(BeatSelect).Data t = Split(t, ";")(BeatMode) t = Split(t, "|") N = UBound(t) t = t(BeatPtr) t = Split(t, ",")

For i = 0 To UBound(t) StartNote 9, t(i), Volume Next BeatPtr = BeatPtr + 1 If BeatPtr > N Then If BeatNext < -1 Then Select Case BeatMode Case 0, 2, 3: BeatMode = 1 Case 4: BeatMode = -1 End Select Else BeatMode = BeatNext BeatNext = -2 End If BeatPtr = 0 End If End If End Sub

2. Modul_1

Universitas Sumatera Utara

Public Type BeatData Name As String Rate As Integer Data As String End Type

Public Beats(2) As BeatData

Public Sub LoadBeat() Beats(1).Name = "Rock" Beats(1).Rate = 150 Beats(1).Data = "44,35,55||44||44,40||44|;" _ & "44,35||44,35||44,40||44||44,35||44||44,40||44|;" _ & "44,50,35|50|44,48,35|48|44,47,35|47|44,45,35|45|44,35,55 ||44||44,40||44|;" _ & "44,35||46||40,44||42|;" _ & "44||44||44||44,35,55"

Beats(2).Name = "16 Beat" Beats(2).Rate = 100 Beats(2).Data = "44|44|44|44|44|44|44|44;" _ & "44,35|44|44|44|44,40|44|44|44;" _ & "44,40|44,40|44,40|44,40|44,40|44,40|44,40|44,40|44,35,55 |44|44|44|44,40|44|44|44;" _ & "44,35|44|44|46|40|42|44|44;" _ & "44,35,55"

Beats(0).Name = "Disco" Beats(0).Rate = 170

Universitas Sumatera Utara

Beats(0).Data = "44,35,55|46|44,40,35|42;" _ & "44,35|46|44,40,35|42;" _ & "44,35|44,35,40|44,35,40|44,35,40|44,35,55|46|44,40,35|42 ;" _ & "44,35|44,40|44,40|44,35;" _ & "44,35,55"

'

Beats(0).Name = "Test"

'

Beats(0).Data = Array( _

'

Array(), _

'

Array(), _

'

Array(), _

'

Array(), _

'

Array() _

'

)

End Sub

3. Modul_3 Option Explicit Public Const MAXPNAMELEN = 32 ' Error values for functions used in this sample. See the function for more information Public Const MMSYSERR_BASE = 0 Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present

Universitas Sumatera Utara

Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation error

Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid Public Const MIDIERR_BASE = 64 Public Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still something playing Public Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware is still busy Public Const MIDIERR_BADOPENMODE = (MIDIERR_BASE + 6) ' operation unsupported w/ open mode

'User-defined variable the stores information about the MIDI output device. Type MIDIOUTCAPS wMid As Integer ' Manufacturer identifier of the device driver for the MIDI output device ' For a list of identifiers, see the Manufacturer Indentifier topic in the ' Multimedia Reference of the Platform SDK.

wPid As Integer ' Product Identifier Product of the MIDI output device. For a list of ' product identifiers, see the Product Identifiers topic in the Multimedia ' Reference of the Platform SDK.

vDriverVersion As Long ' Version number of the device driver for the MIDI output device.

Universitas Sumatera Utara

' The high-order byte is the major version number, and the low-order byte is ' the minor version number.

szPname As String * MAXPNAMELEN null-terminated string.

' Product name in a

wTechnology As Integer ' One of the following that describes the MIDI output device: '

MOD_FMSYNTH-

'

MOD_MAPPER-The

'

MOD_MIDIPORT-

The device is an FM synthesizer. device is the Microsoft MIDI mapper. The device is a MIDI hardware port. ' The device is a square wave synthesizer. '

MOD_SQSYNTHMOD_SYNTH-The

device is a synthesizer.

wVoices As Integer ' Number of voices supported by an internal synthesizer device. If the ' device is a port, this member is not meaningful and is set to 0.

wNotes As Integer ' Maximum number of simultaneous notes that can be played by an internal ' synthesizer device. If the device is a port, this member is not meaningful ' and is set to 0.

wChannelMask As Integer ' Channels that an internal synthesizer device responds to, where the least

Universitas Sumatera Utara

' significant bit refers to channel 0 and the most significant bit to channel ' 15. Port devices that transmit on all channels set this member to 0xFFFF.

dwSupport As Long ' One of the following describes the optional functionality supported by ' the device: ' MIDICAPS_CACHE-Supports patch caching. ' MIDICAPS_LRVOLUME-Supports separate left and right volume control. ' MIDICAPS_STREAM-Provides direct support for the midiStreamOut function. ' MIDICAPS_VOLUME-Supports volume control. ' ' If a device supports volume changes, the MIDICAPS_VOLUME flag will be set ' for the dwSupport member. If a device supports separate volume changes on ' the left and right channels, both the MIDICAPS_VOLUME and the ' MIDICAPS_LRVOLUME flags will be set for this member. End Type

Declare Function midiOutGetNumDevs Lib "winmm" () As Integer Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long

Universitas Sumatera Utara

Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long Public Declare Function GetTickCount Lib "kernel32" () As Long

Public hMidi As Long Public DeviceID As Long Dim rc As Long Dim midimsg As Long

Public Sub MidiOpen() rc = midiOutOpen(hMidi, DeviceID, 0, 0, 0) If rc 0 Then MsgBox "Open MIDI Out failed" End Sub

Public Sub MidiClose() rc = midiOutClose(hMidi) If rc 0 Then MsgBox "Close MIDI Out failed" End Sub

Public Sub StartNote(ByVal Channel As Integer, ByVal Index As Integer, ByVal Volume As Integer) midimsg = &H90 + (Index * &H100) + (Volume * &H10000) + Channel rc = midiOutShortMsg(hMidi, midimsg)

Universitas Sumatera Utara

End Sub

Public Sub StopNote(ByVal Channel As Integer, ByVal Index As Integer) midimsg = &H80 + (Index * &H100) + Channel midiOutShortMsg hMidi, midimsg End Sub

Public Sub ChangeInstrument(ByVal Channel As Integer, ByVal Inst As Integer) midiOutShortMsg hMidi, &HB0 + Channel midiOutShortMsg hMidi, 32 * &H100 + &HB0 + Channel midiOutShortMsg hMidi, Inst * &H100 + &HC0 + Channel End Sub

Public Sub Delay(S As Long) Dim N As Long N = GetTickCount + S Do DoEvents Loop Until GetTickCount >= N End Sub

Universitas Sumatera Utara