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