Untitled

Einen Beep via Soundkarte erzeugen

Es ist gar nicht so schwer, einen Ton via Soundkarte zu erzeugen. Man muss nur die richtigen API-Funktionen kennen. Durch Jürgen Wenzel bin ich an eine Mappe von Erich Neuwirth gekommen, der diese Funktionen dort einsetzt. Leider ist der Code dort nicht gerade leicht nachzuvollziehen, ich habs dann auch aufgegeben. Aber ein bischen im Internet gestöbert, die KB durchsucht und ein paar Stunden rumprobiert, das wars. Wobei mir allerdings wegen CopyMemory und Co. Excel mehrfach abgeschmiert ist. XP sei's gedankt, dass dann der Rest wenigstens stabil weiterläuft.

Beispieldatei (piep.zip 16 KB)

'########################################################
'# Zum Testen über Buttonklick, oder als benutzerdefinierte Funktion
'# aufrufen! =WENN(A4>10;Piepsen(1000;1000;2);)
'########################################################

Private Sub cmbPiepsen_Click()
Dim Frequenz As Long, Dauer As Long, Form As Long
Frequenz = Range("B1")
Dauer = Range("B2")
Form = Range("B3")
Piepsen Frequenz, Dauer, Form
End Sub

'########################################################
'# In ein Modul
'########################################################

Private Declare Function waveOutReset Lib "winmm.dll" _
    (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutOpen Lib "winmm.dll" _
    (lphWaveOut As Long, ByVal uDeviceID As Long, _
    lpFormat As waveformat_tag, ByVal dwCallback As Long, _
    ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function waveOutClose Lib "winmm.dll" _
    (ByVal hWaveOut As Long) As Long
Private Declare Function waveOutPrepareHeader Lib "winmm.dll" _
    (ByVal hWaveOut As Long, ByVal lpWaveOutHdr As Long, _
    ByVal uSize As Long) As Long
Private Declare Function waveOutUnprepareHeader Lib "winmm.dll" _
    (ByVal hWaveOut As Long, ByVal lpWaveOutHdr As Long, _
    ByVal uSize As Long) As Long
Private Declare Function waveOutWrite Lib "winmm.dll" _
    (ByVal hWaveOut As Long, ByVal lpWaveOutHdr As Long, _
    ByVal uSize As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
    (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'Global Memory
Private Declare Function GlobalAlloc Lib "KERNEL32" _
    (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "KERNEL32" _
    (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "KERNEL32" _
    (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "KERNEL32" _
    (ByVal hMem As Long) As Long
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_SHARE = &H2000
Private Const WHDR_BEGINLOOP = &H4
Private Const WHDR_ENDLOOP = &H8
Private Const WAVE_ALLOWSYNC = 2
Private Const MMSYSERR_BASE = 0
Private Const WAVERR_BASE = 32
Private Const WAVE_FORMAT_QUERY = 1
Private Const WAVERR_STILLPLAYING = (WAVERR_BASE + 1)
Private Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5)
Private Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7)
Private Const WAVERR_UNPREPARED = (WAVERR_BASE + 2)
Private Const WAVE_FORMAT_PCM = 1
'Typen
Private Type waveformat_tag
    wFormatTag As Integer
    nChannels As Integer
    nSamplesPerSec As Long
    nAvgBytesPerSec As Long
    nBlockAlign As Integer
    BitsPerSample As Integer
End Type
Private Type WaveHdr
    lpData As Long
    dwBufferLength As Long
    dwBytesRecorded As Long
    dwUser As Long
    dwFlags As Long
    dwLoops As Long
    lpNext As Long
    reserved As Long
End Type
Public Function Piepsen(Tonfrequenz As Long, Tondauer As Long, Optional Kurvenart As Long)
Dim WaveF As waveformat_tag, myHeader As WaveHdr
Dim myWave As Long
Dim memHeader As Long, pmemHeader As Long
Dim memDaten As Long, pmemDaten As Long
Dim Headerlänge As Long, Datenlänge As Long
Dim Daten As String, Durchläufe As Long
Dim ret As Long, i As Long, Grad As Long
Dim Abtastrate As Long, Auflösung As Long
If (Kurvenart > 3) Or (Kurvenart < 0) Then Kurvenart = 0
Headerlänge = Len(myHeader)
If Kurvenart = 0 And Tonfrequenz <= 4000 Then 'Sinus bis ca. 4 kHz
    Datenlänge = 24: Grad = 15
    If Tonfrequenz <= 2500 Then Datenlänge = 36: Grad = 10
    If Tonfrequenz <= 1250 Then Datenlänge = 72: Grad = 5
    If Tonfrequenz <= 500 Then Datenlänge = 180: Grad = 2
    For i = 1 To Datenlänge
        Daten = Daten & Chr((Sin(i * Grad * 3.1416 / 180) + 1) * 127)
    Next
ElseIf (Kurvenart = 0) And (Tonfrequenz > 4000) Then _
    Daten = Chr(0) & Chr(255) & Chr(0) '^ Dreieck bis ca. 33 kHz
ElseIf (Kurvenart = 1) Then _
    Daten = Chr(0) & Chr(255) & Chr(0) '^ Dreieck bis ca. 33 kHz
ElseIf (Kurvenart = 2) Then _
    Daten = Chr(0) & Chr(0) & Chr(255) & Chr(255) 'Rechteck bis ca. 25 kHz
ElseIf (Kurvenart = 3) Then _
    Daten = Chr(0) & Chr(127) & Chr(255) 'Sägezahn bis ca. 33 kHz
End If
Datenlänge = Len(Daten)
Abtastrate = Tonfrequenz * Datenlänge
Durchläufe = Tonfrequenz * Tondauer / 1000
With WaveF 'Waveformat
    .wFormatTag = WAVE_FORMAT_PCM
    .nChannels = 1 'Mono
    .nBlockAlign = 1 ' 8 bit mono
    .BitsPerSample = 8 'WAVE_FORMAT_8BIT
    .nSamplesPerSec = Abtastrate
'    .nAvgBytesPerSec = Abtastrate
End With
'Open Wave
'als myWave wird ein Wavehandle zurückgegeben
waveOutOpen myWave, 0&, WaveF, 0&, 0&, WAVE_ALLOWSYNC
'Globalen Speicher für Header erzeugen
memHeader = GlobalAlloc((GMEM_MOVEABLE Or GMEM_SHARE), Headerlänge)
pmemHeader = GlobalLock(memHeader)
'Globalen Speicher für Daten erzeugen
memDaten = GlobalAlloc((GMEM_MOVEABLE Or GMEM_SHARE), Datenlänge)
pmemDaten = GlobalLock(memDaten)
'Daten in den globalen Datenbuffer
CopyMemory ByVal pmemDaten, ByVal Daten, Len(Daten)
'Header setzen
With myHeader
    .dwBufferLength = Datenlänge
    .dwFlags = (WHDR_BEGINLOOP Or WHDR_ENDLOOP)
    .dwLoops = Durchläufe
    .lpData = pmemDaten 'Pointer auf den Datenblock
End With
'Den Header in den globalen Headerblock schreiben
CopyMemory ByVal pmemHeader, myHeader.lpData, Headerlänge
'Die Tonausgabe beginnen
waveOutPrepareHeader myWave, ByVal pmemHeader, Headerlänge
waveOutWrite myWave, ByVal pmemHeader, Headerlänge
'Auf das Beenden warten
Do
  ret = waveOutUnprepareHeader(myWave, ByVal pmemHeader, Headerlänge)
Loop While ((ret = WAVERR_STILLPLAYING) And (ret <> MMSYSERR_INVALHANDLE))
'waveOutReset .hWave ' Sofort Beenden
waveOutClose myWave
GlobalUnlock memDaten: GlobalFree memDaten
GlobalUnlock memHeader: GlobalFree memHeader
End Function