Die Community zu .NET und Classic VB.
Menü

Quellcode des Wave-Generators

 von 

Quellcode  

'Dieser Source stammt von http://www.activevb.de und
'darf zur nicht kommerziellen Nutzung frei verwendet werden,
'solange diese Vermerke unverändert bleiben.
'© Klaus Langbein, November 2000
'
'Für eventuelle Schäden wird nicht gehaftet.
'
'Sollten Sie Fehler entdecken oder Fragen haben, dann
'mailen Sie mir bitte unter: MarkusPalme@activevb.de
'Ansonsten viel Spaß und Erfolg damit !

Dim xoff As Long
Dim yoff As Long
Dim xfact As Single
Dim yfact As Single

Dim npt As Long
'-------------------------------------------------------

Sub plot_wave(fname$)

   Dim vmin As Long
   Dim vmax As Long
   Dim xx As Long   ' xx and yy are the coordinates
            'in screen output units (twips or pixels)
   Dim yy As Long
   Dim test$

   test$ = Dir$(fname$)
      ' first check if the file exists
   If test$ = "" Then
       MsgBox "File does not exist!"
       Exit Sub
   End If

   Picture1.AutoRedraw = -1
       ' just in case you forgot to set this at design time
   Picture2.AutoRedraw = -1
   Picture1.Cls
   Picture2.Cls
   DoEvents

   vmin = Val(Text2.Text) ' one could of course make this sub more universal
   If vmin < 1 Then       ' by passing the start and the end to the sub instead
       vmin = 1           ' of reading from the text boxes
   End If

   vmax = Val(Text3.Text)
   If vmax > UBound(wave1) Then
       vmax = UBound(wave1)
   End If

   xx = xxc(1)
   yy = yyc(wave1(vmin))
   Picture1.PSet (xx, yy) ' just setting the starting point

   xx = xxc(1)
   yy = yyc(wave2(vmin))
   Picture2.PSet (xx, yy)

   Dim pts As Long
   pts = vmax - vmin
   ReDim poly(pts) As pointapi

   For i = vmin To vmax
       'MsgBox wave1(i)
       poly(i - vmin).X = xxc(1 + i - vmin)
       poly(i - vmin).Y = yyc(wave1(i))
   Next i

   If pts < 16384 Then ' for some reason the polyline call does not
                       ' like arrays > 16384 ie 1/2 a short integer
        A = Polyline(Picture1.hdc, poly(0), pts)
   Else
       np = 16000
       j = 0
       Do
           A = Polyline(Picture1.hdc, poly(j), np)
           j = j + np
           If pts - j < 16000 Then
               np = pts - j
           End If
       Loop Until np = 0
   End If

   If fmt.Chan = 1 Then ' if its mono we have already done enough
        Goto exi
   End If
   DoEvents

   ReDim poly(pts) As pointapi
   For i = vmin To vmax

       poly(i - vmin).X = xxc(1 + i - vmin)
       poly(i - vmin).Y = yyc(wave2(i))

   Next i

   If pts < 16384 Then
        A = Polyline(Picture2.hdc, poly(0), pts)
   Else
       np = 16000
       j = 0
       Do
           A = Polyline(Picture2.hdc, poly(j), np)
           j = j + np
           If pts - j < 16000 Then
               np = pts - j
           End If
       Loop Until np = 0
   End If

   Picture2.Refresh
   Picture2.PSet (xx, yy)
exi:


End Sub
'-------------------------------------------------------

Private Sub cmdReadH_Click()

   Call read_header(txtReadF.Text)
   Label2(3).Caption = fmt.Dl
   Label2(0).Caption = fmt.Chan
   Label2(1).Caption = fmt.Ns
   Label2(2).Caption = fmt.Sl
   Label2(4).Caption = riff4.chunkSize
   Label2(5).Caption = fmt.Sps
   Label2(6).Caption = fmt.CSize
   Label2(7).Caption = FileLen(txtReadF.Text)

   Select Case fmt.Chan

   Case 1
       Option1(0).Value = -1
   Case 2
       Option1(1).Value = -1
   End Select

   Select Case fmt.Sl

   Case 8
       Option2(0).Value = -1
       Text7.Text = 127
   Case 16
       Option2(1).Value = -1
       Text7.Text = 10000
   Case 24
       Option2(3).Value = -1
   Case 32
       Option2(4).Value = -1

   End Select

   Text6.Text = fmt.Ns



End Sub
'-------------------------------------------------------


Private Sub cmdReadA_Click()

   Call cmdReadH_Click
   Call read_wave(txtReadF.Text)
   wmax = find_max_of_both(fmt.Chan)
   Text7.Text = wmax

End Sub
'-------------------------------------------------------

Private Sub Command1_Click()
   Text2.Text = "0"
   Text3.Text = Text6.Text
End Sub
'-------------------------------------------------------

Private Sub Command2_Click()

   npt = Val(Text3.Text) - Val(Text2.Text)
   Call fact(Picture1)

   Call plot_wave(txtReadF.Text)


End Sub
'-------------------------------------------------------
Private Sub Command3_Click()

   If Option1(0).Value = -1 Then
       fmt.Chan = 1
   End If

   If Option1(1).Value = -1 Then
       fmt.Chan = 2
   End If

   If Option2(0).Value = -1 Then
       fmt.Sl = 8
   End If
   If Option2(1).Value = -1 Then
       fmt.Sl = 16
   End If
   If Option2(2).Value = -1 Then
       fmt.Sl = 24
   End If
   If Option2(3).Value = -1 Then
       fmt.Sl = 32
   End If

   Ns = Val(Text6.Text)
   If Ns > 0 Then
       fmt.Ns = Ns
   End If

   fmt.Dl = fmt.Ns * fmt.Chan * (fmt.Sl / 8)

   fmt.Sps = Val(Text8.Text)
   fmt.BlA = fmt.Chan * (fmt.Sl / 8)
   fmt.Bps = fmt.Sps * fmt.BlA

   Call generate_wave
   Call normalize_waves(fmt.Chan, Val(Text7.Text))

End Sub
'-------------------------------------------------------
Private Sub Command4_Click()

   Call Command6_Click
   'MsgBox find_max_of_both(2)
   Call write_wave_file(txtWriteF.Text)

End Sub
'-------------------------------------------------------
Private Sub Command5_Click()

   fname$ = txtWriteF.Text
   If fname$ = "" Then
       fname$ = txtReadF.Text
       txtWriteF.Text = fname$
   End If
   Call Play_Sound(fname$)

End Sub
'-------------------------------------------------------

Private Sub Command6_Click()
   Call Stop_Sound

   t = Timer
   timm = 1 'Or &H8
   'A = playwav("", 1)
   If timm = 0 Then
       MsgBox Timer - t
   End If

End Sub
'-------------------------------------------------------


Private Sub Command7_Click()

   fname$ = txtWriteF.Text
   If fname$ = "" Then
       fname$ = txtReadF.Text
       txtWriteF.Text = fname$
   End If

   t = Timer
   flag = 1 'Or &H8
   A = PlayWav(fname$, flag)
   If flag = 0 Then
       MsgBox Timer - t
   End If

End Sub
'-------------------------------------------------------

Private Sub Command8_Click()

   Call Command3_Click
   Call Command4_Click
   Call Command7_Click
End Sub
'-------------------------------------------------------

Private Sub Form_Load()

   fname$ = appath() + "\test.wav"

   txtReadF.Text = fname$
   txtWriteF.Text = fname$

End Sub
'-------------------------------------------------------


Sub fact(pic As Control)

   ymax = 2 * Val(Text7.Text)
   If ymax = 0 Then
       ymax = 1000
   End If


   bordery = pic.ScaleHeight * 0.01
   borderx = pic.ScaleWidth * 0.02

   xoff = borderx
     ' this looks stupid but gives some flexibility
     ' if you want to change things at runtime
   yoff = pic.ScaleHeight / 2

   xfact = (pic.ScaleWidth - 2 * borderx) / npt
   yfact = (pic.ScaleHeight - bordery) / ymax

End Sub
'-------------------------------------------------------


Function xxc(ByVal X As Double) As Long
   ' just a simple function to convert
   ' to the coordintes of the ouput control
   xxc = xoff + xfact * X

'-------------------------------------------------------
End Function

Function yyc(ByVal Y As Double) As Long

   yyc = yoff - yfact * Y

'-------------------------------------------------------
End Function



Private Sub Form_MouseDown(Button As Integer, _
 Shift As Integer, X As Single, Y As Single)

 Z = 1

'-------------------------------------------------------

End Sub
'-------------------------------------------------------

Private Sub mnuExit_Click()
   End
End Sub
'-------------------------------------------------------


Private Sub mnuOpen_Click()

   fname$ = Filesel(CMDialog1, "Select Wave File", "wav", "", _
    " _Wave Files (*.wav) |*.wav|All Files (*.*)|*.*")
   If fname$ <> "" Then
       txtReadF.Text = fname$
       txtWriteF.Text = fname$
   End If
   Call cmdReadH_Click

End Sub
'-------------------------------------------------------


Private Sub mnuReverse_Click()

   Call reverse_waveform(fmt.Chan)

'-------------------------------------------------------
End Sub

Private Sub Option2_Click(Index As Integer)

   Select Case Index
   Case 0
       Text7.Text = "127"
       fmt.Sl = 8
   Case 1
       Text7.Text = "32000"
       fmt.Sl = 16
   Case 2
   Case 3
   End Select

'-------------------------------------------------------
End Sub

 

Type pointapi
   X As Long
   Y As Long
End Type
'Global poly() As pointapi

Declare Function Polyline Lib "gdi32" (_ByVal hdc As Long, lpPoint As pointapi, ByVal nCount As Long) As Long
'-------------------------------------------------------


Function bite(ByRef ModString$, ByVal delim$) As String

   ' Function to "bite" off a chunk of text up to (and including)
   ' a delimiter from a string from left to right

   ' warning if the delimiter is found ModString$ is returned modified!
   ' if it is not found the original string remains unchanged

   ' the temporary variable bit is used for debugging purposes only

   Dim pos As Integer
   Dim bit$

   pos = InStr(1, ModString$, delim$, 1)
   If pos > 0 Then
       bit$ = Left$(ModString$, pos - 1)
       ModString$ = Right$(ModString$, Len(ModString$) - Len(bit$) - Len(delim$))
   Else
       bit$ = ModString$
       'ModString$ = ""  is set in function eat
   End If

   bite$ = bit$

'-------------------------------------------------------
End Function

Function Filesel(dlg As Control,_ Optional Title, Optional ext, Optional default, Optional filter) As String

   On Error Goto FileSel_err

   Dim pos As Long
   Dim actio As Long
   Dim fname$

   actio = 1 ' setting a default

   If IsEmpty(Title) = -1 Then
       Title = "Open"
   Else
       pos = InStr(1, Title, "save", 1)
       If pos = 0 Then
           pos = InStr(1, Title, "export", 1)
       End If
       If pos > 0 Then
           actio = 2
           pos = InStr(1, Title, "open", 1)
           If pos > 0 Then
               actio = 1
           End If
       End If
   End If
   dlg.DialogTitle = Title

   If VarType(ext) = 10 Then
       dlg.DefaultExt = "*"
   Else
       If ext = "" Then
           dlg.DefaultExt = ""
       Else
           dlg.DefaultExt = "*." + ext
           If VarType(default) = 10 Then
               dlg.filename = "*." + ext
           End If
       End If
   End If

   If VarType(default) = 10 Then ' vartype = error
       dlg.DefaultExt = ""
       default = ""
   Else
       dlg.filename = default
   End If

   If default = "" Then
       dlg.DefaultExt = ""
   End If
   'filter = ""

   If VarType(filter) = 10 Then

      dlg.filter = "All files (*.*) |*.*"
   Else
       dlg.filter = filter
   End If

   dlg.CancelError = -1

   dlg.Action = actio
   fname$ = dlg.filename

   pos = InStr(1, fname$, ".", 1) ' just in case MS creates a second "." due to defaultext
   If pos > 0 Then
       pos = InStr(pos + 1, fname$, ".", 1)
       If pos > 0 Then
           fname$ = Left$(fname$, pos - 1)
       End If

   End If


   'MsgBox fname$

   If fname$ <> "" Then
       test$ = Dir$(fname$, 16) 'causes error if bad path
   End If

   If actio = 1 Then
       If fname$ <> "" Then
           test$ = Dir$(fname$)
           If test$ = "" Then
               MsgBox "File not found: " + fname$
           End If
       End If
   Else
       test$ = "ok"
   End If

   If test$ <> "" Then
       Filesel = fname$
   End If

FileSel_exit:

Exit Function

FileSel_err:

   Select Case Err

   Case 32755
       'dont care
       Filesel = ""
       Resume FileSel_exit

   Case Else
       MsgBox Error$
       'Resume
       Resume FileSel_exit


   End Select

FileSel_err2:

End Function
'-------------------------------------------------------
Function appath() As String

   Dim path$

   path$ = App.path

   If Right$(path$, 1) = "\" Then
       path$ = Left$(path$, Len(path$) - 1)
   End If

   appath = path$

End Function
'-------------------------------------------------------


Function eat(ByRef ModString$, ByVal delim$) As String

   ' Function to "bite" off a chunk of text up to (and including)
   ' a delimiter from a string from left to right

   ' warning if the delimiter is found ModString$ is returned modified!
   ' if it is not found the original string is returned empty

   Dim pos As Integer
   Dim bit$

   pos = InStr(1, ModString$, delim$, 1)
   If pos > 0 Then
       bit$ = Left$(ModString$, pos - 1)
       ModString$ = Right$(ModString$, Len(ModString$) - Len(bit$) - Len(delim$))
   Else
       bit$ = ModString$
       ModString$ = ""  ' see also function bite"
   End If

   eat = bit$

End Function
'-------------------------------------------------------

soundplay.bas  

Private Declare Function mciSendString Lib "winmm.dll" Alias _
                          "mciSendStringA" (ByVal lpstrCommand As String, _
                          ByVal lpstrReturnString As String, ByVal uReturnLength _
                          As Long, ByVal hwndCallback As Long) As Long

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
 (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'-------------------------------------------------------

Function PlayWav(ByVal soundfile$, ByVal flag As Long) As Long

   ' does the same as sndPlaySound - I just prefer the name of the function
   On Error Resume Next
   Dim Sound As Long


   Sound = sndPlaySound(soundfile$, flag)
   PlayWav = Sound


End Function
'-------------------------------------------------------
Sub Stop_Sound()

   Dim result&, buffer$, CallBack&

   buffer = Space$(128)
   result = mciSendString("stop sound", buffer, 128, CallBack)
   result = mciSendString("close sound", buffer, 128, CallBack)

End Sub
'-------------------------------------------------------

Sub Play_Sound(ByVal path$)

   Dim result&, buffer$, CallBack&
   Call Stop_Sound
   DoEvents
   buffer = Space$(128)
   result = mciSendString("open waveaudio!" & path _
            & " alias sound", buffer, 128, CallBack)

   If result Then
       MsgBox "Error " + Format$(result)
       Exit Sub
   End If

   result = mciSendString("play sound", buffer, 128, CallBack)
   'result = mciSendString("close sound", buffer, 128, CallBack)
End Sub

wavegen.bas  

 Type riff_descriptor_4


   Id As String * 4    ' this should normally be "riff"
    chunkSize As Long   ' length of the chunk to follow
    typ As String * 4   ' information about the type

 End Type

 Type chunk_descriptor

    Id As String * 4
    chunkSize As Long

 End Type

 Type data_descriptor

    Id As String * 4
    chunkSize As Long
    ' chunkSize ' is interpreted separately here
 End Type

 Type fact_descriptor_4

    Id As String * 4
    chunkSize As Long
    fact As Long

 End Type

 ' my own structure to hold wav file information
 ' - makes life a little easier for me
 ' a lot of info is redundant, but this means
 'there is less to calculate in code

 Type format_own

    Id As String * 4  ' Chunk Identifier (e.g. Riff, Data
    CSize As Long     ' ChunkSize
    Tag As Integer    ' wFormatTag
    Chan As Integer   ' Number of channels
    Sps As Long       ' samples per second
    Bps As Long       ' Bytes  per second
    BlA As Long       ' wBlockAlign
    Sl As Long        ' sample_length (wBitsPerSample)
    Fpos As Long      ' holds current file position (ie this can vary)
    Dpos As Long      ' position of data in file
    Dl As Long        ' data length
    Ns As Long        ' number of samples per channel ie dl/(sl*chan)

 End Type

 '
 Type format_16
 ' ie if chunksize is read as 16 byte long
 ' total length is 24

    Id As String * 4
    chunkSize As Long
    wFormatTag As Integer    '2
    wChannels As Integer     '2
    dwSamplesPerSec As Long  '4
    dwAvgBytesPerSec As Long '4
    wBlockAlign As Integer    '2
    wBitsPerSample As Integer ' 2

 End Type

 Type format_18
 ' ie if chunksize is read as 18 byte long
 ' total length is 26
    Id As String * 4
    chunkSize As Long
    wFormatTag As Integer    '2
    wChannels As Integer     '2
    dwSamplesPerSec As Long  '4
    dwAvgBytesPerSec As Long '4
    wBlockAlign As Integer    '2
    wBitsPerSample As Integer ' 2
    b1 As Integer             ' 2
 End Type


 Type format_20 'total length is 28

    Id As String * 4
    chunkSize As Long
    wFormatTag As Integer    '2
    wChannels As Integer     '2
    dwSamplesPerSec As Long  '4
    dwAvgBytesPerSec As Long '4
    wBlockAlign As Integer    '2
    wBitsPerSample As Integer ' 2
    a1 As Long

 End Type

 Type format_50  ' total length: 58

    Id As String * 4         '4
    chunkSize As Long        '4
    wFormatTag As Integer    '2
    wChannels As Integer     '2
    dwSamplesPerSec As Long  '4
    dwAvgBytesPerSec As Long '4
    wBlockAlign As Integer   '2
    wBitsPerSample As Integer '2
    a1 As Long               '4
          'a1 - a7 and b1 are used here just to take up the
    a2 As Long               '4  required space.
    a3 As Long               '4
    a4 As Long               '4
    a5 As Long               '4
    a6 As Long               '4
    a7 As Long               '4
    a8 As Long               '4
    b1 As Integer            '2

 End Type

 Global fmt_length As Long
 Global data_pos As Long
 Global TestId As chunk_descriptor
 Global DataId  As data_descriptor
 Global Fmt16 As format_16
 Global Fmt18 As format_18
 Global fmt20 As format_20
 Global fmt50 As format_50
 Global fact4 As fact_descriptor_4
 Global riff4 As riff_descriptor_4
 Global fmt As format_own

 Global wave1() As Integer
 Global wave2() As Integer
 '-------------------------------------------------------

 Function find_max(ByRef wave() As Integer) As Long

    Dim i As Long
    Dim wmax As Long


    For i = 1 To UBound(wave)

        If wave(i) > wmax Then
            wmax = wave(i)
        End If

    Next i

    find_max = wmax

 '-------------------------------------------------------
 End Function

 Function find_max_of_both(ByVal channels As Integer) As Long

    Dim wmax1 As Long
    Dim wmax2 As Long
    Dim wmax As Long

    wmax1 = find_max(wave1())
    If channels = 2 Then
        wmax2 = find_max(wave2())
    End If
    wmax = wmax1
    If wmax2 > wmax Then
        wmax = wmax2
    End If

    find_max_of_both = wmax

 End Function
 '-------------------------------------------------------

 Sub normalize_wave(ByVal amax As Long, ByVal wmax As Long, _
  ByRef wave() As Integer)

    Dim fact As Single


    fact = amax / wmax

    For i = 1 To UBound(wave)

        wave(i) = wave(i) * fact

    Next i

 End Sub
 '-------------------------------------------------------

 Sub normalize_waves(ByVal channels As Integer, ByVal amax As Long)

    Dim wmax As Long
    wmax = find_max_of_both(channels)

    Call normalize_wave(amax, wmax, wave1())
    If channels = 2 Then
        Call normalize_wave(amax, wmax, wave2())
    End If

 '    wmax1 = find_max(wave1())
 '    wmax2 = find_max(wave2())

 End Sub
 '-------------------------------------------------------


 Sub reverse_waveform(ByVal channels As Integer)

    ub = UBound(wave1)
    ReDim wave1r(ub) As Integer

    For i = 1 To ub
        wave1r(ub - i + 1) = wave1(i)
    Next i
    For i = 1 To ub
        wave1(i) = wave1r(i)
    Next i


    If channels = 1 Then
        Exit Sub
    End If

    ReDim wave2r(ub) As Integer
    For i = 1 To ub
        wave2r(ub - i + 1) = wave2(i)
    Next i
    For i = 1 To ub
        wave2(i) = wave2r(i)
    Next i

 End Sub
 '-------------------------------------------------------

 Function write_header(ByVal fno As Long, ByRef FmtOwn As format_own) As Long

    ' writes the wave file header into an already open channel (fno)
    ' file must be open in binary mode

    Dim riff As riff_descriptor_4  ' dimensioning temporary descriptors
    Dim Fmt16 As format_16
    Dim DataHead As data_descriptor

    Dim rl As Long    ' riff length
    Dim fl As Long    ' frame legth in bits
    Dim l As Long     ' filelength (not used
    Dim pos As Long

    If fno = 0 Then
        MsgBox "Invalid file handle!"
        Exit Function
    End If

    fl = 16 + 8        ' fmt-length + 4 Byte fmt keyword + 4 byte for length

    Dl = FmtOwn.Ns * (FmtOwn.Sl / 8) * FmtOwn.Chan

    rl = fl + Dl
    rl = rl + 8 + 4    ' fmt_length + 8 byte data header + 4 byte for "Wave" keyword

    Call make_fmt16(Fmt16, FmtOwn)
    Call make_riff(riff, rl)
    Call make_datahead(DataHead, Dl)

    Seek #fno, 1
    Put #fno, , riff
    Put #fno, , Fmt16
    Put #fno, , DataHead

    pos = Seek(fno)

    write_header = pos ' passing back the present position in file

 '-------------------------------------------------------
 End Function

 Sub generate_wave()

    On Error Goto err1

    Z = 1
    ReDim wave1(fmt.Ns)
    ReDim wave2(fmt.Ns)
    Dim Y As Integer
    Dim a1 As Single
    Dim a2 As Single
    Dim b1 As Single
    Dim b2 As Single
    Dim b3 As Single
    Dim d1 As Single
    Dim n1 As Single
    Dim n2 As Single
    Dim phi1 As Single
    Dim phi2 As Single

    a1 = Val(Form1.Text4(0).Text)
    a2 = Val(Form1.Text4(1).Text)
    b1 = Val(Form1.Text4(2).Text)
    b2 = Val(Form1.Text4(3).Text)
    n1 = Val(Form1.Text4(4).Text)
    n2 = Val(Form1.Text4(5).Text)
    d1 = Val(Form1.Text4(6).Text)

    b3 = b2 + (d1 * b2)

    phi1 = 1.52
    phi2 = 1
    t = Timer

    For i = 1 To UBound(wave1)

        a2 = a1 * Sin(i * b1 + phi1) ^ n1
 '        Y2 = a2 * Sin(i * b2) ^ n2
 '        Y1 = a2 * Sin(i * b3) ^ n2
 '        wave1(i) = Y1 + Y2          ' this is more flexible
        wave1(i) = a2 * Sin(i * b2) ^ n2 + a2 * Sin(i * b3) ^ n2 ' this is faster
        'MsgBox wave1(i)

    Next i

    'MsgBox Timer - t
    t = Timer
    off = 2.5 / b2
    For i = 1 To UBound(wave1) - off

        wave2(i) = wave1(i + off)

    Next i
    'MsgBox Timer - t
 exi:
    Exit Sub
    'Exit Function
 ' ******** normal end of sub ******************

 err1:

    Select Case Err

    Case 9

    Case Else


        MsgBox Err & ": " + Error$, 16, subb$
        Resume err2

    End Select

 err2:



 End Sub
 '-------------------------------------------------------

 Sub generate_sinus()

    Z = 1
    ReDim wave1(fmt.Ns)
    ReDim wave2(fmt.Ns)
    Dim Y As Integer
    Dim a1 As Single
    Dim b1 As Single
    Dim a2 As Single
    Dim b2 As Single
    'pipi = pi
    a1 = Val(Form1.Text4(0).Text)
    a2 = Val(Form1.Text4(1).Text)
    b1 = Val(Form1.Text4(2).Text)
    b2 = Val(Form1.Text4(3).Text)
    n1 = Val(Form1.Text4(4).Text)
    n2 = Val(Form1.Text4(5).Text)
    d1 = Val(Form1.Text4(6).Text)

    b3 = b2 + (d1 * b2)

    phi1 = 1.52
    phi2 = 1

    t = 0

    Sps = fmt.Sps
    ts = 1 / Sps
    freq = 440
    tf = 1 / freq

    tau = tf / ts
    w = 2 * pi * freq
    tstep = ts

    For i = 1 To UBound(wave1)

        t = t + tstep
        Y1 = a1 * Sin(w * t) ^ n2
        'wave1(i) = Y1

        a3 = a2 * Sin(i * b1 + phi1) ^ n1
        wave1(i) = a3 * Y1
        If Y1 > 0 Then
       ' MsgBox wave1(i)
        End If
    Next i


    off = 2.5 / b2
    For i = 1 To UBound(wave1) - off

        wave2(i) = wave1(i + off)

    Next i

    'MsgBox Timer - t

 End Sub
 '-------------------------------------------------------


 Sub generate_square()

    Z = 1
    ReDim wave1(fmt.Ns)
    ReDim wave2(fmt.Ns)
    Dim Y As Integer
    Dim a1 As Single
    Dim b1 As Single
    Dim a2 As Single
    Dim b2 As Single

    a1 = Val(Form1.Text4(0).Text)
    a2 = Val(Form1.Text4(1).Text)
    b1 = Val(Form1.Text4(2).Text)
    b2 = Val(Form1.Text4(3).Text)
    n1 = Val(Form1.Text4(4).Text)
    n2 = Val(Form1.Text4(5).Text)
    d1 = Val(Form1.Text4(6).Text)

    b3 = b2 + (d1 * b2)

    phi1 = 1.52
    phi2 = 1

    t = 0

    Sps = fmt.Sps
    ts = 1 / Sps
    freq = 440
    tf = 1 / freq

    tau = tf / ts
    w = 2 * pi * freq
    tstep = ts
    pi2 = 2 * pi
    For i = 1 To UBound(wave1)

        t = t + tstep
        dt = (w * t / pi2) - Int(w * t / pi2)
        'MsgBox dt
        If dt < 0.3 Then
            wave1(i) = a1
        Else
            wave1(i) = -a1
        End If


        'MsgBox wave1(i)
    Next i


    off = 0 '2.5 / b2
    For i = 1 To UBound(wave1) - off

        wave2(i) = wave1(i + off)


 '        t = t + tstep
 '        Y1 = a1 * Sin(w * t)
        'MsgBox dt




    Next i

    'MsgBox Timer - t

 End Sub
 '-------------------------------------------------------
 Sub generate_sawtooth()

    Z = 1
    ReDim wave1(fmt.Ns)
    ReDim wave2(fmt.Ns)
    Dim Y As Integer
    Dim a1 As Single
    Dim b1 As Single
    Dim a2 As Single
    Dim b2 As Single

    a1 = Val(Form1.Text4(0).Text)
    a2 = Val(Form1.Text4(1).Text)
    b1 = Val(Form1.Text4(2).Text)
    b2 = Val(Form1.Text4(3).Text)
    n1 = Val(Form1.Text4(4).Text)
    n2 = Val(Form1.Text4(5).Text)
    d1 = Val(Form1.Text4(6).Text)

    b3 = b2 + (d1 * b2)

    phi1 = 1.52
    phi2 = 1

    t = 0

    Sps = fmt.Sps
    ts = 1 / Sps
    freq = 440
    tf = 1 / freq

    tau = tf / ts
    w = 2 * pi * freq
    tstep = ts
    pi2 = 2 * pi
    For i = 1 To UBound(wave1)

        t = t + tstep
        dt = (w * t / pi2) - Int(w * t / pi2)
        Y1 = dt * 2 * a1 - a1

        wave1(i) = Y1
        'MsgBox wave1(i)
    Next i


    off = 0 '2.5 / b2
    For i = 1 To UBound(wave1) - off

        wave2(i) = wave1(i + off)


 ''        t = t + tstep
 ''        Y1 = a1 * Sin(w * t)
        'MsgBox dt




    Next i

    'MsgBox Timer - t

 End Sub
 '-------------------------------------------------------


 Sub generate_triangle()

    Z = 1
    ReDim wave1(fmt.Ns)
    ReDim wave2(fmt.Ns)
    Dim Y As Integer
    Dim a1 As Single
    Dim b1 As Single
    Dim a2 As Single
    Dim b2 As Single

    a1 = Val(Form1.Text4(0).Text)
    a2 = Val(Form1.Text4(1).Text)
    b1 = Val(Form1.Text4(2).Text)
    b2 = Val(Form1.Text4(3).Text)
    n1 = Val(Form1.Text4(4).Text)
    n2 = Val(Form1.Text4(5).Text)
    d1 = Val(Form1.Text4(6).Text)

    b3 = b2 + (d1 * b2)

    phi1 = 1.52
    phi2 = 1

    t = 0

    Sps = fmt.Sps
    ts = 1 / Sps
    freq = 440
    tf = 1 / freq

    tau = tf / ts
    w = 2 * pi * freq
    tstep = ts
    pi2 = pi / 2
    ystep = a1 / 50
    cnt = 0
    t = 0
    Y1 = 0
    On Error Resume Next
    For i = 1 To UBound(wave1)
        cnt = cnt + 1
        t = t + tstep
        'dt = (w * t / pi2) - Int(w * t / pi2)
        dt = Abs(Sin(w * t))

        If dt > 0.9 Then
        Z = 1
        End If
        If dt > 0.999 Then
            If done = 0 Then
                ystep = -ystep
            End If
            done = 1
        End If

        If dt < 0.9 Then
            done = 0
        End If

        Y1 = Y1 + ystep

        a3 = a2 * Sin(i * b1 + phi1) ^ n1
        wave1(i) = a3 * Y1

    Next i
    t = 0

    off = 2.5 / b2
    For i = 1 To UBound(wave1) - off

        wave2(i) = wave1(i + off)

 '
 '        t = t + tstep
 '        Y1 = a1 * Sin(w * t)
 '        wave2(i) = Y1
 '

    Next i

    'MsgBox Timer - t

 End Sub
 '-------------------------------------------------------



 Sub ini()

    ReDim wave1(1000)
    ReDim wave2(1000)

 End Sub
 '-------------------------------------------------------

 Sub main()

    Call ini
    Form1.Show

 '-------------------------------------------------------
 End Sub


 Sub make_fmt16(ByRef Fmt16 As format_16, ByRef FmtOwn As format_own)

    ' creating a 16+8 bite header from the own wave header

    Fmt16.Id = "fmt "
    Fmt16.chunkSize = 16
     'fmtown.CSize of course it should always be 16.
     'fmtown.Csize could contain an error
    Fmt16.wChannels = FmtOwn.Chan
    Fmt16.wFormatTag = 1 'fmtown.tag
    Fmt16.dwSamplesPerSec = FmtOwn.Sps
    Fmt16.dwAvgBytesPerSec = FmtOwn.Bps
    Fmt16.wBlockAlign = FmtOwn.BlA
    Fmt16.wBitsPerSample = FmtOwn.Sl

 '-------------------------------------------------------
 End Sub

 Sub make_datahead(ByRef dath As data_descriptor, ByVal Dl As Long)

    dath.Id = "data"
    dath.chunkSize = Dl

 End Sub
 '-------------------------------------------------------

 Sub make_riff(ByRef riff As riff_descriptor_4, ByVal rl As Long)

    riff.Id = "RIFF"
    riff.chunkSize = rl
    riff.typ = "WAVE"

 End Sub
 '-------------------------------------------------------


 Function open_output_file(ByVal fname$) As Long

    Dim test$
    Dim fno As Long
    Dim ll As Long

    test$ = Dir$(fname$)
    If test$ = "" Then
        'MsgBox "File does not exist!"
        'Exit Function
    Else
        Kill fname$
    End If

    fno = FreeFile
    Open fname$ For Binary As #fno
    ll = LOF(fno)

    If ll > 0 Then ' something went wrong
        MsgBox "File already exists !"
    End If

    open_output_file = fno

 '-------------------------------------------------------
 End Function

 Sub read_header(ByVal fname$)

    Dim pos As Long
    Dim exi As Long
    Dim ll As Long
    Dim Fpos As Long

    Dim fmt0 As format_own
    fmt = fmt0                 ' clearing global fmt

    test$ = Dir$(fname$)
    If test$ = "" Then
        MsgBox "File does not exist!"
        Exit Sub
    End If

    fno = FreeFile
    Open fname$ For Binary As #fno
    ll = LOF(fno)

    tst$ = Space$(20)

    pos = 1

    Do

        Get #fno, pos, TestId
         ' this will read 8 bytes, ie a descriptor and the chunksize

        'MsgBox TestId.id

        Select Case LCase(TestId.Id)

        Case "riff"

                Get #fno, pos, riff4  ' read again, but this time
                                      ' the complete riff descriptor
                pos = Seek(fno)       ' set the new position

                If LCase(riff4.typ) <> "wave" Then
                    MsgBox "unknown riff type: " + riff4.typ
                End If

        Case "fmt "

            fmt.Fpos = pos
              ' save the position at which this structure begins

            Select Case TestId.chunkSize

            Case 16
                Get #fno, pos, Fmt16    ' this is mostly the case,
                                        ' fmt20 and fmt50 are very rare
                pos = Seek(fno)         ' set the new read position
                fmt.CSize = 16          ' tell it how long it is -
                                        ' this seems stupid, but len(fmt16) <> 16
            Case 18
                Get #fno, pos, Fmt18
                pos = Seek(fno)
                fmt.CSize = 18
            Case 20
                Get #fno, pos, fmt20
                pos = Seek(fno)
                fmt.CSize = 20
            Case 50
                Get #fno, pos, fmt50
                pos = Seek(fno)
                fmt.CSize = 50
            Case Else
                MsgBox "new fmt length found!"

            End Select


        Case "data"
            Get #fno, pos, DataId
              ' one could just as well set DataId = TestId.
              ' It is read again just to use the same method in all cases.
            data_pos = pos
              ' data_pos now is the position where the data header is found.
              ' It is not the current position in file
            pos = Seek(fno)
            Exit Do
              ' once the wave data is reached, the header has beed read completely

        Case "fact"

            If TestId.chunkSize = 4 Then
                Get #fno, pos, fact4
                pos = Seek(fno)
            Else

            End If

        Case Else

            MsgBox tst$

        End Select

    Loop Until Seek(fno) > ll Or exi = 1

    Close #fno

    ' now we are filling the own header structure (fmt_own) structure

    Select Case fmt.CSize

    Case 16

        fmt.Id = Fmt16.Id
        fmt.CSize = Fmt16.chunkSize
           ' now it becomes obvious why we stored this information
        fmt.Tag = Fmt16.wFormatTag
        fmt.Chan = Fmt16.wChannels
        fmt.Sps = Fmt16.dwSamplesPerSec
        fmt.Bps = Fmt16.dwAvgBytesPerSec
        fmt.BlA = Fmt16.wBlockAlign
        fmt.Sl = Fmt16.wBitsPerSample

    Case 18

        fmt.Id = Fmt18.Id
        fmt.CSize = Fmt18.chunkSize
        fmt.Tag = Fmt18.wFormatTag
        fmt.Chan = Fmt18.wChannels
        fmt.Sps = Fmt18.dwSamplesPerSec
        fmt.Bps = Fmt18.dwAvgBytesPerSec
        fmt.BlA = Fmt18.wBlockAlign
        fmt.Sl = Fmt18.wBitsPerSample


    Case 20

        fmt.Id = fmt20.Id
        fmt.CSize = fmt20.chunkSize
        fmt.Tag = fmt20.wFormatTag
        fmt.Chan = fmt20.wChannels
        fmt.Sps = fmt20.dwSamplesPerSec
        fmt.Bps = fmt20.dwAvgBytesPerSec
        fmt.BlA = fmt20.wBlockAlign
        fmt.Sl = fmt20.wBitsPerSample

    Case 50

        fmt.Id = fmt50.Id
        fmt.CSize = fmt50.chunkSize
        fmt.Tag = fmt50.wFormatTag
        fmt.Chan = fmt50.wChannels
        fmt.Sps = fmt50.dwSamplesPerSec
        fmt.Bps = fmt50.dwAvgBytesPerSec
        fmt.BlA = fmt50.wBlockAlign
        fmt.Sl = fmt50.wBitsPerSample  ' this may be wrong

    End Select

    If fmt.Sps > 0 Then
        Sl = fmt.Bps / fmt.Sps
           ' doing this in 2 steps just to be able to follow what is going on
    End If

    Sl = (Sl / fmt.Chan) * 8
    Sl = Int(Sl)

    If fmt.Sl = 0 Then
        fmt.Sl = Sl
        MsgBox "oh"    ' hopefully this won't happen
    Else
        If fmt.Sl = Sl Then
            ' This means the information found is consistent.
            ' Believe it or not - I found cases where this
            ' was not the case. all is ok
        Else
            MsgBox "Error in calc. of sample length!"
            fmt.Sl = Sl
        End If

    End If

    fmt.Dl = DataId.chunkSize
    fmt.Dpos = pos       ' ie this is te position after the data header
    fmt.Ns = (8 * fmt.Dl) / (fmt.Sl * fmt.Chan)


 '-------------------------------------------------------
End Sub


Sub read_wave(fname$)

    Dim cnt As Long ' just a counter
    Dim test$       ' multi purpose string variable
    Dim fno As Long ' filenumber
    Dim ll As Long  ' filelength

    test$ = Dir$(fname$)
    If test$ = "" Then
        MsgBox "File does not exist!"
        Exit Sub
    End If
    cnt = 0

    ReDim wave1(fmt.Ns)
      ' Redimensioning to the number of samples per channel
    ReDim wave2(fmt.Ns)
      ' wave1 and wave2 are Global arrays

    fno = FreeFile
    Open fname$ For Binary As #fno
    ll = LOF(fno)

    Seek #fno, fmt.Dpos

    Select Case fmt.Sl

    Case 8

        Dim v1 As Byte

        Select Case fmt.Chan

        Case 1

            Do
                Get #fno, , v1
                'MsgBox v1
                cnt = cnt + 1
                wave1(cnt) = v1

            Loop Until Seek(fno) >= ll Or cnt >= fmt.Ns

        Case 2

            Do
                Get #fno, , v1
                'MsgBox v1
                cnt = cnt + 1
                wave1(cnt) = v1
                Get #fno, , v1
                wave2(cnt) = v1

            Loop Until Seek(fno) >= ll Or cnt >= fmt.Ns

        End Select

    Case 16

        Dim v2 As Integer

        Select Case fmt.Chan


        Case 1

            Do
                Get #fno, , v2
                'MsgBox v2
                cnt = cnt + 1
                wave1(cnt) = v2

            Loop Until Seek(fno) >= ll Or cnt >= fmt.Ns

        Case 2

            Do
                Get #fno, , v2
                'MsgBox v2
                cnt = cnt + 1
                wave1(cnt) = v2

                Get #fno, , v2
                wave2(cnt) = v2

            Loop Until Seek(fno) >= ll Or cnt >= fmt.Ns

        End Select



    Case 24

    Case 32

    End Select

    Close #fno

End Sub
 '-------------------------------------------------------


Function write_wave_data(ByVal fno As Long, ByVal Dpos As Long, _
   ByRef FmtOwn As format_own) As Long

    If fno = 0 Then
        MsgBox "Invalid file handle!"
        Exit Function
    End If


    cnt = 0
    t = Timer

    Seek #fno, Dpos

    Select Case FmtOwn.Sl

    Case 8

        If FmtOwn.Chan = 1 Then

            ReDim WaveByte(1 To FmtOwn.Ns) As Byte
               ' need to convert from integers to single bytes

            For i = 1 To FmtOwn.Ns
                 WaveByte(i) = wave1(i) + 127
               ' correcting the offset.
            Next i

            Put #fno, , WaveByte()

        Else

            ReDim WaveByte(1 To FmtOwn.Ns * 2) As Byte

            For i = 1 To FmtOwn.Ns
                 WaveByte(i * 2 - 1) = wave1(i) + 127
                 WaveByte(i * 2) = wave2(i) + 127
            Next i

            Put #fno, , WaveByte()

        End If

    Case 16

        If FmtOwn.Chan = 1 Then
 '            For i = 1 To FmtOwn.Ns
              ' alternative method: much slower!
 '                 Put #fno, , wave1(i)
 '            Next i

            Put #fno, , wave1()

        Else
            ReDim wave(FmtOwn.Ns * 2) As Integer
            t = Timer
            For i = 1 To FmtOwn.Ns

                j = j + 1           ' creating field with alternating channels
                wave(j) = wave1(i)  ' this is much faster than using alternating
                j = j + 1           ' put on each sample. ie 60000 samples take 2 seconds to
                wave(j) = wave2(i)  ' write on a 300Mhz Pentium

            Next i
            Put #fno, , wave()      ' this only takes 0.2 sec

        End If

    Case 24
        '    never found any of those :)
    Case 32

    End Select

    write_wave_data = Seek(fno)

End Function
 '-------------------------------------------------------

Sub write_wave_file(ByVal fname$)


    Dim fno As Long
    Dim newpos As Long

    fno = open_output_file(fname$)
    newpos = write_header(fno, fmt)
    newpos = write_wave_data(fno, newpos, fmt)

    Close #fno

 '-------------------------------------------------------
End Sub