Снять информацию с MicIn

[cg_ck]

Есть такие програмы, для настройки электро гитары. А она как известно подключается к микрофонному входу, и суть такой программы, что она видит частоту колебаний струны и сапоставляет её с нотой. Как можно посмотреть частоту колебания струны в VB?

[Amed]

В API-Guide есть пример чтения сигнала из разных входов... В категории Sound...

[Amed]

Код: Выделить всё

'This project needs a module and a form
'The form must contain two labels, two progressbars, a timer and a checkbox

'Paste this code into the form
Dim hmixer As Long                  ' mixer handle
Dim inputVolCtrl As MIXERCONTROL    ' waveout volume control
Dim outputVolCtrl As MIXERCONTROL   ' microphone volume control
Dim rc As Long                      ' return code
Dim ok As Boolean                   ' boolean return code

Dim mxcd As MIXERCONTROLDETAILS         ' control info
Dim vol As MIXERCONTROLDETAILS_SIGNED   ' control's signed value
Dim volume As Long                      ' volume value
Dim volHmem As Long                     ' handle to volume memory
Private Sub Form_Load()
   'KPD-Team 1999
   'URL: http://www.allapi.net/
   'E-Mail: KPDTeam@Allapi.net
   Me.ScaleMode = vbTwips
   Me.Caption = "Volume meter"
   Label1.Move 0, 0
   Label1.AutoSize = True
   Label1.Caption = "Input level"
   Label2.Move 0, 4 * Label1.Height
   Label2.AutoSize = True
   Label2.Caption = "Output level"
   ProgressBar1.Move Label1.Width * 2, 0, 3375
   ProgressBar2.Move Label1.Width * 2, Label2.Top, 3375
   Check1.Move ProgressBar1.Left, ProgressBar1.Height
   Check1.Caption = "Get Input"
   Me.Move Me.Left, Me.Top, ProgressBar1.Width + ProgressBar1.Left + 10 * Screen.TwipsPerPixelX, ProgressBar2.Top + ProgressBar2.Height + 30 * Screen.TwipsPerPixelY
   Timer1.Interval = 50
   Timer1.Enabled = True

   ' Open the mixer specified by DEVICEID
   rc = mixerOpen(hmixer, DEVICEID, 0, 0, 0)

   If ((MMSYSERR_NOERROR <> rc)) Then
       MsgBox "Couldn't open the mixer."
       Exit Sub
   End If

   ' Get the input volume meter
   ok = GetControl(hmixer, MIXERLINE_COMPONENTTYPE_DST_WAVEIN, MIXERCONTROL_CONTROLTYPE_PEAKMETER, inputVolCtrl)

   If (ok <> True) Then
       ok = GetControl(hmixer, MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE, MIXERCONTROL_CONTROLTYPE_PEAKMETER, inputVolCtrl)
   End If

   If (ok = True) Then
      ProgressBar1.Min = 0
      ProgressBar1.Max = inputVolCtrl.lMaximum
   Else
      ProgressBar1.Enabled = False
      MsgBox "Couldn't get wavein meter"
   End If

   ' Get the output volume meter
   ok = GetControl(hmixer, MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT, MIXERCONTROL_CONTROLTYPE_PEAKMETER, outputVolCtrl)

   If (ok = True) Then
      ProgressBar2.Min = 0
      ProgressBar2.Max = outputVolCtrl.lMaximum
   Else
      ProgressBar2.Enabled = False
      MsgBox "Couldn't get waveout meter"
   End If

   ' Initialize mixercontrol structure
   mxcd.cbStruct = Len(mxcd)
   volHmem = GlobalAlloc(&H0, Len(volume))  ' Allocate a buffer for the volume value
   mxcd.paDetails = GlobalLock(volHmem)
   mxcd.cbDetails = Len(volume)
   mxcd.cChannels = 1

End Sub
Private Sub Check1_Click()
   If (Check1.Value = 1) Then
      StartInput  ' Start receiving audio input
   Else
      StopInput   ' Stop receiving audio input
   End If
End Sub
Private Sub Timer1_Timer()

   On Error Resume Next

   ' Process sound buffer if recording
   If (fRecording) Then
      For i = 0 To (NUM_BUFFERS - 1)
         If inHdr(i).dwFlags And WHDR_DONE Then
            rc = waveInAddBuffer(hWaveIn, inHdr(i), Len(inHdr(i)))
         End If
      Next
   End If

   ' Get the current input level
   If (ProgressBar1.Enabled = True) Then
      mxcd.dwControlID = inputVolCtrl.dwControlID
      mxcd.item = inputVolCtrl.cMultipleItems
      rc = mixerGetControlDetails(hmixer, mxcd, MIXER_GETCONTROLDETAILSF_VALUE)
      CopyStructFromPtr volume, mxcd.paDetails, Len(volume)
      If (volume < 0) Then
         volume = -volume
         End If
      ProgressBar1.Value = volume
   End If

   ' Get the current output level
   If (ProgressBar2.Enabled = True) Then
      mxcd.dwControlID = outputVolCtrl.dwControlID
      mxcd.item = outputVolCtrl.cMultipleItems
      rc = mixerGetControlDetails(hmixer, mxcd, MIXER_GETCONTROLDETAILSF_VALUE)
      CopyStructFromPtr volume, mxcd.paDetails, Len(volume)

      If (volume < 0) Then volume = -volume

      ProgressBar2.Value = volume
   End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
   If (fRecording = True) Then
       StopInput
   End If
   GlobalFree volHmem
End Sub

'Paste this code into the module
Public Const CALLBACK_FUNCTION = &H30000
Public Const MM_WIM_DATA = &H3C0
Public Const WHDR_DONE = &H1         '  done bit
Public Const GMEM_FIXED = &H0         ' Global Memory Flag used by GlobalAlloc functin

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
Type WAVEINCAPS
   wMid As Integer
   wPid As Integer
   vDriverVersion As Long
   szPname As String * 32
   dwFormats As Long
   wChannels As Integer
End Type
Type WAVEFORMAT
   wFormatTag As Integer
   nChannels As Integer
   nSamplesPerSec As Long
   nAvgBytesPerSec As Long
   nBlockAlign As Integer
   wBitsPerSample As Integer
   cbSize As Integer
End Type

Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMAT, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Declare Function waveInGetDevCaps Lib "winmm.dll" Alias "waveInGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEINCAPS, ByVal uSize As Long) As Long
Declare Function waveInGetNumDevs Lib "winmm.dll" () As Long
Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long

Public Const MMSYSERR_NOERROR = 0
Public Const MAXPNAMELEN = 32

Public Const MIXER_LONG_NAME_CHARS = 64
Public Const MIXER_SHORT_NAME_CHARS = 16
Public Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
Public Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
Public Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&

Public Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
Public Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000&
Public Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
Public Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
Public Const MIXERLINE_COMPONENTTYPE_SRC_LINE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)

Public Const MIXERCONTROL_CT_CLASS_FADER = &H50000000
Public Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000
Public Const MIXERCONTROL_CT_UNITS_SIGNED = &H20000
Public Const MIXERCONTROL_CT_CLASS_METER = &H10000000
Public Const MIXERCONTROL_CT_SC_METER_POLLED = &H0&
Public Const MIXERCONTROL_CONTROLTYPE_FADER = (MIXERCONTROL_CT_CLASS_FADER Or MIXERCONTROL_CT_UNITS_UNSIGNED)
Public Const MIXERCONTROL_CONTROLTYPE_VOLUME = (MIXERCONTROL_CONTROLTYPE_FADER + 1)
Public Const MIXERLINE_COMPONENTTYPE_DST_WAVEIN = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 7)
Public Const MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 8)
Public Const MIXERCONTROL_CONTROLTYPE_SIGNEDMETER = (MIXERCONTROL_CT_CLASS_METER Or MIXERCONTROL_CT_SC_METER_POLLED Or MIXERCONTROL_CT_UNITS_SIGNED)
Public Const MIXERCONTROL_CONTROLTYPE_PEAKMETER = (MIXERCONTROL_CONTROLTYPE_SIGNEDMETER + 1)

Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long
Declare Function mixerGetControlDetails Lib "winmm.dll" Alias "mixerGetControlDetailsA" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long
Declare Function mixerGetDevCaps Lib "winmm.dll" Alias "mixerGetDevCapsA" (ByVal uMxId As Long, ByVal pmxcaps As MIXERCAPS, ByVal cbmxcaps As Long) As Long
Declare Function mixerGetID Lib "winmm.dll" (ByVal hmxobj As Long, pumxID As Long, ByVal fdwId As Long) As Long
Declare Function mixerGetLineInfo Lib "winmm.dll" Alias "mixerGetLineInfoA" (ByVal hmxobj As Long, pmxl As MIXERLINE, ByVal fdwInfo As Long) As Long
Declare Function mixerGetLineControls Lib "winmm.dll" Alias "mixerGetLineControlsA" (ByVal hmxobj As Long, pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Long) As Long
Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long
Declare Function mixerMessage Lib "winmm.dll" (ByVal hmx As Long, ByVal uMsg As Long, ByVal dwParam1 As Long, ByVal dwParam2 As Long) As Long
Declare Function mixerOpen Lib "winmm.dll" (phmx As Long, ByVal uMxId As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal fdwOpen As Long) As Long
Declare Function mixerSetControlDetails Lib "winmm.dll" (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long

Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" (struct As Any, ByVal ptr As Long, ByVal cb As Long)
Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" (ByVal ptr As Long, struct As Any, ByVal cb As Long)
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long

Type MIXERCAPS
   wMid As Integer
   wPid As Integer
   vDriverVersion As Long
   szPname As String * MAXPNAMELEN
   fdwSupport As Long
   cDestinations As Long
End Type
Type MIXERCONTROL
   cbStruct As Long
   dwControlID As Long
   dwControlType As Long
   fdwControl As Long
   cMultipleItems As Long
   szShortName As String * MIXER_SHORT_NAME_CHARS
   szName As String * MIXER_LONG_NAME_CHARS
   lMinimum As Long
   lMaximum As Long
   Reserved(10) As Long
End Type
Type MIXERCONTROLDETAILS
   cbStruct As Long
   dwControlID As Long
   cChannels As Long
   item As Long
   cbDetails As Long
   paDetails As Long
End Type
Type MIXERCONTROLDETAILS_SIGNED
   lValue As Long
End Type
Type MIXERLINE
   cbStruct As Long
   dwDestination As Long
   dwSource As Long
   dwLineID As Long
   fdwLine As Long
   dwUser As Long
   dwComponentType As Long
   cChannels As Long
   cConnections As Long
   cControls As Long
   szShortName As String * MIXER_SHORT_NAME_CHARS
   szName As String * MIXER_LONG_NAME_CHARS
   dwType As Long
   dwDeviceID As Long
   wMid  As Integer
   wPid As Integer
   vDriverVersion As Long
   szPname As String * MAXPNAMELEN
End Type
Type MIXERLINECONTROLS
   cbStruct As Long
   dwLineID As Long
   dwControl As Long
   cControls As Long
   cbmxctrl As Long
   pamxctrl As Long
End Type

Public i As Integer, j As Integer, rc As Long, msg As String * 200, hWaveIn As Long
Public Const NUM_BUFFERS = 2
Public format As WAVEFORMAT, hmem(NUM_BUFFERS) As Long, inHdr(NUM_BUFFERS) As WAVEHDR
Public Const BUFFER_SIZE = 8192
Public Const DEVICEID = 0
Public fRecording As Boolean
Function GetControl(ByVal hmixer As Long, ByVal componentType As Long, ByVal ctrlType As Long, ByRef mxc As MIXERCONTROL) As Boolean
' This function attempts to obtain a mixer control. Returns True if successful.

   Dim mxlc As MIXERLINECONTROLS
   Dim mxl As MIXERLINE
   Dim hmem As Long
   Dim rc As Long

   mxl.cbStruct = Len(mxl)
   mxl.dwComponentType = componentType

   ' Obtain a line corresponding to the component type
   rc = mixerGetLineInfo(hmixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)

   If (MMSYSERR_NOERROR = rc) Then
      mxlc.cbStruct = Len(mxlc)
      mxlc.dwLineID = mxl.dwLineID
      mxlc.dwControl = ctrlType
      mxlc.cControls = 1
      mxlc.cbmxctrl = Len(mxc)

      ' Allocate a buffer for the control
      'hmem = GlobalAlloc(&H40, Len(mxc))
      hmem = GlobalAlloc(GMEM_FIXED, Len(mxc))
      mxlc.pamxctrl = GlobalLock(hmem)
      mxc.cbStruct = Len(mxc)

      ' Get the control
      rc = mixerGetLineControls(hmixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)

      If (MMSYSERR_NOERROR = rc) Then
         GetControl = True

         ' Copy the control into the destination structure
         CopyStructFromPtr mxc, mxlc.pamxctrl, Len(mxc)
      Else
         GetControl = False
      End If
      GlobalFree (hmem)
      Exit Function
   End If

   GetControl = False
End Function
' Function to process the wave recording notifications.
Sub waveInProc(ByVal hwi As Long, ByVal uMsg As Long, ByVal dwInstance As Long, ByRef hdr As WAVEHDR, ByVal dwParam2 As Long)
   If (uMsg = MM_WIM_DATA) Then
      If fRecording Then
         rc = waveInAddBuffer(hwi, hdr, Len(hdr))
      End If
   End If
End Sub
' This function starts recording from the soundcard. The soundcard must be recording in order to
' monitor the input level. Without starting the recording from this application, input level
' can still be monitored if another application is recording audio
Function StartInput() As Boolean

    If fRecording Then
        StartInput = True
        Exit Function
    End If

    format.wFormatTag = 1
    format.nChannels = 1
    format.wBitsPerSample = 8
    format.nSamplesPerSec = 8000
    format.nBlockAlign = format.nChannels * format.wBitsPerSample / 8
    format.nAvgBytesPerSec = format.nSamplesPerSec * format.nBlockAlign
    format.cbSize = 0

    For i = 0 To NUM_BUFFERS - 1
        hmem(i) = GlobalAlloc(&H40, BUFFER_SIZE)
        inHdr(i).lpData = GlobalLock(hmem(i))
        inHdr(i).dwBufferLength = BUFFER_SIZE
        inHdr(i).dwFlags = 0
        inHdr(i).dwLoops = 0
    Next

    rc = waveInOpen(hWaveIn, DEVICEID, format, 0, 0, 0)
    If rc <> 0 Then
        waveInGetErrorText rc, msg, Len(msg)
        MsgBox msg
        StartInput = False
        Exit Function
    End If

    For i = 0 To NUM_BUFFERS - 1
        rc = waveInPrepareHeader(hWaveIn, inHdr(i), Len(inHdr(i)))
        If (rc <> 0) Then
            waveInGetErrorText rc, msg, Len(msg)
            MsgBox msg
        End If
    Next

    For i = 0 To NUM_BUFFERS - 1
        rc = waveInAddBuffer(hWaveIn, inHdr(i), Len(inHdr(i)))
        If (rc <> 0) Then
            waveInGetErrorText rc, msg, Len(msg)
            MsgBox msg
        End If
    Next

    fRecording = True
    rc = waveInStart(hWaveIn)
    StartInput = True
End Function
' Stop receiving audio input on the soundcard
Sub StopInput()

    fRecording = False
    waveInReset hWaveIn
    waveInStop hWaveIn
    For i = 0 To NUM_BUFFERS - 1
        waveInUnprepareHeader hWaveIn, inHdr(i), Len(inHdr(i))
        GlobalFree hmem(i)
    Next
    waveInClose hWaveIn
End Sub

[cg_ck]

(пачесался)
Щас разберёмся...
Спасибо!

[Amed]

Да, сложный код

У меня на буке, кстати, не работает

[cg_ck]

У меня тоже не работает. Выдаёт следующее:
"Couldn't get wavein meter"
"Couldn't get waveout meter"

(моя система - ХР)

[Amed]

У меня то же самое... Странно...

Попробуйте поискать в Яндексе или Гугле...

[cg_ck]

99 год. Наверно под ХР работеть просто не будет. Может кто-нибудь проверить на 9х?
А вообще я видел описание подобной программы на каком-то гитарном сайте, только реализованной на qBasic. Жаль, но ссылка безнадёжно потеряна. Найти не получается.

[KiloGraf]

Знакома... Была такая проблема, связанная с совместимостью в 98 м XP.
Ели память не изменяет, то зарыта она в WAVEFORMATEX...

Здесь она решилась...

[cg_ck]

Особенно в этой программе порадовало то, что она работает обсалютно одинакого если микрофон подключен, выключен, звук включён или выключен и вообще она не реагирует никак не любые изменения в системе связанные со звуком. обсалютно одинакого и беспорядочно бегает график по монитору. Может там какая ошибка? Я там разобратся не в силах...

[alibek]

Ты наверное на микшере микрофонный вход не включал, вот он шумы и выдавал.
Кстати, народ, а у кого есть быстрая реализация FFE на VB?

[Ennor]

Ты наверное на микшере микрофонный вход не включал, вот он шумы и выдавал.
Кстати, народ, а у кого есть быстрая реализация FFE на VB?

А такое возможно?

[alibek]

Ennor, ты удивляешься про шумы в микрофоне или разложению Фурье?
Я же не знаю, потому и спрашиваю. Может быть у кого есть пример разложения в реальном времени.

[cg_ck]

alibek, а ты проверял? У тебя работает? Скажи пожалуйста тогда, в каком положении должны быть галочки на микшере, ибо как бы я их не выстовлял, всё остоётся неизменым. Беспорядочное движение графика.

[cg_ck]

Прастите народ, извените! Сам виноват. Это был фон о провода. Заменил, теперь всё работает. Спасибо! Тему можно закрывать.

[Ennor]

2 Alibek: конечно, БПФ - про шумы я тебе и сам расскажу, не надо мне ничего рассказывать. А насчет реал-тайма... На аудиокартах уровня того же Creamware стоит куча DSP, которые только этим и занимаются. А ты хочешь мало того, что за счет CPU (который тебе все равно гарантированного реал-тайма не даст никогда), так еще и на VB. Как-то не верится, если честно...

[Igor_123]

Кстати, народ, а у кого есть быстрая реализация FFE на VB?

Что-то вроде www.algolib.manual.ru
там вроде было, правда не знаю насчёт быстроты.
А вообще есть у интела
Intel® Signal Processing Library v4.5 - версия бесплатная и там это все уже сделанно в виде ДЛЛ и оптимизированно.
Весит около 17 мБ