main.frm

一个使用数学方法生成波形声音文件的源代码

   Loop
   S.FillColor = vbButtonFace
End Sub


Private Sub cmdRepStop_Click(Index As Integer)
' NB Repeat (Rnd - Rnd) chosen to repeat pattern but not random numbers
   If Index = 0 Then
      aRepeatPlay = True
      Call chkPlay_MouseUp(1, 0, 0, 0)
   Else
      StopPlay
      aRepeatPlay = False
   End If
End Sub

' Formulae  ----------------------------------------------------

Private Sub List1_Click()
' Public FuncIndex
   FuncIndex = List1.ListIndex + 1
   Evaluate
   aPlayOnce = False
End Sub

Private Sub Evaluate()
' Public FuncIndex
' Private uAmp As Single, uFrq As Single, uDur As Single
Dim percent As Integer
   uAmp = HS(0).Value
   uFrq = HS(1).Value
   uDur = CSng(HS(2).Value) / 10
   
   LabF = Func$(FuncIndex)
   percent = uAmp * 100 / 32767
   Lab(0) = "振幅 =" & Str$(percent) & "%"
   Lab(1) = "频率 = " & CLng(uFrq) & " 赫兹"
   Lab(2) = "持续 = " & Str$(uDur) & " 秒"
   Lab(3) = "采样 = " & Str$(SamplesPerSecond) & " /秒"
   EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
End Sub

' Params ----------------------------------------------------

Private Sub HS_Scroll(Index As Integer)
   Call HS_Change(Index)
End Sub

Private Sub HS_Change(Index As Integer)
' Public FuncIndex
' Private uAmp As Single, uFrq As Single, uDur As Single
Dim percent As Integer
   uAmp = HS(0).Value
   uFrq = HS(1).Value
   uDur = CSng(HS(2).Value) / 10
   If Index = 3 Then
      Select Case HS(3).Value
      Case 1: SamplesPerSecond = 5012
      Case 2: SamplesPerSecond = 11025
      Case 3: SamplesPerSecond = 22050
      Case 4: SamplesPerSecond = 44100
      End Select
      Header.SRate = SamplesPerSecond
      If Bitnum = 1 Then ' 16 bit
         Header.Blk = 2
         Header.BRate = SamplesPerSecond * 2
      Else   ' 8 bit
         Header.Blk = 1
         Header.BRate = SamplesPerSecond
      End If
   End If
   
   LabF = Func$(FuncIndex)
   percent = uAmp * 100 / 32767
   Lab(0) = "Amplitude =" & Str$(percent) & "%"
   Lab(1) = "Frequency = " & CLng(uFrq) & " Hz"
   Lab(2) = "Duration = " & Str$(uDur) & " s"
   Lab(3) = "SampleRate = " & Str$(SamplesPerSecond) & " /s"
   
   If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
   aPlayOnce = False
End Sub

Private Sub optBit_Click(Index As Integer)
   Bitnum = Index
   If Index = 0 Then   ' 8 bit
      cmdSave.Caption = "保存声音文件(8位单声道)"
      Header.Bits = 8
      Header.Blk = 1
      Header.BRate = SamplesPerSecond
   Else   ' 16 bit
      cmdSave.Caption = "保存声音文件(16位单声道)"
      Header.Bits = 16
      Header.Blk = 2
      Header.BRate = SamplesPerSecond * 2
   End If
   aPlayOnce = False
End Sub

' Ramps ----------------------------------------------------

Private Sub picRamp_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   Call picRamp_MouseMove(Index, Button, Shift, X, Y)
End Sub

Private Sub picRamp_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim X0 As Single, x1 As Single
   If X < 0 Then X = 0
   If X > picRamp(0).ScaleWidth Then X = picRamp(0).ScaleWidth
   If Button = 1 Then
      If Index = 0 Then ' Up/Down
         Ramp = 0
         picRamp(0).Cls
         picRamp(0).BackColor = 0
         picRamp(0).ForeColor = vbCyan
         picRamp(0).Line (0, picRamp(0).ScaleHeight)-(X, 0)
         picRamp(0).Line (X, 0)-(picRamp(0).ScaleWidth, picRamp(0).ScaleHeight)
         RampFrac(0) = Round(X / picRamp(0).ScaleWidth, 2)
         
         ' X = RampFrac(Ramp) * picRamp(Ramp).ScaleWidth
         
         picRamp(1).BackColor = vbButtonFace
         picRamp(1).ForeColor = 0
         
         x1 = RampFrac(1) * picRamp(1).ScaleWidth
         picRamp(1).Line (0, 0)-(x1, picRamp(1).ScaleHeight)
         picRamp(1).Line (x1, picRamp(1).ScaleHeight)-(picRamp(1).ScaleWidth, 0)
      Else     ' Down/Up
         Ramp = 1
         picRamp(1).Cls
         picRamp(1).BackColor = 0
         picRamp(1).ForeColor = vbCyan
         picRamp(1).Line (0, 0)-(X, picRamp(1).ScaleHeight)
         picRamp(1).Line (X, picRamp(1).ScaleHeight)-(picRamp(1).ScaleWidth, 0)
         RampFrac(1) = Round(X / picRamp(1).ScaleWidth, 2)
         
         picRamp(0).BackColor = vbButtonFace
         picRamp(0).ForeColor = 0
         
         X0 = RampFrac(0) * picRamp(0).ScaleWidth
         picRamp(0).Line (0, picRamp(0).ScaleHeight)-(X0, 0)
         picRamp(0).Line (X0, 0)-(picRamp(0).ScaleWidth, picRamp(0).ScaleHeight)
      End If
   
      LabFrac(0) = RampFrac(0)
      LabFrac(1) = RampFrac(1)
      If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
      aPlayOnce = False
   End If
End Sub

Private Sub picRamp_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
End Sub

Private Sub cmdRamp_Click()
' No Ramp
Dim X0 As Single, x1 As Single
   picRamp(0).BackColor = vbButtonFace
   picRamp(0).ForeColor = 0
   X0 = RampFrac(0) * picRamp(0).ScaleWidth
   picRamp(0).Line (0, picRamp(0).ScaleHeight)-(X0, 0)
   picRamp(0).Line (X0, 0)-(picRamp(0).ScaleWidth, picRamp(0).ScaleHeight)
   
   picRamp(1).BackColor = vbButtonFace
   picRamp(1).ForeColor = 0
   x1 = RampFrac(1) * picRamp(1).ScaleWidth
   picRamp(1).Line (0, 0)-(x1, picRamp(1).ScaleHeight)
   picRamp(1).Line (x1, picRamp(1).ScaleHeight)-(picRamp(1).ScaleWidth, 0)
   
   Ramp = 2
   RampFrac(2) = 0
   If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
   aPlayOnce = False
End Sub

' Echoes ----------------------------------------------------

Private Sub HSEcho_Scroll()
   Call HSEcho_Change
End Sub

Private Sub HSEcho_Change()
   EchoMul = HSEcho.Value
   LabEcho = EchoMul
   If aEcho Then
      If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
      aPlayOnce = False
   End If
End Sub

Private Sub chkEcho_Click()
   aEcho = -chkEcho.Value
   If aEcho Then
      EchoMul = HSEcho.Value
      LabEcho = EchoMul
   Else
      chkStagger.Value = chkEcho.Value
      aStagger = aEcho
   End If
   If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
   aPlayOnce = False
End Sub

Private Sub chkStagger_Click()
   aStagger = -chkStagger.Value
   If aStagger Then
      chkEcho.Value = chkStagger.Value
      aEcho = aStagger
   End If
   If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
   aPlayOnce = False
End Sub

' Repeat ----------------------------------------------------

Private Sub HSRepeat_Scroll()
   Call HSRepeat_Change
End Sub

Private Sub HSRepeat_Change()
   RepeatMul = HSRepeat.Value
   LabRepeat = RepeatMul
   If aRepeat Then
      If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
      aPlayOnce = False
   End If
End Sub

Private Sub chkRepeat_Click()
   aRepeat = -chkRepeat.Value
   If aRepeat Then
      RepeatMul = HSRepeat.Value
      LabRepeat = RepeatMul
   End If
   If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
   aPlayOnce = False
End Sub

' Presets ----------------------------------------------------

Public Sub Presets()
'' Presets all Public
' pFIndex     = 1 to 16
' pEcho       = 0 UnChecked, 1 Checked
' pEchoMul  = 4 to 32
' pStagger    = 0 UnChecked, 1 Checked
' pRamp       = 0 or 1 U/D or D/U
' pRampFrac   = 0.0 to 1.0
' pReverse    = 0 UnChecked, 1 Checked
' pAmp        = 0.0 to 1.0
' pFreq       = 10 to 8000
' pDuration   = 0.1 to 10
' pSampleRate = 1 to 4
' pAbs        = 0 UnChecked, 1 Checked
' pRepeat     = 0 UnChecked, 1 Checked
' pRepeatMul  = 2 to 32
' pBitnum     = 0(8 bit), 1(16 bit)


   aBlock = True
   
   List1.ListIndex = pFIndex - 1
   chkEcho.Value = pEcho
   HSEcho.Value = pEchoMul
   If pEcho = 0 Then pStagger = 0
   chkStagger.Value = pStagger
   If pRamp <> 2 Then
      Call picRamp_MouseMove(pRamp, 1, 0, pRampFrac * picRamp(pRamp).ScaleWidth, 0)
   Else
      cmdRamp_Click
   End If
   HS(0).Value = pAmp * 32767
   HS(1).Value = pFreq
   HS(2).Value = 10 * pDuration
   HS(3).Value = pSampleRate
   chkReverse.Value = pReverse
   aReverse = pReverse
   chkABS.Value = pAbs
   aABS = pAbs
   aRepeat = pRepeat
   chkRepeat.Value = pRepeat
   HSRepeat.Value = pRepeatMul
   Bitnum = pBitNum
   optBit(Bitnum).Value = True
   InitHeader
   aBlock = False
   EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
   aPlayOnce = False
End Sub

Private Sub cmdPresets_Click()
   Load frmPresets   ' Reads values from Presets.txt
                     ' & lastly calls Form1.Presets
   If ReadError Then Unload frmPresets
End Sub

Private Sub cmdAdd2Presets_Click()
Dim A$
Dim fnum
   Unload frmPresets
   ' Name
   ' get all values
   ' add to Presets.txt
   fnum = 0
   If FileExists(PathSpec$ & "Presets.txt") Then
      A$ = InputBox("ENTER WAVETTE NAME", "Add to Presets", , 95, 95)
      If Trim$(A$) = "" Then
         PlayNoName
         MsgBox "No name entered or Cancelled   ", vbInformation, "Add to Presets"
         Exit Sub
      End If
   Else
      fnum = MsgBox("Make new Presets.txt file", vbQuestion + vbYesNo, "Add to Presets")
      If fnum = vbNo Then Exit Sub
   End If
   
   If fnum = vbYes Then
      A$ = InputBox("ENTER WAVETTE NAME", "Add to Presets", , 95, 95)
      If Trim$(A$) = "" Then
         PlayNoName
         MsgBox "No name entered or Cancelled   ", vbInformation, "Add to Presets"
         Exit Sub
      End If
      fnum = FreeFile
      Open PathSpec$ & "Presets.txt" For Output As #fnum
   Else
      fnum = FreeFile
      Open PathSpec$ & "Presets.txt" For Append As #fnum
   End If
   
   Print #fnum,
   Print #fnum, "Name = " & A$
   
   pFIndex = List1.ListIndex + 1
   Print #fnum, "pFIndex =" & Str$(pFIndex)
   
   pEcho = chkEcho.Value
   Print #fnum, "pEcho =" & Str$(pEcho)
   pEchoMul = HSEcho.Value
   Print #fnum, "pEchoMul =" & Str$(pEchoMul)
   pStagger = chkStagger.Value
   Print #fnum, "pStagger =" & Str$(pStagger)
   Print #fnum, "pRamp =" & Str$(Ramp)
   Print #fnum, "pRampFrac =" & Str$(RampFrac(Ramp))
   pReverse = chkReverse.Value
   Print #fnum, "pReverse =" & Str$(pReverse)
   
   pAmp = HS(0).Value / 32767
   pFreq = HS(1).Value
   pDuration = HS(2).Value / 10
   pSampleRate = HS(3).Value
   
   pAbs = chkABS.Value
   Print #fnum, "pAmp =" & Str$(pAmp)
   Print #fnum, "pFreq =" & Str$(pFreq)
   Print #fnum, "pDuration =" & Str$(pDuration)
   Print #fnum, "pSampleRate =" & Str$(pSampleRate)
   Print #fnum, "pAbs =" & Str$(pAbs)
   
   pRepeat = chkRepeat.Value
   Print #fnum, "pRepeat =" & Str$(pRepeat)
   pRepeatMul = HSRepeat.Value
   Print #fnum, "pRepeatMul =" & Str$(pRepeatMul)
   Print #fnum, "pBitnum =" & Str$(Bitnum)
   
   Close #fnum
End Sub


'Save WAV  ----------------------------------------------------

Private Sub cmdSave_Click()
Dim Title$, Filt$, InDir$
Dim fnum As Long
Dim res As Long
   If Not aPlayOnce Then
      PlayFirst
      MsgBox "Play it first !    ", vbInformation, "Save WAV"
      Exit Sub
   End If

   Dim CDL As OSDialog
   Title$ = "Save As wav file"
   Filt$ = "Save wav|*.wav"
   InDir$ = CurrPath$ 'PathSpec$
   FileSpec$ = ""
   Set CDL = New OSDialog
   CDL.ShowSave FileSpec$, Title$, Filt$, InDir$, "", Me.hWnd
   Set CDL = Nothing

   If Len(FileSpec$) = 0 Then Exit Sub 'for cancel
   If FileExists(FileSpec$) Then
      res = MsgBox("Delete" & vbCrLf & FileSpec$ & "  " & vbCrLf & _
            "binary file first", vbQuestion + vbYesNo, "Saving WAV")
      If res = vbYes Then
         Kill FileSpec$ ' Else get appending with existing wav file
      Else
         MsgBox "then file not saved to avoid appending to existing file !     ", vbInformation, "Saving WAV"
      End If
   End If
   CurrPath$ = FileSpec$
   fnum = FreeFile
   Open FileSpec$ For Binary Access Write As fnum
   Put fnum, , SoundFile
   Close fnum
   aPlayOnce = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim i As Long
   StopPlay
   DoEvents
   If Forms.Count > 1 Then
      For i = Forms.Count - 1 To 0 Step -1
         If UCase(Forms(i).Name) <> UCase("Form1") Then
            Unload Forms(i)
         End If
      Next i
   End If
   Unload Me
End Sub