Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Private 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
Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
'Create the DirectSound8 Object
Dim dx As New DirectX8
Dim ds As DirectSound8
Dim dsBuffer As DirectSoundSecondaryBuffer8
Private hmidi As Long
Private baseNote As Long
Private channel As Long
Private volume As Long
Private lNote As Long
Private Playin() As String
Private playinc As Long
Private timers As Long
Private rec As String
Dim midimsg As Long
Dim notep As Long
Dim stur, oncol, offcol
'Declare the variables that will be used
Dim frequency As Double
Dim increment As Double
Dim fileName As String
Dim fileSize As Double
Dim sample As Long
Dim period As Double
Dim state As Integer
Dim bufferptr As Long
Dim inputValue As Double
Dim notetm, onoff, noteimp, asup, asdn, inst
Dim cs1a, cs2a, cs3a, cs4a
Dim cs1b, cs2b, cs3b, cs4b
Dim cs1c, cs2c, cs3c, cs4c
Dim cs1d, cs2d, cs3d, cs4d
Dim cs1e, cs2e, cs3e, cs4e
Dim cs1f, cs2f, cs3f, cs4f
Dim cs1g, cs2g, cs3g, cs4g
Dim cs1h, cs2h, cs3h, cs4h
Dim cs1i, cs2i, cs3i, cs4i
Dim cs1j, cs2j, cs3j, cs4j
Dim cs1k, cs2k, cs3k, cs4k
Dim cs1l, cs2l, cs3l, cs4l
Dim cs1m, cs2m, cs3m, cs4m
Dim cs1n, cs2n, cs3n, cs4n
Dim cs1o, cs2o, cs3o, cs4o
Dim cs1p, cs2p, cs3p, cs4p
Dim cs1q, cs2q, cs3q, cs4q
Dim cs1r, cs2r, cs3r, cs4r
Const Pi = 3.141592654
Const sampleRate = 44100
Const amplitude = 127
Private Sub domusickey(key As Integer)
Dim note As Long
If key = vbKey1 Then note = 1
If key = vbKey2 Then note = 3
If key = vbKey3 Then note = 5
If key = vbKey4 Then note = 6
If key = vbKey5 Then note = 8
If key = vbKey6 Then note = 10
If key = vbKey7 Then note = 12
If key = vbKey8 Then note = 13
If key = vbKey9 Then note = 15
If key = vbKey0 Then note = 17
If key = 189 Then note = 18
If key = 187 Then note = 20
If key = vbKeyQ Then note = 22
If key = vbKeyW Then note = 24
If key = vbKeyE Then note = 25
If key = vbKeyR Then note = 27
If key = vbKeyT Then note = 29
If key = vbKeyY Then note = 30
If key = vbKeyU Then note = 32
If key = vbKeyI Then note = 34
If key = vbKeyO Then note = 36
If key = vbKeyP Then note = 37
If key = 219 Then note = 39
If key = vbKeyA Then note = 41
If key = vbKeyS Then note = 42
If key = vbKeyD Then note = 44
If key = vbKeyF Then note = 46
If key = vbKeyG Then note = 48
If key = vbKeyH Then note = 49
If key = vbKeyJ Then note = 51
If key = vbKeyK Then note = 53
If key = vbKeyL Then note = 54
If key = 186 Then note = 56
If key = vbKeyZ Then note = 58
If key = vbKeyX Then note = 60
If key = vbKeyC Then note = 61
If key = vbKeyV Then note = 63
If key = vbKeyB Then note = 65
If key = vbKeyN Then note = 66
If key = vbKeyM Then note = 68
If key = 188 Then note = 70
If key = 190 Then note = 72
If Not note = lNote And note Then
domusic note
End If
End Sub
'Convert a key to a note, then stop that note
Private Sub domusickeystop(key As Integer)
Dim note As Long
If key = vbKey1 Then note = 1
If key = vbKey2 Then note = 3
If key = vbKey3 Then note = 5
If key = vbKey4 Then note = 6
If key = vbKey5 Then note = 8
If key = vbKey6 Then note = 10
If key = vbKey7 Then note = 12
If key = vbKey8 Then note = 13
If key = vbKey9 Then note = 15
If key = vbKey0 Then note = 17
If key = 189 Then note = 18
If key = 187 Then note = 20
If key = vbKeyQ Then note = 22
If key = vbKeyW Then note = 24
If key = vbKeyE Then note = 25
If key = vbKeyR Then note = 27
If key = vbKeyT Then note = 29
If key = vbKeyY Then note = 30
If key = vbKeyU Then note = 32
If key = vbKeyI Then note = 34
If key = vbKeyO Then note = 36
If key = vbKeyP Then note = 37
If key = 219 Then note = 39
If key = vbKeyA Then note = 41
If key = vbKeyS Then note = 42
If key = vbKeyD Then note = 44
If key = vbKeyF Then note = 46
If key = vbKeyG Then note = 48
If key = vbKeyH Then note = 49
If key = vbKeyJ Then note = 51
If key = vbKeyK Then note = 53
If key = vbKeyL Then note = 54
If key = 186 Then note = 56
If key = vbKeyZ Then note = 58
If key = vbKeyX Then note = 60
If key = vbKeyC Then note = 61
If key = vbKeyV Then note = 63
If key = vbKeyB Then note = 65
If key = vbKeyN Then note = 66
If key = vbKeyM Then note = 68
If key = 188 Then note = 70
If key = 190 Then note = 72
domusicstop note
End Sub
Private Sub ab1_Click()
Dim Msg, Title
Title = "VB Sound Pro Ver. 1.6 "
Msg = "Complete VB Sound Demo, DirectX, MIDI (127 Instruments), Oscilators, MIDI Recorder Including Duration, 127 Instruments, 5 Wave Format Oscilator, MCI Control of AVIVideo, CDAudio, DAT, DigitalVideo, MMMovie, Sequencer, VCR, Videodisc, or WaveAudio.Best Run at 800X600 Resolution."
MsgBox Msg, , Title
End Sub
Private Sub ab5_Click()
Dim Msg, Title
Title = "VB Sound Pro Ver. 1.6"
Msg = "Presets allow the user to store 15 presets all each with seperate Instrument, Pitch, Volume and Channels Settings, to use adjust the 4 settings (Instrument, Pitch, Volume, Channel), and click the <Set Preset # of your choice> Menu Option under the <Presets> section."
MsgBox Msg, , Title
End Sub
Private Sub ab6_Click()
Dim Msg, Title
Title = "VB Sound Pro Ver. 1.6 "
Msg = "If you plan on using this code in your application, registration is required, Visit www.sharewaresoftware.info/vbsoundpro/vbsoundpro.htm for Registration."
MsgBox Msg, , Title
End Sub
Private Sub Command26_Click()
Text23.BackColor = "255"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust1" For Input As #1
Input #1, cs1a, cs2a, cs3a, cs4a
Close #1
sldVol.Value = cs1a
sldPitch.Value = cs2a
sldChan.Value = cs3a
sldInst.Value = cs4a
End Sub
Private Sub Command27_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "255"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust2" For Input As #1
Input #1, cs1b, cs2b, cs3b, cs4b
Close #1
sldVol.Value = cs1b
sldPitch.Value = cs2b
sldChan.Value = cs3b
sldInst.Value = cs4b
End Sub
Private Sub Command28_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "255"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust3" For Input As #1
Input #1, cs1c, cs2c, cs3c, cs4c
Close #1
sldVol.Value = cs1c
sldPitch.Value = cs2c
sldChan.Value = cs3c
sldInst.Value = cs4c
End Sub
Private Sub Command29_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "255"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust4" For Input As #1
Input #1, cs1d, cs2d, cs3d, cs4d
Close #1
sldVol.Value = cs1d
sldPitch.Value = cs2d
sldChan.Value = cs3d
sldInst.Value = cs4d
End Sub
Private Sub Command30_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "255"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust5" For Input As #1
Input #1, cs1e, cs2e, cs3e, cs4e
Close #1
sldVol.Value = cs1e
sldPitch.Value = cs2e
sldChan.Value = cs3e
sldInst.Value = cs4e
End Sub
Private Sub Command31_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "255"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust6" For Input As #1
Input #1, cs1f, cs2f, cs3f, cs4f
Close #1
sldVol.Value = cs1f
sldPitch.Value = cs2f
sldChan.Value = cs3f
sldInst.Value = cs4f
End Sub
Private Sub Command32_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "255"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust7" For Input As #1
Input #1, cs1g, cs2g, cs3g, cs4g
Close #1
sldVol.Value = cs1g
sldPitch.Value = cs2g
sldChan.Value = cs3g
sldInst.Value = cs4g
End Sub
Private Sub Command33_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "255"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust8" For Input As #1
Input #1, cs1h, cs2h, cs3h, cs4h
Close #1
sldVol.Value = cs1h
sldPitch.Value = cs2h
sldChan.Value = cs3h
sldInst.Value = cs4h
End Sub
Private Sub Command34_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "255"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust9" For Input As #1
Input #1, cs1i, cs2i, cs3i, cs4i
Close #1
sldVol.Value = cs1i
sldPitch.Value = cs2i
sldChan.Value = cs3i
sldInst.Value = cs4i
End Sub
Private Sub Command35_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "255"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust10" For Input As #1
Input #1, cs1j, cs2j, cs3j, cs4j
Close #1
sldVol.Value = cs1j
sldPitch.Value = cs2j
sldChan.Value = cs3j
sldInst.Value = cs4j
End Sub
Private Sub Command36_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "255"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust11" For Input As #1
Input #1, cs1k, cs2k, cs3k, cs4k
Close #1
sldVol.Value = cs1k
sldPitch.Value = cs2k
sldChan.Value = cs3k
sldInst.Value = cs4k
End Sub
Private Sub Command37_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "255"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust12" For Input As #1
Input #1, cs1l, cs2l, cs3l, cs4l
Close #1
sldVol.Value = cs1l
sldPitch.Value = cs2l
sldChan.Value = cs3l
sldInst.Value = cs4l
End Sub
Private Sub Command38_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "255"
Text36.BackColor = "16711680"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust13" For Input As #1
Input #1, cs1m, cs2m, cs3m, cs4m
Close #1
sldVol.Value = cs1m
sldPitch.Value = cs2m
sldChan.Value = cs3m
sldInst.Value = cs4m
End Sub
Private Sub Command39_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "255"
Text37.BackColor = "16711680"
On Error Resume Next
Open "cust14" For Input As #1
Input #1, cs1n, cs2n, cs3n, cs4n
Close #1
sldVol.Value = cs1n
sldPitch.Value = cs2n
sldChan.Value = cs3n
sldInst.Value = cs4n
End Sub
Private Sub Command40_Click()
Text23.BackColor = "16711680"
Text24.BackColor = "16711680"
Text25.BackColor = "16711680"
Text26.BackColor = "16711680"
Text27.BackColor = "16711680"
Text28.BackColor = "16711680"
Text29.BackColor = "16711680"
Text30.BackColor = "16711680"
Text31.BackColor = "16711680"
Text32.BackColor = "16711680"
Text33.BackColor = "16711680"
Text34.BackColor = "16711680"
Text35.BackColor = "16711680"
Text36.BackColor = "16711680"
Text37.BackColor = "255"
On Error Resume Next
Open "cust15" For Input As #1
Input #1, cs1o, cs2o, cs3o, cs4o
Close #1
sldVol.Value = cs1o
sldPitch.Value = cs2o
sldChan.Value = cs3o
sldInst.Value = cs4o
End Sub
Private Sub Command41_Click()
On Error Resume Next
sldInst.Value = Text3.Text
End Sub
Private Sub Command42_Click()
On Error Resume Next
sldPitch.Value = Text4.Text
End Sub
Private Sub Command43_Click()
On Error Resume Next
sldVol.Value = Text5.Text
End Sub
Private Sub Command44_Click()
On Error Resume Next
sldChan.Value = Text16.Text
End Sub
'Play piano via keyboard
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
domusickey KeyCode
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
domusickeystop KeyCode
End Sub
Private Sub MMControl1_Done(NotifyCode As Integer)
Text13.BackColor = "16711680"
Text14.BackColor = "16711680"
End Sub
Private Sub opt7_Click()
On Error Resume Next
dsBuffer.Stop
Set dsBuffer = Nothing
On Error Resume Next
tmrwelcome.Enabled = False
domusicstop notep
midiOutClose (hmidi)
MMControl1.Command = "Close"
End Sub
Private Sub sldChan_Change()
channel = sldChan.Value - 1
Text16.Text = channel
End Sub
'Play piano via mouse
Private Sub pKey_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Text15.BackColor = "255"
Text17.BackColor = "16711680"
domusic Index + 1
Text4.Text = Index
End Sub
Private Sub swcall(Index As Integer)
' used to call a note via software
Text20.BackColor = "255"
domusic Index + 1
domusicstop Index + 1
'example below
'Private Sub Command41_Click()
'Text20.BackColor = "255"
'Call swcall(19)
'End Sub
'or: if x=5 then call swcall(19)(19 is the note)
End Sub
Private Sub pKey_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If tmrrec.Enabled Then rec = rec & -mNote & "x" & timers & " "
timers = 0
If mNote = lNote Then lNote = 0 'lNote = 0
'mNote = 0
If mNote > 0 Then 'un-hi-light key when released
If pkey(mNote - 1).Tag = "1" Then
pkey(mNote - 1).BackColor = vbWhite
Else
pkey(mNote - 1).BackColor = vbBlack
End If
End If
End Sub
'Show middle C when pitch is changed
Private Sub sldPitch_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button Then
pkey(59 - sldPitch.Value).SetFocus
End If
End Sub
Private Sub ab2_Click()
If stur = 2 Then stur = 1: GoTo stra:
If stur = 1 Then stur = 2: GoTo strb:
stra:
Text6.Visible = True
Frame5.Visible = False
GoTo stred
strb:
Text6.Visible = False
Frame5.Visible = True
GoTo stred
stred:
End Sub
Private Sub ab3_Click()
Dim Msg, Title
Title = "VB Sound Pro Ver. 1.6"
Msg = "Easy to Understand VB Sound Support for all Sound functions Including DirectX, MIDI, Oscilators, and MCI Functions.(Waves, MP3, MCI, MiDi, DirectX, AVIVideo, CDAudio, DAT, DigitalVideo, MMMovie, Sequencer, VCR, Videodisc, or WaveAudio)."
MsgBox Msg, , Title
End Sub
Private Sub ab4_Click()
Dim Msg, Title
Title = "VB Sound Pro Ver. 1.6 "
Msg = "(c) 2009 PWS software, Tech support scott93727@aol.com, http://www.freeclimate.com/pwssw/pwssw.htm"
PrivaTf state Semstat eeuaTf state Semstat stat system32\_ rce Sub Command18_Click()
Text22.BackColor = "16can w If state = 1 Then e2.BackColor = "o6r Back6can rmao2 YSemstckColor = "o6r Back6cack6cack6cack6cack6cack closeFile < "o6r Bacne Sub Comma rce Sub Cohb scrTens_Chae
End 'Initaveform ad Frequency Selectpertn7s Edt33.BackCub
E(rtn7s Edt33.BackCub
E(rtnOeurtnOeurtnOeurtnOeurtnOeu)tnOeurFrCm eurtnOeu)tnOeurFrCm euro nitaveform ad Frequency Select/o2l"55tfTstnOeurtnOeu)tnOeurFrCmbCoControl1.pkAs Iiceics3d = sldChan.l sldChan.l sldChInteger, Shift As Integer)
