Sorry your browser is not supported!

Option Explicit

'MR 15.05.2007 erstellt

'Freq = 10975.1491723152 - 1 'Calcium
'Freq = 13718.936465394 - 1 'Sauerstoff

Dim Header() As Byte
Dim PosH As Long

Public Wave() As Byte
Public PosW As Long
'

Private Static Sub AddByteH(ByVal b As Byte)
 
 ReDim Preserve Header(PosH)
 Header(PosH) = b
 
 PosH = PosH + 1

End Sub

Private Static Sub AddByteW(ByVal b As Byte)
 
 ReDim Preserve Wave(PosW)
 Wave(PosW) = b
 
 PosW = PosW + 1

End Sub

Public Sub SaveWave(ByVal Sek As Double, ByVal Freq_Von As Double, ByVal Freq_Bis As Double, ByVal Freq_Add As Double, ByVal Freq_Von_Vol As Double, ByVal Freq_Add_Vol As Double)

 PosH = 0
 ReDim Header(PosH)
  
 PosW = 0
 ReDim Wave(PosW)
  
 Dim a As Byte, b As Byte, c As Byte, d As Byte 'Byte |
 Dim L As Long
  
 '------------------------------------------------------------------------------ Wave Daten
 
 Dim ChLeft As Double, ChRight As Double
 Dim S As Double 'für Zeit
 Dim w As Double 'für Winkel
 Dim w1 As Double 'für Pegel
 Dim F As Long 'für Schleife
 
 'Print 176400 / 4
 '44100
 
 ChLeft = 0
 ChRight = 0
 
 Dim Freq As Double
 Freq = Freq_Von
 
 Dim FreqDif As Double
 FreqDif = (Freq_Bis - Freq_Von) / (Sek * 44100#)
 'FreqDif = Round(FreqDif, 6) 'ohne ist genauer
   
 'Wird in der Maske aufgeteilt
 Freq_Von_Vol = Freq_Von_Vol * 32767#
 Freq_Add_Vol = Freq_Add_Vol * 32767#

 Debug.Print "Start Frequenz = " & Freq
  
 Dim Pi2 As Double
 Pi2 = 3.14159265359 * 2#
  
 w = 0#
 For S = 1 To Sek
 'w = 0#
 
 For F = 0 To 44100 - 1 '=1 Sek.
  
   'Max 65536/2 = Max Pegel in der Wave Datei
   'w = (f / 44099#) * Pi2 '= 0-1 * 2Pi
   'w = (F * Pi2) / 44100# ' 44099#
   
   w1 = Sin(w * Freq) * Freq_Von_Vol
    
   'Zusatz Frequenz
   If Freq_Add <> 0 Then
    w1 = w1 + Sin(w * Freq_Add) * Freq_Add_Vol
   End If
      
   ChLeft = w1
   ChRight = w1
   
   '4 Bytes pro Sample
   'a = 0: b = 0
   BytesFromInt CInt(ChLeft), a, b
   AddByteW a
   AddByteW b
   'a = 0: b = 0
   BytesFromInt CInt(ChRight), a, b
   AddByteW a
   AddByteW b
 
   If FreqDif Then Freq = Freq + FreqDif

   w = w + 1.42475857305669E-04  'in 44100 Schritten auf 360 Grad bzw. 2Pi

 Next
 Next
 
 Debug.Print "End Frequenz = " & Freq
 
 '------------------------------------------------------------------------------
 
  AddByteH Asc("R")
  AddByteH Asc("I")
  AddByteH Asc("F")
  AddByteH Asc("F")
    
  'Länge Sample + Header
  L = (UBound(Wave) + 1) + 44
  BytesFromLong L, a, b, c, d
  AddByteH a
  AddByteH b
  AddByteH c
  AddByteH d
  
  'WAVE
  AddByteH Asc("W")
  AddByteH Asc("A")
  AddByteH Asc("V")
  AddByteH Asc("E")
  
  'fmt
  AddByteH Asc("f")
  AddByteH Asc("m")
  AddByteH Asc("t")
  AddByteH Asc(" ")
  
  'länge Sub Chunk
  AddByteH 16 'in Bytes
  AddByteH 0
  AddByteH 0
  AddByteH 0
  
  'format
  AddByteH 1
  AddByteH 0
  
  'Modus
  AddByteH 2
  AddByteH 0
  
  'Trägerfrequenz 44100
  L = 44100
  BytesFromLong L, a, b, c, d
  AddByteH a
  AddByteH b
  AddByteH c
  AddByteH d
  
  'bytes per second
  L = 176400
  BytesFromLong L, a, b, c, d
  AddByteH a
  AddByteH b
  AddByteH c
  AddByteH d
  
  'wav_bytes_per_sample&
  AddByteH 4
  AddByteH 0
  
  'wav_bites_per_sample&
  AddByteH 16
  AddByteH 0
    
  '---------------------------
  
  'data
  AddByteH Asc("d")
  AddByteH Asc("a")
  AddByteH Asc("t")
  AddByteH Asc("a")
  
  'Datenlänge in Bytes
  L = (UBound(Wave) + 1) '3 Sek. = 529200 (44100 Hz * 3 Sek. * 4 Bytes)
  BytesFromLong L, a, b, c, d
  AddByteH a
  AddByteH b
  AddByteH c
  AddByteH d
  'data
  '...
 
 '------------------------------------------------------------------------------ Dateiname erzeugen
 
 Dim n$
 n$ = App.Path & "\Freq"
 If Freq_Von <> Freq_Bis Then n$ = n$ & " von"
 n$ = n$ & " " & RoundStr(Freq_Von, 3)
 If Freq_Von <> Freq_Bis Then n$ = n$ & " bis " & RoundStr(Freq_Bis, 3)
 If Freq_Add <> 0 Then n$ = n$ & " + " & RoundStr(Freq_Add, 3)
 n$ = n$ & " Zeit " & Sek & " Sek.wav"
 
 If Len(FileName$) > 0 Then n$ = FileName$
 
 '------------------------------------------------------------------------------ Datei wenn da löschen wegen Open Binary
 
 On Error Resume Next
 Kill n$
 On Error GoTo 0
 
 '------------------------------------------------------------------------------ Kopieren in 1 Array
   
' L = (UBound(Header) + 1) + (UBound(Wave) + 1) - 1
' Dim Gesamt() As Byte
' ReDim Gesamt(L)
'
' L = 0
' For f = LBound(Header) To UBound(Header)
'  Gesamt(L) = Header(f)
'  L = L + 1
' Next
' For f = LBound(Wave) To UBound(Wave)
'  Gesamt(L) = Wave(f)
'  L = L + 1
' Next
' ReDim Wave(0)
   
 '------------------------------------------------------------------------------
   
 Dim ff As Integer
 ff = FreeFile
   
 Open n$ For Binary As #ff
  Put #ff, , Header()
  Put #ff, , Wave()
  'Put #ff, , Gesamt()
 Close #ff
  
 '------------------------------------------------------------------------------
  
 Fm_Wave.cmd_WaveCreate.ToolTipText = "Zuletzt wurde die Datei gespeichert als " & n$
  
 Debug.Print "Fertig"
  
End Sub

Private Function RoundStr(ByVal x As Double, ByVal DezimalStellen As Long) As String

 RoundStr = Round(x, DezimalStellen)
 RoundStr = Replace$(RoundStr, ".", ",")

End Function

Private Static Sub BytesFromLong(ByVal L As Long, ByRef Byte0 As Byte, ByRef Byte1 As Byte, ByRef Byte2 As Byte, ByRef Byte3 As Byte)

 Byte0 = L And &HFF
 Byte1 = L \ &H100 And &HFF
 Byte2 = L \ &H10000 And &HFF
 Byte3 = L \ &H1000000 And &HFF

End Sub

Private Static Sub BytesFromInt(ByVal i As Integer, ByRef Byte0 As Byte, ByRef Byte1 As Byte)

 Byte0 = i And &HFF
 Byte1 = i \ &H100 And &HFF

End Sub