[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 687
  • Last Modified:

How to play tones of defined pitch, volume and duration?

Hi!

How do I make a sound card produce some sounds that are not saved to a file ( WAV, MIDI, etc.), but generated at runtime.

If I'm not mistaking, Quick Basic had a function called: Sound ( pitch, duration ) which could generate a sound of defined pitch ( in Hz ) and duration ( in miliseconds i think )
Off course, the sound was played on PC speaker.

So following routine:

duration = 10
For x = 100 To 2000
     Sound (x,duration)
Next X

would have produced a sound whoose pitch was higher every 10 miliseconds.

I would like to have the same thing in Visual Basic, but played on Sound Card, and with the ability to define volume of the sound.
How do I do that?
0
dbrckovi
Asked:
dbrckovi
1 Solution
 
dds110Commented:
0
 
dds110Commented:
Option Compare Database
Option Explicit

Public Declare Function Beep Lib "kernel32" _
  (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Function Test()
Dim x As Long
For x = 200 To 300 Step 10
Beep x, 100
Next
End Function
0
 
dds110Commented:
That code comes from the same link.
0
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

 
dbrckoviAuthor Commented:
Thanks dds110, but it plays the sound on my PC speaker and I wan't it  played on wave output of my sound card with the ability to set the volume.
0
 
dbrckoviAuthor Commented:
I have increased the points to 500 and asked another question which points to this one.
0
 
GrahamSkanRetiredCommented:
Hi again Davor,

This really just a listening comment.

I tried this myself some time ago, but got bogged down with DirectctX and DLS (Down-Loadable Sounds). Before that I was able to program tones, attack, vibrato etc in stereo on my Amstrad CPC 464. You might know the brand as Schneider. It was a home PC, strictly 8 bit with 32K of user memory. That was in 1985.

Best regards, Graham
0
 
dbrckoviAuthor Commented:
Hi!

I know. I was able to produce some sounds on SB16 under DOS, but it was complicated so I forgot the theory behind it, and even if I had the code it would be usless becouse it was C,
so I thought Windows would provide some simpler way (accessible to VB) to do it, but I can't find it anywhere.

I tried DirectX. It can produce some interesting effects like distortion, 3D sound, chorus, but it all works on existing wav files. I never managed to produce any sound myself.
0
 
vwareCommented:
Hi. The following code is not by myself, just found it somewhere. However, I suppose it does what you want to do - create sounds with DirectX instead of playing sound files.
You will need a txtEnglish textbox and cmdPlay command button on your form. Have fun with this crazy thing... Plays english characters in morse code.



'If the duration of a dot is taken to be one unit
'then that of a dash is three units.
'The space between the components of one character is one unit,
'between characters is three units and between words seven units.
'To indicate that a mistake has been made and for the receiver to
'delete the last word send ........ (eight dots).



Option Explicit
Dim lpBuffer() As Integer
Dim lBufferSize As Long

Private Const MorseUnitLength = 100

Private Const MorseDash = 3
Private Const MorseDot = 1
Private Const MorseWordGap = 7
Private Const morseUnitComponentGap = 1
Private Const morseCharacterGap = 3

Private aMorseCode() As String

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Function createBaseSound() As Integer
    Dim two_pi As Double
    two_pi = 8 * Atn(1)
    Dim lFrequency&, lSampleRate&, lMultiplier&, I&
    lFrequency = 100
    lSampleRate = 22050
    lMultiplier = lSampleRate \ lFrequency
    lBufferSize = lMultiplier * 500
    ReDim lpBuffer(lBufferSize)
    For I = 0 To lBufferSize - 1
        '// For 16-bit integer PCM
        lpBuffer(I) = 32767 * Sin(I * two_pi * lFrequency / lSampleRate)
    Next
    lpBuffer() = lpBuffer()
    lBufferSize = lBufferSize
     
       
End Function


Private Sub cmdPlay_Click()
    Dim sSequence As String
    Dim iRet As Integer
   
    iRet = CreateMorseCodeSequence(txtEnglish.Text, sSequence)
    If iRet <> -1 Then
        Play sSequence
    Else
        MsgBox "String was not able to converted to Morse Code", vbInformation
    End If
End Sub

Private Sub Form_Load()
    Dim iRet As Integer
    ReDim aMorseCode(33 To 90) ' The numbers are the ascii value
   
    'NUMBERS
    aMorseCode(48) = "-----" '0
    aMorseCode(49) = ".----" '1
    aMorseCode(50) = "..---" '2
    aMorseCode(51) = "...--" '3
    aMorseCode(52) = "....-" '4
    aMorseCode(53) = "....." '5
    aMorseCode(54) = "-...." '6
    aMorseCode(55) = "--..." '7
    aMorseCode(56) = "---.." '8
    aMorseCode(57) = "----." '9

    'PUNCTUATION
    aMorseCode(33) = ".----." '!
    aMorseCode(34) = ".-..-." '"
    aMorseCode(40) = "-.--.-" '(
    aMorseCode(44) = "--..--" ',
    aMorseCode(45) = "-....-" '-
    aMorseCode(46) = ".-.-.-" '.
    aMorseCode(47) = "-..-. " '/
    aMorseCode(58) = "---..." ':
    aMorseCode(63) = "..--.." '?
 
    'CHARACTERS
    aMorseCode(65) = ".-" 'A
    aMorseCode(66) = "-..." 'B
    aMorseCode(67) = "-.-." 'C
    aMorseCode(68) = "-.." 'D
    aMorseCode(69) = "." 'E
    aMorseCode(70) = "..-." 'F
    aMorseCode(71) = "--." 'G
    aMorseCode(72) = "...." 'H
    aMorseCode(73) = ".." 'I
    aMorseCode(74) = ".---" 'J
    aMorseCode(75) = "-.-" 'K
    aMorseCode(76) = ".-.." 'L
    aMorseCode(77) = "--" 'M
    aMorseCode(78) = "-." 'N
    aMorseCode(79) = "---" 'O
    aMorseCode(80) = ".--." 'P
    aMorseCode(81) = "--.-" 'Q
    aMorseCode(82) = ".-." 'R
    aMorseCode(83) = "..." 'S
    aMorseCode(84) = "-" 'T
    aMorseCode(85) = "..-" 'U
    aMorseCode(86) = "...-" 'V
    aMorseCode(87) = ".--" 'W
    aMorseCode(88) = "-..-" 'X
    aMorseCode(89) = "-.--" 'Y
    aMorseCode(90) = "--.." 'Z
       
    iRet = createBaseSound
   
End Sub

Private Function CreateMorseCodeSequence(ByVal sEnglish As String, ByRef sSequence As String) As Integer
Dim x As Long
Dim sChar As String
Dim iAscii As Integer

sSequence = ""

For x = 1 To Len(sEnglish)
    sChar = Mid(sEnglish, x, 1)
    iAscii = Asc(UCase(sChar))
    Select Case iAscii
    Case 32
        sSequence = sSequence & "W"
    Case 33 To 90
        If aMorseCode(iAscii) <> "" Then
            sSequence = sSequence & aMorseCode(iAscii) & "C"
        Else
            GoTo ErrHandler
        End If
    Case Else
            GoTo ErrHandler
    End Select
Next x
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
        MsgBox "Character not yet developed in MorseCode array", vbInformation
        CreateMorseCodeSequence = -1
End Select
End Function


Private Sub Play(sSequence As String)
   
    Dim x As Long
    Dim DX As DirectX8
    Dim DS As DirectSound8
    Dim DSBD1 As DSBUFFERDESC
    Dim DSB As DirectSoundSecondaryBuffer8
    Dim DSFormat As WAVEFORMATEX
     
    Set DX = New DirectX8
    Set DS = DX.DirectSoundCreate(vbNullString)
    DS.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY
     
    With DSFormat
        .nFormatTag = WAVE_FORMAT_PCM
        .nChannels = 2
        .lSamplesPerSec = 22050
        .nBitsPerSample = 16
        .nBlockAlign = .nBitsPerSample / 8 * .nChannels
        .lAvgBytesPerSec = .lSamplesPerSec * .nBlockAlign
    End With
     
    DSBD1.fxFormat = DSFormat
    DSBD1.lBufferBytes = lBufferSize
    Set DSB = DS.CreateSoundBuffer(DSBD1)
    DSB.WriteBuffer 0, 0, lpBuffer(0), DSBLOCK_ENTIREBUFFER
   
    Dim lTime As Long
    For x = 1 To Len(sSequence)
        Select Case Mid$(sSequence, x, 1)
            Case "."
                DSB.Play DSBPLAY_LOOPING
                Sleep MorseUnitLength * MorseDot
                DSB.Stop
                Sleep MorseUnitLength * morseUnitComponentGap
            Case "-"
                DSB.Play DSBPLAY_LOOPING
                Sleep MorseUnitLength * MorseDash
                DSB.Stop
                Sleep MorseUnitLength * morseUnitComponentGap
            Case "C" ' Character Gap
                Sleep MorseUnitLength * morseCharacterGap
            Case "W" ' Word Gap
                Sleep MorseUnitLength * MorseWordGap
            Case Else
                MsgBox "Tone not developed", vbCritical
        End Select
           
    Next x
    Set DSB = Nothing
    Set DS = Nothing
    Set DX = Nothing

End Sub
0
 
dbrckoviAuthor Commented:
Thanks.
0
 
dbrckoviAuthor Commented:
GrahamSkan

Since you said you are listening, I suppose you would be interested in this:

This is what I managed to do with the code vware provided:
 - only one command button and a reference to DirectX 8 is required
----------------------------------------------------------------------------------------
Option Explicit
Dim lpBuffer() As Integer
Dim lBufferSize As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Command1_Click()
    PlaySound 50, 5000
    'Can't be used in a loop, becouse the sound will be choppy
    'Eventual effects have to be applied on a lpBuffer before playing inside PlaySound function
End Sub

Sub PlaySound(ByVal Frequency As Integer, ByVal miliseconds As Integer)
    Dim a As Double
    Dim i As Double
    Dim x As Long
    Dim DX As DirectX8
    Dim DS As DirectSound8
    Dim DSBD1 As DSBUFFERDESC
    Dim DSB As DirectSoundSecondaryBuffer8
    Dim DSFormat As WAVEFORMATEX
    Dim two_pi As Double
    Dim lFrequency&, lSampleRate&, lMultiplier&
   
    two_pi = 3.14159265358979 * 2
       
 'Create the sound and store it in lpBuffer() array
    lFrequency = Frequency
    lSampleRate = 22050
    lMultiplier = lSampleRate \ lFrequency
    lBufferSize = lMultiplier * miliseconds * 2
    ReDim lpBuffer(lBufferSize)
       
        'main loop where actual sinusoidal pattern is created
    Me.Print "Creating sound..."
    DoEvents
    For i = 0 To lBufferSize - 1
        lpBuffer(i) = 32767 * Sin((i + a) * two_pi * lFrequency / lSampleRate)
    Next i
    Me.Cls
 'Play the sound from lpBuffer()
    Set DX = New DirectX8
    Set DS = DX.DirectSoundCreate(vbNullString)
    DS.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY
     
    With DSFormat
        .nFormatTag = WAVE_FORMAT_PCM
        .nChannels = 2
        .lSamplesPerSec = 22050
        .nBitsPerSample = 16
        .nBlockAlign = .nBitsPerSample / 8 * .nChannels
        .lAvgBytesPerSec = .lSamplesPerSec * .nBlockAlign
    End With
     
    DSBD1.fxFormat = DSFormat
    DSBD1.lBufferBytes = lBufferSize
    Set DSB = DS.CreateSoundBuffer(DSBD1)
    DSB.WriteBuffer 0, 0, lpBuffer(0), DSBLOCK_ENTIREBUFFER
   
    Me.Print "Playing sound..."
    DoEvents
    DSB.Play DSBPLAY_LOOPING
    Sleep miliseconds
    DSB.Stop
    Me.Cls
   
    Set DSB = Nothing
    Set DS = Nothing
    Set DX = Nothing

End Sub
------------------------------------------------------------------------------------
0

Featured Post

The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now