Option Explicit

' ============================================================
' SCHNELLER PCM AUDIO PLAYER
'
' 96.000 Hz
' 24 Bit
' Mono
'
' Excel:
'   Blatt "Audio"
'   A2:A48001 = 48.000 Samples
'
' 48.000 Samples / 96.000 Hz = 0,5 Sekunden
'
' 12 Wiederholungen = 6 Sekunden
'
' Letzte Wiederholung:
'   100 % -> 0 % Fade-Out
'
' Device 0
' ============================================================


#If VBA7 Then

    Private Declare PtrSafe Function waveOutOpen Lib "winmm.dll" ( _
        lphwo As LongPtr, _
        ByVal uDeviceID As Long, _
        lpFormat As WAVEFORMATEX, _
        ByVal dwCallback As LongPtr, _
        ByVal dwInstance As LongPtr, _
        ByVal dwFlags As Long) As Long

    Private Declare PtrSafe Function waveOutPrepareHeader Lib "winmm.dll" ( _
        ByVal hwo As LongPtr, _
        lpWaveHdr As WAVEHDR, _
        ByVal uSize As Long) As Long

    Private Declare PtrSafe Function waveOutWrite Lib "winmm.dll" ( _
        ByVal hwo As LongPtr, _
        lpWaveHdr As WAVEHDR, _
        ByVal uSize As Long) As Long

    Private Declare PtrSafe Function waveOutReset Lib "winmm.dll" ( _
        ByVal hwo As LongPtr) As Long

    Private Declare PtrSafe Function waveOutUnprepareHeader Lib "winmm.dll" ( _
        ByVal hwo As LongPtr, _
        lpWaveHdr As WAVEHDR, _
        ByVal uSize As Long) As Long

    Private Declare PtrSafe Function waveOutClose Lib "winmm.dll" ( _
        ByVal hwo As LongPtr) As Long

    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" ( _
        ByVal uFlags As Long, _
        ByVal dwBytes As LongPtr) As LongPtr

    Private Declare PtrSafe Function GlobalFree Lib "kernel32" ( _
        ByVal hMem As LongPtr) As LongPtr

    Private Declare PtrSafe Function GlobalLock Lib "kernel32" ( _
        ByVal hMem As LongPtr) As LongPtr

    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" ( _
        ByVal hMem As LongPtr) As Long

    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        ByVal Destination As LongPtr, _
        ByRef Source As Any, _
        ByVal Length As LongPtr)

#End If


' ============================================================
' EINSTELLUNGEN
' ============================================================

Private Const DEVICE_ID As Long = 0

Private Const SAMPLE_RATE As Long = 96000

Private Const BITS_PER_SAMPLE As Long = 24

Private Const CHANNELS As Long = 1

Private Const BYTES_PER_SAMPLE As Long = 3

Private Const SAMPLE_COUNT As Long = 48000

Private Const LOOP_COUNT As Long = 12

Private Const PLAY_TIME As Double = 6#


' ============================================================
' WINDOWS-KONSTANTEN
' ============================================================

Private Const WAVE_FORMAT_PCM As Integer = 1

Private Const GMEM_MOVEABLE As Long = &H2

Private Const GMEM_ZEROINIT As Long = &H40


' ============================================================
' WAVEFORMATEX
' ============================================================

Private Type WAVEFORMATEX

    wFormatTag As Integer

    nChannels As Integer

    nSamplesPerSec As Long

    nAvgBytesPerSec As Long

    nBlockAlign As Integer

    wBitsPerSample As Integer

    cbSize As Integer

End Type


' ============================================================
' WAVEHDR
' ============================================================

Private Type WAVEHDR

    lpData As LongPtr

    dwBufferLength As Long

    dwBytesRecorded As Long

    dwUser As LongPtr

    dwFlags As Long

    dwLoops As Long

    lpNext As LongPtr

    Reserved As LongPtr

End Type


' ============================================================
' GLOBALE VARIABLEN
' ============================================================

Private g_hWave As LongPtr

Private g_hMem As LongPtr

Private g_pMem As LongPtr

Private g_Header As WAVEHDR

Private g_Playing As Boolean

Private g_HeaderPrepared As Boolean


' ============================================================
' START
' ============================================================

Public Sub PCM_Start_4Sekunden()

    Dim ws As Worksheet

    Dim i As Long
    Dim rep As Long

    Dim value As Double
    Dim sample As Long

    Dim sampleValues() As Long

    Dim oneWave() As Byte
    Dim fullBuffer() As Byte

    Dim oneWaveBytes As Long
    Dim totalBytes As Long

    Dim sourcePos As Long
    Dim destPos As Long

    Dim fadeFactor As Double
    Dim fadedSample As Double

    Dim fmt As WAVEFORMATEX

    Dim result As Long

    Dim startTime As Double
    Dim elapsed As Double


    On Error GoTo Fehler


    ' ========================================================
    ' EVENTUELLE WIEDERGABE STOPPEN
    ' ========================================================

    If g_Playing Then

        PCM_Stop

    End If


    ' ========================================================
    ' EXCEL-BLATT
    ' ========================================================

    Set ws = ThisWorkbook.Worksheets("Audio")


    If ws.Cells(ws.Rows.count, 1).End(xlUp).Row < 48001 Then

        MsgBox _
            "Es werden 48.000 Samples benötigt." & vbCrLf & _
            "Erwarteter Bereich: A2:A48001", _
            vbExclamation

        Exit Sub

    End If


    ' ========================================================
    ' GRÖSSEN
    ' ========================================================

    oneWaveBytes = _
        SAMPLE_COUNT * BYTES_PER_SAMPLE


    totalBytes = _
        oneWaveBytes * LOOP_COUNT


    ' ========================================================
    ' SAMPLE-ARRAY
    '
    ' Excel wird nur EINMAL gelesen.
    ' ========================================================

    ReDim sampleValues(0 To SAMPLE_COUNT - 1)


    For i = 0 To SAMPLE_COUNT - 1


        If Not IsNumeric(ws.Cells(i + 2, 1).value) Then

            MsgBox _
                "Ungültiger Wert in A" & _
                (i + 2), _
                vbCritical

            Exit Sub

        End If


        value = _
            CDbl(ws.Cells(i + 2, 1).value)


        If value < -8388608# Or _
           value > 8388607# Then

            MsgBox _
                "Wert außerhalb des 24-Bit-Bereichs:" & _
                vbCrLf & _
                "A" & (i + 2) & _
                " = " & CStr(value), _
                vbCritical

            Exit Sub

        End If


        sampleValues(i) = CLng(value)


    Next i


    ' ========================================================
    ' EINE NORMALE 0,5-SEKUNDEN-WELLE ERZEUGEN
    ' ========================================================

    ReDim oneWave(0 To oneWaveBytes - 1)


    For i = 0 To SAMPLE_COUNT - 1


        sample = sampleValues(i)


        If sample < 0 Then

            sample = sample + 16777216

        End If


        sourcePos = i * 3


        oneWave(sourcePos) = _
            sample And &HFF


        oneWave(sourcePos + 1) = _
            (sample \ 256) And &HFF


        oneWave(sourcePos + 2) = _
            (sample \ 65536) And &HFF


    Next i


    ' ========================================================
    ' GESAMTEN 6-SEKUNDEN-PUFFER ERZEUGEN
    '
    ' Wiederholungen 1-11:
    '       unverändert
    '
    ' Wiederholung 12:
    '       100 % -> 0 %
    ' ========================================================

    ReDim fullBuffer(0 To totalBytes - 1)


    destPos = 0


    ' ========================================================
    ' WIEDERHOLUNGEN 1-11
    ' ========================================================

    For rep = 1 To LOOP_COUNT - 1


        CopyMemory _
            VarPtr(fullBuffer(destPos)), _
            oneWave(0), _
            oneWaveBytes


        destPos = _
            destPos + oneWaveBytes


    Next rep


    ' ========================================================
    ' LETZTE WIEDERHOLUNG MIT FADE-OUT
    ' ========================================================

    For i = 0 To SAMPLE_COUNT - 1


        ' ----------------------------------------------------
        ' Fade-Faktor:
        '
        ' Anfang = 1,0
        ' Ende   = 0,0
        ' ----------------------------------------------------

        fadeFactor = _
            1# - _
            (CDbl(i) / _
             CDbl(SAMPLE_COUNT - 1))


        fadedSample = _
            CDbl(sampleValues(i)) * _
            fadeFactor


        ' ----------------------------------------------------
        ' RUNDEN
        ' ----------------------------------------------------

        If fadedSample >= 0 Then

            sample = _
                CLng(fadedSample + 0.5)

        Else

            sample = _
                CLng(fadedSample - 0.5)

        End If


        ' ----------------------------------------------------
        ' SICHERHEIT
        ' ----------------------------------------------------

        If sample > 8388607 Then

            sample = 8388607

        ElseIf sample < -8388608 Then

            sample = -8388608

        End If


        ' ----------------------------------------------------
        ' 24-BIT-ZWEIERKOMPLEMENT
        ' ----------------------------------------------------

        If sample < 0 Then

            sample = sample + 16777216

        End If


        sourcePos = i * 3


        ' ----------------------------------------------------
        ' LITTLE ENDIAN
        ' ----------------------------------------------------

        fullBuffer(destPos + sourcePos) = _
            sample And &HFF


        fullBuffer(destPos + sourcePos + 1) = _
            (sample \ 256) And &HFF


        fullBuffer(destPos + sourcePos + 2) = _
            (sample \ 65536) And &HFF


    Next i


    ' ========================================================
    ' NICHT MEHR BENÖTIGT
    ' ========================================================

    Erase oneWave

    Erase sampleValues


    ' ========================================================
    ' AUDIOFORMAT
    ' ========================================================

    With fmt

        .wFormatTag = WAVE_FORMAT_PCM

        .nChannels = CHANNELS

        .nSamplesPerSec = SAMPLE_RATE

        .nBlockAlign = _
            BYTES_PER_SAMPLE

        .nAvgBytesPerSec = _
            SAMPLE_RATE * BYTES_PER_SAMPLE

        .wBitsPerSample = _
            BITS_PER_SAMPLE

        .cbSize = 0

    End With


    ' ========================================================
    ' WINDOWS-SPEICHER
    ' ========================================================

    g_hMem = GlobalAlloc( _
                GMEM_MOVEABLE Or GMEM_ZEROINIT, _
                totalBytes)


    If g_hMem = 0 Then

        MsgBox _
            "Speicher konnte nicht reserviert werden.", _
            vbCritical

        Exit Sub

    End If


    ' ========================================================
    ' SPEICHER SPERREN
    ' ========================================================

    g_pMem = GlobalLock(g_hMem)


    If g_pMem = 0 Then

        GlobalFree g_hMem

        g_hMem = 0

        MsgBox _
            "Speicher konnte nicht gesperrt werden.", _
            vbCritical

        Exit Sub

    End If


    ' ========================================================
    ' EIN EINZIGER GROSSER COPY
    ' ========================================================

    CopyMemory _
        g_pMem, _
        fullBuffer(0), _
        totalBytes


    Erase fullBuffer


    ' ========================================================
    ' DEVICE 0 ÖFFNEN
    ' ========================================================

    result = waveOutOpen( _
                g_hWave, _
                DEVICE_ID, _
                fmt, _
                0, _
                0, _
                0)


    If result <> 0 Then

        PCM_Cleanup

        MsgBox _
            "Device 0 konnte nicht geöffnet werden." & _
            vbCrLf & _
            "Fehlercode: " & result, _
            vbCritical

        Exit Sub

    End If


    ' ========================================================
    ' WAVE HEADER
    ' ========================================================

    g_Header.lpData = g_pMem

    g_Header.dwBufferLength = _
        totalBytes

    g_Header.dwBytesRecorded = _
        totalBytes

    g_Header.dwUser = 0

    g_Header.dwFlags = 0

    g_Header.dwLoops = 0

    g_Header.lpNext = 0

    g_Header.Reserved = 0


    ' ========================================================
    ' HEADER VORBEREITEN
    ' ========================================================

    result = waveOutPrepareHeader( _
                g_hWave, _
                g_Header, _
                LenB(g_Header))


    If result <> 0 Then

        PCM_Cleanup

        MsgBox _
            "waveOutPrepareHeader Fehler: " & _
            result, _
            vbCritical

        Exit Sub

    End If


    g_HeaderPrepared = True


    ' ========================================================
    ' AUDIO STARTEN
    ' ========================================================

    result = waveOutWrite( _
                g_hWave, _
                g_Header, _
                LenB(g_Header))


    If result <> 0 Then

        PCM_Cleanup

        MsgBox _
            "waveOutWrite Fehler: " & _
            result, _
            vbCritical

        Exit Sub

    End If


    g_Playing = True


    Application.StatusBar = _
        "PCM läuft | 96 kHz / 24 Bit | " & _
        "48.000 Samples × 12 | " & _
        "6 Sekunden | Fade-Out"


    ' ========================================================
    ' WARTEN
    '
    ' DoEvents hält Excel bedienbar.
    ' ========================================================

    startTime = Timer


    Do While g_Playing


        DoEvents


        elapsed = _
            Timer - startTime


        If elapsed < 0 Then

            elapsed = _
                elapsed + 86400#

        End If


        If elapsed >= PLAY_TIME Then

            Exit Do

        End If


    Loop


    ' ========================================================
    ' NORMALER STOP
    ' ========================================================

    PCM_Stop


    Exit Sub


' ============================================================
' FEHLER
' ============================================================

Fehler:


    PCM_Stop


    MsgBox _
        "Fehler:" & _
        vbCrLf & vbCrLf & _
        Err.Number & " - " & _
        Err.Description, _
        vbCritical

End Sub


' ============================================================
' STOP
' ============================================================

Public Sub PCM_Stop()


    On Error Resume Next


    g_Playing = False


    If g_hWave <> 0 Then


        waveOutReset _
            g_hWave


        If g_HeaderPrepared Then

            waveOutUnprepareHeader _
                g_hWave, _
                g_Header, _
                LenB(g_Header)

        End If


        waveOutClose _
            g_hWave


        g_hWave = 0

        g_HeaderPrepared = False


    End If


    If g_hMem <> 0 Then


        If g_pMem <> 0 Then

            GlobalUnlock _
                g_hMem

        End If


        GlobalFree _
            g_hMem


        g_hMem = 0

        g_pMem = 0


    End If


    Application.StatusBar = False


End Sub


' ============================================================
' CLEANUP
' ============================================================

Private Sub PCM_Cleanup()


    On Error Resume Next


    g_Playing = False


    If g_hWave <> 0 Then


        waveOutReset _
            g_hWave


        If g_HeaderPrepared Then

            waveOutUnprepareHeader _
                g_hWave, _
                g_Header, _
                LenB(g_Header)

        End If


        waveOutClose _
            g_hWave


        g_hWave = 0

        g_HeaderPrepared = False


    End If


    If g_hMem <> 0 Then


        If g_pMem <> 0 Then

            GlobalUnlock _
                g_hMem

        End If


        GlobalFree _
            g_hMem


        g_hMem = 0

        g_pMem = 0


    End If


End Sub