waveform.frm

本程序代码可以准确地生成1－500Hz波形文件

VERSION 5.00
Begin VB.Form WaveForm 
   Caption         =   "WaveForm Generator"
   ClientHeight    =   2190
   ClientLeft      =   60
   ClientTop       =   390
   ClientWidth     =   5070
   LinkTopic       =   "Form1"
   ScaleHeight     =   2190
   ScaleWidth      =   5070
   StartUpPosition =   2  'CenterScreen
   Begin VB.Frame Frame4 
      Caption         =   "Waveform"
      Height          =   615
      Left            =   120
      TabIndex        =   8
      Top             =   720
      Width           =   4815
      Begin VB.OptionButton Option5 
         Caption         =   " Noise"
         Height          =   255
         Left            =   3900
         TabIndex        =   13
         Top             =   240
         Width           =   855
      End
      Begin VB.OptionButton Option4 
         Caption         =   "Triangle"
         Height          =   255
         Left            =   2820
         TabIndex        =   12
         Top             =   240
         Width           =   975
      End
      Begin VB.OptionButton Option1 
         Caption         =   "Sine"
         Height          =   255
         Left            =   180
         TabIndex        =   11
         Top             =   240
         Value           =   -1  'True
         Width           =   735
      End
      Begin VB.OptionButton Option2 
         Caption         =   "Square"
         Height          =   255
         Left            =   1020
         TabIndex        =   10
         Top             =   240
         Width           =   975
      End
      Begin VB.OptionButton Option3 
         Caption         =   "Saw"
         Height          =   255
         Left            =   2040
         TabIndex        =   9
         Top             =   240
         Width           =   615
      End
   End
   Begin VB.HScrollBar VolCtrl 
      Height          =   255
      LargeChange     =   300
      Left            =   1440
      Max             =   0
      Min             =   -5000
      SmallChange     =   50
      TabIndex        =   1
      Top             =   360
      Value           =   -2000
      Width           =   3375
   End
   Begin VB.Frame Frame2 
      Caption         =   "Volume"
      Height          =   615
      Left            =   1320
      TabIndex        =   6
      Top             =   120
      Width           =   3615
   End
   Begin VB.TextBox freqText 
      Alignment       =   2  'Center
      Height          =   285
      Left            =   240
      TabIndex        =   0
      Text            =   "440"
      Top             =   360
      Width           =   855
   End
   Begin VB.CommandButton Stop 
      Caption         =   "Stop"
      Height          =   375
      Left            =   3728
      TabIndex        =   4
      Top             =   1560
      Width           =   855
   End
   Begin VB.CommandButton Play 
      Caption         =   "Play"
      Height          =   375
      Left            =   2108
      TabIndex        =   3
      Top             =   1560
      Width           =   855
   End
   Begin VB.CommandButton Generate 
      Caption         =   "Generate"
      Height          =   375
      Left            =   488
      TabIndex        =   2
      Top             =   1560
      Width           =   855
   End
   Begin VB.Frame Frame1 
      Caption         =   "Frequency"
      Height          =   615
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   1095
   End
   Begin VB.Frame Frame3 
      Caption         =   "Function"
      Height          =   735
      Left            =   120
      TabIndex        =   7
      Top             =   1320
      Width           =   4815
   End
End
Attribute VB_Name = "WaveForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'A general purpose audio function generator by Michael Hebert
'written as an exercise in learning how to program various
'waveform types. Uses DirectX8 for playback functions only.
'Frequency resolution is 1/10 of a cycle and pitch accuracy
'is reasonable at frequencies < 500 Hz. Use of higher sample
'rates improves accuracy but may not allow use on some
'sound cards.

'Declarations

Dim dx As New DirectX8
Dim ds As DirectSound8
Dim dsBuffer As DirectSoundSecondaryBuffer8
Dim SetVolume As Long
Dim increment As Double
Dim freq As Double
Dim fileName As String
Dim sample As Long
Dim period As Double
Dim state As Integer
Dim bufferptr As Long
Dim inputValue As Double

Const Pi = 3.141592654
Const SampleRate = 44100
Const amplitude = 127

'Make a clean exit from program

Private Sub cmdExit_Click()
    Cleanup
    Unload Me
End Sub

Private Sub Cleanup()
    If Not (dsBuffer Is Nothing) Then dsBuffer.Stop
    Set dsBuffer = Nothing
    Set ds = Nothing
    Set dx = Nothing
End Sub

'Initialize

Private Sub Form_Load()
    Me.Show
    On Local Error Resume Next
    Set ds = dx.DirectSoundCreate("")
    If Err.Number <> 0 Then
        MsgBox "Unable to start DirectSound"
        End
    End If
    ds.SetCooperativeLevel Me.hWnd, DSSCL_PRIORITY
    freqText_Change                'Get/Set desired pitch
End Sub

Private Sub freqText_Change()
    freq = Val(freqText.Text)
End Sub

Private Sub VolCtrl_Scroll()
    dsBuffer.SetVolume VolCtrl.Value
End Sub

Private Sub VolCtrl_Change()
    dsBuffer.SetVolume VolCtrl.Value
End Sub

'Select the waveform

Private Sub Generate_Click()
    If Option1.Value = True Then
        SineWave
    End If
    If Option2.Value = True Then
        SquareWave
    End If
    If Option3.Value = True Then
        SawWave
    End If
    If Option4.Value = True Then
        TriangleWave
    End If
    If Option5.Value = True Then
        WhiteNoise
    End If
End Sub

'Define the DirectX8 playback buffer
'and initialize playback volume

Private Sub Play_Click()
    Dim bufferDesc As DSBUFFERDESC
    bufferDesc.lFlags = DSBCAPS_CTRLVOLUME Or DSBCAPS_STATIC Or DSBCAPS_STICKYFOCUS
    fileName = App.Path & "\temp.wav"
    Set dsBuffer = ds.CreateSoundBufferFromFile(fileName, bufferDesc)
    VolCtrl_Scroll
    VolCtrl_Change
    dsBuffer.Play DSBPLAY_LOOPING
End Sub

'Pause playback without flushing buffer

Private Sub Stop_Click()
    dsBuffer.Stop
End Sub

'Create a PCM Wave file

Private Sub MakeFile()
    fileName = App.Path & "\temp.wav"
    Kill fileName                   'REM this line if file does not exist
    Open fileName For Binary Access Write As #1
        Put #1, 1, "RIFF"           '"RIFF" header
        Put #1, 5, CInt(0)          'Filesize - 8, will write later
        Put #1, 9, "WAVEfmt "       '"WAVEfmt " header - not space after fmt
        Put #1, 17, CLng(16)        'Lenth of format data
        Put #1, 21, CInt(1)         'Wave type PCM
        Put #1, 23, CInt(1)         '1 channel
        Put #1, 25, CLng(44100)     '44.1 kHz SampleRate
        Put #1, 29, CLng(88200)     '(SampleRate * BitsPerSample * Channels) / 8
        Put #1, 33, CInt(2)         '(BitsPerSample * Channels) / 8
        Put #1, 35, CInt(16)        'BitsPerSample
        Put #1, 37, "data"          '"data" Chunkheader
        Put #1, 41, CInt(0)         'Filesize - 44, will write later
End Sub

'The following are algorithms for the various waveforms.
'They are a combination of info from several web sources
'and a lot of experimentation to get them to work properly.
'Some of them could definitely stand improvement but they
'are reasonably accurate as is.

Private Sub SineWave()
    MakeFile
    bufferptr = 45
        increment = Pi / (SampleRate / freq)
        For inputValue = 0 To (2 * Pi) Step increment   'Step around the circle
            sample = Int(amplitude * Sin(inputValue))
            Put #1, bufferptr, sample                   'Write sample to file
            bufferptr = bufferptr + 1                   'Increment buffer pointer for next sample
        Next inputValue
    CloseFile
End Sub

Private Sub SquareWave()
    MakeFile
    bufferptr = 45
    period = (SampleRate / freq)
    state = 1
        If state = 1 Then                   'Positive half cycle
            For inputValue = 0 To period
                sample = amplitude * state
                Put #1, bufferptr, sample
                bufferptr = bufferptr + 1
            Next inputValue
        End If
     state = -1
        If state = -1 Then                  'Negative half cycle
            For inputValue = 0 To period
                sample = amplitude * state
                Put #1, bufferptr, sample
                bufferptr = bufferptr + 1
            Next inputValue
        End If
    CloseFile
End Sub

Private Sub SawWave()
    MakeFile
    bufferptr = 45
        period = SampleRate / (freq / 2)
        For inputValue = 0 To period
            sample = Int(2 * amplitude * (inputValue / period))
            Put #1, bufferptr, sample
            bufferptr = bufferptr + 1
        Next inputValue
    CloseFile
End Sub

Private Sub TriangleWave()
    MakeFile
    state = 0
    bufferptr = 45
        period = SampleRate / freq
        If state = 0 Then
        For inputValue = 0 To period / 2    'Generate Positive Slope
            sample = Int(2 * amplitude * (inputValue / period))
            Put #1, bufferptr, sample
            bufferptr = bufferptr + 1
        Next inputValue
        state = 1
        End If
        If state = 1 Then
        For inputValue = 0 To period        'Generate Negative Slope
            sample = Int((amplitude - 2 * amplitude) - 2 * amplitude * (inputValue - period) / period)
            Put #1, bufferptr, sample
            bufferptr = bufferptr + 1
        Next inputValue
        state = 2
        End If
        If state = 2 Then
        For inputValue = 0 To period / 2    'Positive Slope to finish cycle
            sample = Int(amplitude + (2 * amplitude * (inputValue / period)))
            Put #1, bufferptr, sample
            bufferptr = bufferptr + 1
        Next inputValue
        End If
    CloseFile
End Sub

Private Sub WhiteNoise()
    Randomize
    MakeFile
    bufferptr = 45
    period = SampleRate
        For inputValue = 0 To period        'Create 44,100 random samples
            sample = Rnd(amplitude) * 254
            Put #1, bufferptr, sample
            bufferptr = bufferptr + 1
        Next inputValue
    CloseFile
End Sub

'Get the file length, write it into the header and close the file.

Private Sub CloseFile()
    fileSize = LOF(1)
    Put #1, 5, CLng(fileSize - 8)
    Put #1, 41, CLng(fileSize - 44)
    Close #1
    Play_Click
End Sub