如何用MSAccess VBA检测麦克风超指定分贝声音并触发事件记录时间

我之前帮朋友搞定过类似的需求——用Access VBA监听麦克风，当声音超过指定分贝时触发事件并记录时间。核心思路是调用Windows原生的音频捕获API，因为VBA本身没有内置的音频处理能力，下面是完整的实现步骤和代码：

一、核心原理 #

我们需要借助Windows的waveIn系列API来捕获麦克风的PCM音频数据，将采样值转换为分贝值后和设定的阈值对比，一旦超过就触发自定义事件，同时把检测时间写入Access数据表。

二、完整代码实现 #

首先新建一个标准模块（比如命名为modAudioDetection），把以下代码粘贴进去：

1. API声明与常量定义 #

#If VBA7 Then
    Declare PtrSafe Function waveInOpen Lib "winmm.dll" (phwi As LongPtr, ByVal uDeviceID As Long, pwfx As WAVEFORMATEX, ByVal dwCallback As LongPtr, ByVal dwInstance As LongPtr, ByVal dwFlags As Long) As Long
    Declare PtrSafe Function waveInStart Lib "winmm.dll" (ByVal hwi As LongPtr) As Long
    Declare PtrSafe Function waveInStop Lib "winmm.dll" (ByVal hwi As LongPtr) As Long
    Declare PtrSafe Function waveInClose Lib "winmm.dll" (ByVal hwi As LongPtr) As Long
    Declare PtrSafe Function waveInPrepareHeader Lib "winmm.dll" (ByVal hwi As LongPtr, pwh As WAVEHDR, ByVal cbwh As Long) As Long
    Declare PtrSafe Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hwi As LongPtr, pwh As WAVEHDR, ByVal cbwh As Long) As Long
    Declare PtrSafe Function waveInAddBuffer Lib "winmm.dll" (ByVal hwi As LongPtr, pwh As WAVEHDR, ByVal cbwh As Long) As Long
    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
    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
    Private Const WAVE_FORMAT_PCM = 1
    Private Const CALLBACK_FUNCTION = &H30000
    Private Const WHDR_DONE = &H1
    Private Const WHDR_PREPARED = &H4
    Private hWaveIn As LongPtr '音频设备句柄
#Else
    Declare Function waveInOpen Lib "winmm.dll" (phwi As Long, ByVal uDeviceID As Long, pwfx As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
    Declare Function waveInStart Lib "winmm.dll" (ByVal hwi As Long) As Long
    Declare Function waveInStop Lib "winmm.dll" (ByVal hwi As Long) As Long
    Declare Function waveInClose Lib "winmm.dll" (ByVal hwi As Long) As Long
    Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hwi As Long, pwh As WAVEHDR, ByVal cbwh As Long) As Long
    Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hwi As Long, pwh As WAVEHDR, ByVal cbwh As Long) As Long
    Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hwi As Long, pwh As WAVEHDR, ByVal cbwh As Long) As Long
    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
    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
    Private Const WAVE_FORMAT_PCM = 1
    Private Const CALLBACK_FUNCTION = &H30000
    Private Const WHDR_DONE = &H1
    Private Const WHDR_PREPARED = &H4
    Private hWaveIn As Long '音频设备句柄
#End If

'模块级变量
Private audioBuffer() As Byte
Private waveHeader As WAVEHDR
Public decibelThreshold As Double '分贝阈值，比如设置为60
Private isMonitoring As Boolean

2. 初始化音频捕获 #

Public Sub InitializeAudioCapture()
    Dim waveFormat As WAVEFORMATEX
    Dim result As Long
    
    '设置音频格式：16位单声道，44100Hz采样率
    With waveFormat
        .wFormatTag = WAVE_FORMAT_PCM
        .nChannels = 1
        .nSamplesPerSec = 44100
        .wBitsPerSample = 16
        .nBlockAlign = .nChannels * (.wBitsPerSample \ 8)
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
        .cbSize = 0
    End With
    
    '打开默认音频输入设备（麦克风）
#If VBA7 Then
    result = waveInOpen(hWaveIn, 0, waveFormat, AddressOf WaveInProc, 0, CALLBACK_FUNCTION)
#Else
    result = waveInOpen(hWaveIn, 0, waveFormat, AddressOf WaveInProc, 0, CALLBACK_FUNCTION)
#End If
    If result <> 0 Then
        MsgBox "无法打开麦克风设备，错误代码：" & result, vbCritical
        Exit Sub
    End If
    
    '初始化音频缓冲区（4096字节，可根据需求调整）
    ReDim audioBuffer(4095) As Byte
#If VBA7 Then
    waveHeader.lpData = VarPtr(audioBuffer(0))
#Else
    waveHeader.lpData = VarPtr(audioBuffer(0))
#End If
    waveHeader.dwBufferLength = UBound(audioBuffer) + 1
    waveHeader.dwFlags = 0
    
    '准备缓冲区
    result = waveInPrepareHeader(hWaveIn, waveHeader, Len(waveHeader))
    If result <> 0 Then
        MsgBox "无法准备音频缓冲区，错误代码：" & result, vbCritical
        waveInClose hWaveIn
        Exit Sub
    End If
    
    '添加缓冲区到音频设备
    result = waveInAddBuffer(hWaveIn, waveHeader, Len(waveHeader))
    If result <> 0 Then
        MsgBox "无法添加音频缓冲区，错误代码：" & result, vbCritical
        waveInUnprepareHeader hWaveIn, waveHeader, Len(waveHeader)
        waveInClose hWaveIn
        Exit Sub
    End If
    
    isMonitoring = False
    decibelThreshold = 60 '默认阈值，可在窗体中设置
End Sub

3. 音频回调函数（核心处理逻辑） #

#If VBA7 Then
Private Sub WaveInProc(ByVal hwi As LongPtr, ByVal uMsg As Long, ByVal dwInstance As LongPtr, ByVal dwParam1 As LongPtr, ByVal dwParam2 As LongPtr)
#Else
Private Sub WaveInProc(ByVal hwi As Long, ByVal uMsg As Long, ByVal dwInstance As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long)
#End If
    Dim currentDecibel As Double
    Dim sampleValue As Integer
    Dim maxSample As Double
    Dim i As Long
    
    If uMsg = &H3BE Then 'WIM_DATA：收到音频数据
        '计算当前缓冲区的平均分贝
        maxSample = 0
        For i = 0 To waveHeader.dwBytesRecorded - 1 Step 2
            '16位PCM采样，每2字节一个样本
            sampleValue = (audioBuffer(i + 1) * 256) + audioBuffer(i)
            '处理负数（16位有符号数）
            If sampleValue > 32767 Then sampleValue = sampleValue - 65536
            maxSample = max(maxSample, Abs(sampleValue))
        Next i
        
        '计算分贝：dB = 20 * log10(采样值/最大采样值)，16位最大采样值是32767
        If maxSample > 0 Then
            currentDecibel = 20 * Log(maxSample / 32767) / Log(10)
            '转换为正数（因为通常分贝是相对于基准的正值）
            currentDecibel = Abs(currentDecibel)
            
            '如果超过阈值，触发事件并记录时间
            If currentDecibel >= decibelThreshold And isMonitoring Then
                SoundDetected currentDecibel
            End If
        End If
        
        '重新添加缓冲区，继续捕获
        waveInAddBuffer hWaveIn, waveHeader, Len(waveHeader)
    End If
End Sub

4. 自定义触发事件（记录时间） #

Private Sub SoundDetected(decibel As Double)
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    '假设你有一个名为SoundLog的数据表，字段：LogID(自动编号), DetectTime(日期/时间), Decibel(数字)
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("SoundLog", dbOpenDynaset)
    
    rs.AddNew
    rs!DetectTime = Now()
    rs!Decibel = Round(decibel, 1)
    rs.Update
    
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    
    '这里可以添加其他触发逻辑，比如弹出提示、执行其他VBA过程等
    'MsgBox "检测到超过阈值的声音！分贝值：" & Round(decibel, 1)
End Sub

5. 启停控制与资源清理 #

Public Sub StartDetection()
    If Not isMonitoring Then
        waveInStart hWaveIn
        isMonitoring = True
        MsgBox "开始监听麦克风..."
    End If
End Sub

Public Sub StopDetection()
    If isMonitoring Then
        waveInStop hWaveIn
        isMonitoring = False
        MsgBox "停止监听麦克风..."
    End If
End Sub

Public Sub CleanupAudioCapture()
    If hWaveIn <> 0 Then
        StopDetection
        waveInUnprepareHeader hWaveIn, waveHeader, Len(waveHeader)
        waveInClose hWaveIn
        hWaveIn = 0
    End If
End Sub

三、使用方法 #

1. 在Access中创建一个名为SoundLog的数据表，字段设置如下：
   • LogID：自动编号，主键
   • DetectTime：日期/时间类型
   • Decibel：数字类型（单精度或双精度）
2. 新建一个窗体，添加两个按钮：btnStart和btnStop，分别绑定点击事件：

   Private Sub btnStart_Click()
       '初始化（第一次点击时执行，之后可以跳过）
       If hWaveIn = 0 Then
           InitializeAudioCapture
       End If
       StartDetection
   End Sub
   
   Private Sub btnStop_Click()
       StopDetection
   End Sub
   
   Private Sub Form_Unload(Cancel As Integer)
       '窗体关闭时清理资源
       CleanupAudioCapture
   End Sub
   

3. 调整分贝阈值：可以在窗体中添加一个文本框txtThreshold，修改InitializeAudioCapture中的decibelThreshold = CDbl(txtThreshold.Value)，或者直接在代码中修改默认值。

四、注意事项 #

• 兼容性：代码同时支持32位和64位Access，通过#If VBA7 Then区分指针类型。
• 权限问题：确保Access的信任中心允许运行VBA代码，否则API调用会被阻止（文件->选项->信任中心->信任中心设置->宏设置）。
• 缓冲区大小：如果监听延迟过高，可以减小缓冲区大小；如果频繁触发回调，可适当增大。
• 阈值校准：建议在使用环境中先测试安静状态下的分贝值，再调整阈值，避免误触发或漏触发。

内容的提问来源于stack exchange，提问作者b06rsw