Круговой визуализатор спектра

Option Explicit
 
' Ìîäóëü modMain.bas ãëàâíûé ìîäóëü ïðîãðàììû TrickSpectrum
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Private Type View                                    ' Òèï îòîáðàæåíèÿ
    fa As Single                                     ' Íà÷àëüíûé óãîë
    ta As Single                                     ' Øèðèíà óãëà
    IsLine As Boolean                                ' ßâëÿåòñÿ ëèíèåé
End Type
 
Public Type Complex                                  ' Êîìïëåêñíîå ÷èñëî
    r As Single
    i As Single
End Type
 
Private mFFTSize As Long                             ' Ðàçìåð FFT
Private mFFTLog  As Long                             ' Log2(FFTSize)
Private mOctaveCount As Long                         ' Êîëè÷åñòâî îêòàâ
Private mSymmetrical As Boolean                      ' Ñèììåòðè÷íîå îòîáðàæåíèå
Private mFade As Single                              ' Êîýôôèöèåíò óãàñàíèÿ
Private mTransparency As Single                      ' Ïðîçðà÷íîñòü
Private mEffect As Long                              ' Ýôôåêò
Private mGain As Long                                ' Óñèëåíèå
Private mTransparent As Boolean                      ' Ïðîçðà÷íîå îêíî
Private mView As Long                                ' Ðåæèì îòîáðàæåíèÿ
 
Dim MapData() As View                                ' Õðàíåíèå îòîáðàæåíèÿ ñîîòâåòñòâèÿ ÷àñòîòû ê êîîðäèíàòå
Dim Spectrum() As Complex                            ' Ðåçóëüòàò FFT ïðåîáðàçîâàíèÿ
Dim Window() As Single                               ' Îêîííàÿ ôóíêöèÿ Õåììèíãà
Dim Palette() As Long                                ' Ïàëèòðà
Dim imgSpectrum As Long                              ' Êàðòèíêà ñïåêòðà
Dim imgSpectrumData() As Long                        ' Ïèêñåëè êàðòèíêè ñïåêòðà
 
Dim grWindow As Long                                 ' Graphics îêíà
Dim grSpectrum As Long                               ' Graphics áóôåðà
Dim Brush As Long                                    ' Êèñòü äëÿ çàëèâêè êðóãà è ñåêòîðîâ
Dim Pen As Long                                      ' Ïåðî äëÿ îòðèñîâêè äóã è ëèíèé
Dim OctAreaSize As Single                            ' Ðàçìåð îáëàñòè îäíîé îêòàâû â ïèêñåëÿõ
Dim Coef(13) As Complex                              ' Êîýôôèöèåíòû äëÿ FFT
Dim FFTInit As Boolean                               ' Èíèöèàëèçèðîâàíû ëè êîýôèöèåíòû äëÿ FFT
Dim ExternalPalette As Boolean                       ' Çàãðóæåíà âíåøíÿÿ ïàëèòðà
 
' Ñâîéñòâî çàäàåò ðàçìåð FFT
Public Property Let FFTSize(ByVal lNewValue As Long)
    Dim lg As Single
    ' Ïðîâåðêà êðàòíî ëè ñòåïåíè 2
    lg = Log(lNewValue) / 0.693147180559945
    If lg <> Fix(lg) Then Exit Property
    ' Ïðîâåðêà âûõîäà çà ïðåäåëû
    If lg > mOctaveCount Or lg < 8 Then Exit Property
    mFFTSize = lNewValue
    mFFTLog = lg
    ' Îáíîâëåíèå ðàçìåðîâ áóôåðîâ
    UpdateBuffers
    ' Îáíîâëåíèå êîîðäèíàò îòîáðàæåíèÿ
    CreateMap
End Property
Public Property Get FFTSize() As Long
    FFTSize = mFFTSize
End Property
 
' Ñâîéñòâî çàäàåò êîëè÷åñòâî îòîáðàæàåìûõ îêòàâ
Public Property Let OctaveCount(ByVal lNewValue As Long)
    ' Ïðîâåðêà âûõîäà çà ãðàíèöû
    If lNewValue > mFFTLog Or lNewValue < 2 Then Exit Property
    ' Ñáðîñ ôëàæêà ñ ïðåäûäóùåé ïîçèöèè â ìåíþ
    CheckMenuItem mnuOct, mOctaveCount - 2, MF_BYPOSITION Or MF_UNCHECKED
    mOctaveCount = lNewValue
    ' Óñòàíîâêà ôëàæêà íà íîâîå ìåñòî â ìåíþ
    CheckMenuItem mnuOct, mOctaveCount - 2, MF_BYPOSITION Or MF_CHECKED
    ' Îáíîâëåíèå êîîðäèíàò îòîáðàæåíèå
    CreateMap
End Property
Public Property Get OctaveCount() As Long
    OctaveCount = mOctaveCount
End Property
 
' Ñâîéñòâî çàäàåò ñãëàæèâàíèå (àíòèàëèàñèíã)
Public Property Let Smoothing(ByVal bNewValue As Boolean)
    GdipSetSmoothingMode grSpectrum, IIf(bNewValue, SmoothingModeAntiAlias, SmoothingModeHighSpeed)
    ' Óñòàíîâêà ôëàæêà â ìåíþ
    CheckMenuItem mnuMain, 1, IIf(bNewValue, MF_CHECKED, MF_UNCHECKED)
End Property
Public Property Get Smoothing() As Boolean
    Dim l As Long
    GdipGetSmoothingMode grSpectrum, l
    Smoothing = l = SmoothingModeAntiAlias
End Property
 
' Ñâîéñòâî çàäàåò îòîáðàæåíèå ñèììåòðè÷íî ïî ãîðèçîíòàëè
Public Property Let Symmetrical(ByVal bNewValue As Boolean)
    mSymmetrical = bNewValue
    ' Óñòàíîâêà ôëàæêà
    CheckMenuItem mnuMain, 0, IIf(bNewValue, MF_CHECKED, MF_UNCHECKED)
    ' Ñîçäàíèå îòîáðàæåíèÿ
    CreateMap
    ' Ñîçäàíèå áóôåðíîé êàðòèíêè
    CreateSpectrumBitmap
End Property
Public Property Get Symmetrical() As Boolean
    Symmetrical = mSymmetrical
End Property
 
' Ñâîéñòâî çàäàåò âêëþ÷åíà ëè ïðîçðà÷íîñòü îêíà
Public Property Let Transparent(ByVal bNewValue As Boolean)
    Dim hRgn As Long
    mTransparent = bNewValue
    ' Óñòàíîâêà ôëàæêà â ìåíþ
    CheckMenuItem mnuMain, 2, IIf(bNewValue, MF_CHECKED, MF_UNCHECKED)
    If mTransparent Then
        ' Åñëè ïðîçðà÷íî
        ' Ñáðîñ ðåãèîíà îêíà
        SetWindowRgn frmMain.hwnd, 0, True
        ' Óñòàíàâëèâàåì ñëîåíûé ñòèëü îêíà
        SetWindowLong frmMain.hwnd, GWL_EXSTYLE, GetWindowLong(frmMain.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    Else
        ' Åñëè íåïðîçðà÷íî
        ' Ñáðàñûâàåì áèò ñëîåíîñòè îêíà
        SetWindowLong frmMain.hwnd, GWL_EXSTYLE, GetWindowLong(frmMain.hwnd, GWL_EXSTYLE) And (Not WS_EX_LAYERED)
        ' Ñîçäàåì êðóãëûé ðåãèîí
        hRgn = CreateEllipticRgn(0, 0, frmMain.ScaleWidth, frmMain.ScaleWidth)
        ' Óñòàíàâëèâàåì åãî â îêíî
        SetWindowRgn frmMain.hwnd, hRgn, True
    End If
End Property
Public Property Get Transparent() As Boolean
    Transparent = mTransparent
End Property
 
' Ñâîéñòâî çàäàåò ýôôåêò àíèìàöèè ôîíà
Public Property Let Effect(ByVal lNewValue As Long)
    ' Ñáðîñ ôëàæêà ñ ïðåäûäóùåé ïîçèöèè â ìåíþ
    CheckMenuItem mnuEffects, mEffect, MF_BYPOSITION Or MF_UNCHECKED
    mEffect = lNewValue
    ' Óñòàíîâêà ôëàæêà íà íîâîå ìåñòî â ìåíþ
    CheckMenuItem mnuEffects, mEffect, MF_BYPOSITION Or MF_CHECKED
End Property
Public Property Get Effect() As Long
    Effect = mEffect
End Property
 
' Ñâîéñòâî çàäàåò ïàðàìåòð çàòóõàíèÿ ôîíà
Public Property Let Fade(ByVal fNewValue As Single)
    ' Ñáðîñ ôëàæêà ñ ïðåäûäóùåé ïîçèöèè â ìåíþ
    CheckMenuItem mnuFade, Sqr(mFade * 100) - 1, MF_BYPOSITION Or MF_UNCHECKED
    mFade = fNewValue
    ' Óñòàíîâêà ôëàæêà íà íîâîå ìåñòî â ìåíþ
    CheckMenuItem mnuFade, Sqr(mFade * 100) - 1, MF_BYPOSITION Or MF_CHECKED
End Property
Public Property Get Fade() As Single
    Fade = mFade
End Property
 
' Ñâîéñòâî çàäàåò ïàðàìåòð óñèëåíèÿ ñèãíàëà ïðè âûâîäå
Public Property Let Gain(ByVal fNewValue As Single)
    ' Ñáðîñ ôëàæêà ñ ïðåäûäóùåé ïîçèöèè â ìåíþ
    CheckMenuItem mnuGain, mGain - 1, MF_BYPOSITION Or MF_UNCHECKED
    mGain = fNewValue
    ' Óñòàíîâêà ôëàæêà íà íîâîå ìåñòî â ìåíþ
    CheckMenuItem mnuGain, mGain - 1, MF_BYPOSITION Or MF_CHECKED
End Property
Public Property Get Gain() As Single
    Gain = mGain
End Property
 
' Ñâîéñòâî çàäàåò ïðîçðà÷íîñòü ïîäëîæêè îêíà
Public Property Let Transparency(ByVal fNewValue As Single)
    ' Ñáðîñ ôëàæêà ñ ïðåäûäóùåé ïîçèöèè â ìåíþ
    CheckMenuItem mnuTransparency, mTransparency * 10 - 1, MF_BYPOSITION Or MF_UNCHECKED
    mTransparency = fNewValue
    ' Óñòàíîâêà ôëàæêà íà íîâîå ìåñòî â ìåíþ
    CheckMenuItem mnuTransparency, mTransparency * 10 - 1, MF_BYPOSITION Or MF_CHECKED
End Property
Public Property Get Transparency() As Single
    Transparency = mTransparency
End Property
 
' Ñâîéñòâî çàäàåò ðåæèì îòîáðàæåíèÿ
Public Property Let View(ByVal lNewValue As Long)
    ' Ñáðîñ ôëàæêà ñ ïðåäûäóùåé ïîçèöèè â ìåíþ
    CheckMenuItem mnuView, mView, MF_BYPOSITION Or MF_UNCHECKED
    mView = lNewValue
    CheckMenuItem mnuView, mView, MF_BYPOSITION Or MF_CHECKED
    ' Óñòàíîâêà ôëàæêà íà íîâîå ìåñòî â ìåíþ
    If mView = 1 Then
        ' Åñëè ðåæèì îòîáðàæåíèÿ â âèäå ñåêòîðîâ
        ' òî çàäàåì øèðèíó ïåðà â 1 ïèêñåëü, äëÿ îòîáðàæåíèÿ òîíêèõ ñåòîðîâ
        GdipSetPenWidth Pen, 1
        ' Ñîçäàåì ïàëèòðó áåç ïðîçðà÷íîñòè
        CreateDefaultSectorPalette
        ' Èíà÷å ñîçäàåì ïàëèòðó ñ ïðîçðà÷íîñòüþ
    Else: CreateDefaultRingPalette
    End If
    ' Ñîçäàåì îòîáðàæåíèå
    CreateMap
End Property
Public Property Get View() As Long
    View = mView
End Property
 
' Ôóíêöèÿ çàãðóæàåò ïàëèòðó èç ôàéëà
Public Function LoadPalette(FileName As String) As Boolean
    Dim bmp As Long, pix As Long, w As Long, x As Long, i As Long, d As Single
    ' Çàãðóæàåì êàðòèíêó
    If GdipLoadImageFromFile(StrPtr(FileName), bmp) Then
        MsgBox "Error opening image"
        Exit Function
    End If
    ' Ïðîâåðÿåì ôîðìàò ïèêñåëåé
    GdipGetImagePixelFormat bmp, pix
    ' Ïîäõîäÿò òîëüêî 32ARGB
    If pix <> PixelFormat32bppARGB Then
        MsgBox "Unsupported pixel format"
        GdipDisposeImage bmp
        Exit Function
    End If
    ' Ïðîâåðÿåì øèðèíó íå ìåíåå 255
    GdipGetImageWidth bmp, w
    If w < 256 Then
        MsgBox "Very small the bitmap. Mininum width - 256 pixels"
        GdipDisposeImage bmp
        Exit Function
    End If
    d = w / 256
    ' Çàäàåì çíà÷åíèÿ ïàëèòðû â ñîîòâåòñòâèè ñ ïèêñåëÿìè ðèñóíêà
    For i = 0 To 255
        x = i * d
        GdipBitmapGetPixel bmp, x, 0, Palette(i)
    Next
    
    ExternalPalette = True
    
    GdipDisposeImage bmp
End Function
' /////////////////////////////////////////////////////Ñòàðòîâàÿ ïðîöåäóðà/////////////////////////////////////////////////////////
Public Sub Main()
    ' Çàãðóæàåì ôîðìó
    Load frmMain
    
    ' Çàäàåì ïàðàìåòðû ïî óìîë÷àíèþ
    mFFTSize = 2048: mFFTLog = 11: mOctaveCount = 7: mFade = 0.81
    mTransparency = 0.5: mSymmetrical = False: mGain = 4
    Transparent = False
    ' Îáíîâëÿåì ðàçìåðû áóôåðîâ
    UpdateBuffers
    ' Ñîçäàåì îòîáðàæåíèå
    CreateMap
    
    ' Èíèöèàëèçèðóåì GDI+
    If Not InitGDIPlus Then Unload frmMain: Exit Sub
    
    ' Ñîçäàåì êèñòü è ïåðî
    If GdipCreateSolidFill(0, Brush) Then MsgBox "Error creating fill": Unload frmMain: Exit Sub
    If GdipCreatePen1(0, 1, UnitPixel, Pen) Then MsgBox "Error creating pen": Unload frmMain: Exit Sub
    
    ' Ïðèðàâíèâàåì øèðèíó è âûñîòó ôîðìû
    frmMain.Height = frmMain.Width
    
    ' Ñîçäàåì ïàëèòðó
    CreateDefaultRingPalette
    ' Ñîçäàåì ìåíþ
    CreateMenu
    ' Ñàáêëàññèì ôîðìó
    Hook
    
    ' Óñòàíîâêà èçíà÷àëüíûõ ôëàæêîâ â ìåíþ
    CheckMenuItem mnuOct, mOctaveCount - 2, MF_BYPOSITION Or MF_CHECKED
    CheckMenuItem mnuTransparency, mTransparency * 10 - 1, MF_BYPOSITION Or MF_CHECKED
    CheckMenuItem mnuFade, Sqr(mFade * 100) - 1, MF_BYPOSITION Or MF_CHECKED
    CheckMenuItem mnuEffects, mEffect, MF_BYPOSITION Or MF_CHECKED
    CheckMenuItem mnuGain, mGain - 1, MF_BYPOSITION Or MF_CHECKED
    CheckMenuItem mnuView, 0, MF_BYPOSITION Or MF_CHECKED
    
    ' Çàõâàòûâàåì çâóê
    If Not InitCapture Then Unload frmMain: Exit Sub
    
    ' Ïîêàçûâàåì ôîðìó
    frmMain.Show
End Sub
 
' Âûõîä èç ïðîãðàììû
Public Sub Quit()
    ' Óäàëÿåì ðåñóðñû GDI+
    If grWindow Then GdipDeleteGraphics grWindow
    If imgSpectrum Then GdipDisposeImage imgSpectrum: GdipDeleteGraphics grSpectrum
    If Pen Then GdipDeletePen Pen
    If Brush Then GdipDeleteBrush Brush
    ' Äåèíèöèàëèçàöèÿ GDI+
    UninitGDIPlus
    ' Óíè÷òîæåíèå ìåíþ
    DeleteMenu
    ' Ñíèìàåì ñàáêëàññèíã
    Unhook
    ' Çàâåðøàåì çàõâàò çâóêà
    EndCapture
End Sub
 
' Ïðè èçìåíåíèè ðàçìåðîâ ôîðìû
Public Sub OnResize()
    ' Åñëè áûë ñîçäàí Graphics îêíà, óäàëÿåì åãî
    If grWindow Then GdipDeleteGraphics grWindow: grWindow = 0
    
    ' Ñîçäàåì íîâûé Graphics ïî ðàçìåðó îêíà
    If GdipCreateFromHDC(frmMain.hdc, grWindow) Then
        MsgBox "Error create GDI+ graphics"
        Unload frmMain: Exit Sub
    End If
    
    ' Äëÿ íåãî âêëþ÷àåì ñãëàæèâàíèå
    GdipSetSmoothingMode grWindow, SmoothingModeAntiAlias
    ' Ñîçäàåì áóôôåðíóþ êàðòèíêó è Graphics
    If Not CreateSpectrumBitmap Then Exit Sub
    ' Ñîçäàåì îòîáðàæåíèå
    CreateMap
End Sub
 
' Ïðîöåäóðà îòðèñîâêè
Public Sub Draw(Wav() As Integer)
    Dim i1 As Long, i2 As Long, c As Long, sz As Currency, pts As Currency, o As Long, _
        Sh As Single, Sw As Single, q1 As Single, q2 As Single, b As Long, fl As Boolean, _
        m As Long, x As Single, y As Single, a As Single, ci As Long
    
    ' Ïåðåâîäèì öåëûå ñòåðåî-âûáîðêè â êîìïëåêñíûé ìîíî-ôîðìàò
    ToComplex Wav(), Spectrum()
    ' Ïðîèçâîäèì áûñòðîå ÏÔ
    FFT Spectrum()
    
    ' Åñëè ðåæèì ñèììåòðè÷íîãî îòîáðàæåíèå, òî
    If mSymmetrical Then
        ' ãîðèçîíòàëüíûé ñäâèã ðàâåí 0
        Sw = 0
    Else
        ' èíà÷å ïîëîâèíå ôîðìû
        Sw = (frmMain.ScaleWidth - 1) / 2
    End If
    ' Âåðòèêàëüíûé ñäâèã = ïîëîâèíå ôîðìû
    Sh = (frmMain.ScaleWidth - 1) / 2
    
    ' Î÷èùàåì îêíî
    GdipGraphicsClear grWindow, ARGB(255, 0)
    ' Óñòàíàâëèâàåì ïðîçðà÷íîñòü ïîäëîæêè
    GdipSetSolidFillColor Brush, ARGB(Transparency * 255, 0)
    ' Çàëèâàåì ïîäëîæêó
    GdipFillEllipse grWindow, Brush, 0, 0, frmMain.ScaleWidth - 1, frmMain.ScaleHeight - 1
 
    ' Àíèìèðóåì ôîí
    Release
    
    ' Ïåðâàÿ ÷àñòîòà
    i1 = 1
    
    ' Â çàâèñèìîñòè îò ðåæèìà îòîáðàæåíèÿ
    Select Case View
    Case 0
        ' Ïðîõîä ïî îêòàâàì
        For o = 0 To mOctaveCount - 1
            ' Ôëàã ïåðåõîäà
            fl = True
            ' Óâåëè÷èâàåì ðàäèóñ íà ðàçìåð îêòàâû
            q2 = q2 + OctAreaSize
            ' Íàõîäèì èíäåêñ ñëåäóþùåé îêòàâû
            i2 = i1 * 2
            ' Ïîõîä ïî èíäåêñàì ñïåêòðà
            Do While i1 < i2
                ' Íàõîäèì àìïëèòóäó ñïåêòðà
                b = Sqr(Spectrum(i1).r * Spectrum(i1).r + Spectrum(i1).i * Spectrum(i1).i)
                ' Îãðàíè÷èâàåì
                If b > 255 Then b = 255
                ' Óñòàíàâëèâàåì öâåò ïåðà â çàâèñèìîñòè îò èíòåíñèâíîñòè àìïëèòóäû
                GdipSetPenColor Pen, Palette(b)
                ' Åñëè îòîáðàæåíèå ÷åðåç ëèíèè
                If MapData(i1).IsLine Then
                    ' Åñëè ïåðåõîäíûé ôëàã, òî óñòàíàâëèâàåì òîëùèíó ïåðà 1 ïèêñåëü
                    If Not fl Then GdipSetPenWidth Pen, 1: fl = True: q1 = q1 + 4: q2 = q2 + 2
                    ' Ðèñóåì ëèíèþ
                    GdipDrawLine grSpectrum, Pen, MapData(i1).fa * q1 + Sw, MapData(i1).ta * q1 + Sh, _
                                                  MapData(i1).fa * q2 + Sw, MapData(i1).ta * q2 + Sh
                Else
                    ' Åñëè ïåðåõîäíûé ôëàã, òî óñòàíàâëèâàåì òîëùèíó ïåðà ðàçìåðó îêòàâû - øèðèíà ðàìêè
                    If fl Then GdipSetPenWidth Pen, OctAreaSize - 2: fl = False
                    ' Ðèñóåì äóãó
                    GdipDrawArc grSpectrum, Pen, Sw - q2, Sh - q2, q2 * 2 - 1, q2 * 2 - 1, MapData(i1).fa, MapData(i1).ta
                End If
                ' Ñëåäóþùèé ñïåêòð
                i1 = i1 + 1
            Loop
            ' Óâåëè÷èâàåì ðàäèóñ, íà ðàçìåð îêòàâû
            q1 = q1 + OctAreaSize
        Next
    Case 1
        ' Êîýôôèöèåíò óñèëåíèÿ
        q1 = (mGain * Gain + 9)
        ' Êîýôôèöèåíò èíäåêñà
        q2 = 255 / ((2 ^ (mOctaveCount + 1)) \ 2)
        ' Ïðîõîä ïî îêòàâàì
        For o = 0 To mOctaveCount - 1
            ' Íàõîäèì èíäåêñ ñëåäóþùåé îêòàâû
            i2 = i1 * 2
            ' Ïîõîä ïî èíäåêñàì ñïåêòðà
            Do While i1 < i2
                ' Íàõîäèì àìïëèòóäó ñïåêòðà è óñèëèâàåì åå
                b = (Log(Sqr(Spectrum(i1).r * Spectrum(i1).r + Spectrum(i1).i * Spectrum(i1).i) _
                    + 0.0001) + 9.21034037197618) * q1
                ' Îãðàíè÷èâàåì
                If b > Sh - 1 Then b = Sh - 1
                ' Åñëè áîëüøå 1 ïèêñåëÿ îòðèñîâûâàåì
                If b > 1 Then
                    ' Íàõîäèì èíäåêñ â ïàëèòðå öâåòà
                    ci = i1 * q2
                    ' Åñëè øèðèíà ñåêòîðà < 2 ïèêñåëåé, òî ðèñóåì ëèíèþ
                    If 6.28318530717959 * b * (MapData(i1).ta / 360) < 2 Then
                        ' Íàõîäèì óãîë â ðàäèàíàõ
                        a = MapData(i1).fa * 1.74532925199433E-02
                        ' Íàõîäèì êîîðäèíàòû êîíöà ëèíèè
                        x = Cos(a) * b + Sw: y = Sin(a) * b + Sh
                        ' Óñòàíàâëèâàåì öâåò ïåðà â çàâèñèìîñòè îò ÷àñòîòû
                        GdipSetPenColor Pen, Palette(ci)
                        ' Ðèñóåì ëèíèþ
                        GdipDrawLine grSpectrum, Pen, Sw, Sh, x, y
                    Else
                        ' Óñòàíàâëèâàåì öâåò çàëèâêè â çàâèñèìîñòè îò ÷àñòîòû
                        GdipSetSolidFillColor Brush, Palette(ci)
                        ' Çàëèâàåì ñåêòîð
                        GdipFillPie grSpectrum, Brush, Sw - b, Sh - b, b * 2, b * 2, MapData(i1).fa, MapData(i1).ta
                    End If
                End If
                ' Ñëåäóþùèé ñïåêòð
                i1 = i1 + 1
            Loop
        Next
    End Select
    
    ' Äëÿ áûñòðîé îòðèñîâêè èç áóôåðà îòêëþ÷àåì ñãëàæèâàíèå
    GdipSetSmoothingMode grWindow, SmoothingModeHighSpeed
    
    ' Äëÿ ñèììåòðè÷íîãî îòîáðàæåíèÿ
    If mSymmetrical Then
        ' îòðèñîâûâàåì äâà çåðêàëüíî-ðàñïîëîæåííûõ áóôåðà
        GdipDrawImageRectI grWindow, imgSpectrum, Sh, 0, -Sh, Sh * 2 + 1
        GdipDrawImageI grWindow, imgSpectrum, Sh, 0
    Else
        ' èíà÷å ðèñóåì êàê åñòü
        GdipDrawImageI grWindow, imgSpectrum, 0, 0
    End If
    
    ' Óñòàíàâëèâàåì ñãëàæèâàíèå äëÿ îêíà
    GdipSetSmoothingMode grWindow, SmoothingModeAntiAlias
    
    ' Îòðèñîâûâàåì èç áóôôåðíîãî DC íà ñåáÿ
    frmMain.Refresh
    ' Èíèöèàëèçàöèÿ ïåðåìåííîé ðàçìåðà
    sz = (frmMain.ScaleWidth + CCur(frmMain.ScaleHeight) * 4294967296#) / 10000
    
    ' Åñëè îêíî ñëîåíîå, òî îáíîâëÿåì åãî ñîñòîÿíèå
    If mTransparent Then
        UpdateLayeredWindow frmMain.hwnd, frmMain.hdc, ByVal 0, sz, frmMain.hdc, pts, 0, AB_32Bpp255, ULW_ALPHA
    End If
End Sub
 
' Ôóíêöèÿ ñîçäàåò áóôôåðíóþ êàðòèíêó è áóôôåðíûé Graphics
Private Function CreateSpectrumBitmap() As Boolean
    Dim s As Boolean, w As Long
    
    ' Çàïîìèíàåì ðåæèì ñãëàæèâàíèÿ
    s = Smoothing
    ' Óäàëÿåì ïðè íåîáõîäèìîñòè ðåñóðû GDI+
    If imgSpectrum Then GdipDisposeImage imgSpectrum: GdipDeleteGraphics grSpectrum
    ' Îïðåäåëÿåì øèðèíó áóôåðíîé êàðòèíêè
    w = IIf(mSymmetrical, frmMain.ScaleWidth / 2, frmMain.ScaleWidth)
    ' Âûäåëÿåì ìåñòî ïîä áèòû ðèñóíêà
    ReDim imgSpectrumData(w - 1, frmMain.ScaleHeight - 1)
    ' Ñîçäàåì ðèñóíîê
    If GdipCreateBitmapFromScan0(w, frmMain.ScaleHeight, w * 4, PixelFormat32bppARGB, imgSpectrumData(0, 0), imgSpectrum) Then
        MsgBox "Error create GDI+ bitmap"
        Unload frmMain: Exit Function
    End If
    ' Ñîçäàåì Graphics
    If GdipGetImageGraphicsContext(imgSpectrum, grSpectrum) Then
        MsgBox "Error create buffer graphics"
        Unload frmMain: Exit Function
    End If
    ' Óñòàíàâëèâàåì íà ìåñòî ðåæèì ñãëàæèâàíèÿ
    Smoothing = s
    ' Óäà÷íî
    CreateSpectrumBitmap = True
End Function
 
' Ïðîöåäóðà àíèìèðóåò ôîí
Private Sub Release()
    Dim x As Long, y As Long, c As Long, d As Long, w As Long, h As Long
    Dim r As Long, g As Long, b As Long, a As Long, dx As Long, dy As Long
    Dim cx As Single, cy As Single, Buf() As Long, o As Single, s As Single
    
    ' Îïðåäåëÿåì øèðèíó è âûñîòó ðèñóíêà - 1
    h = UBound(imgSpectrumData, 2): w = UBound(imgSpectrumData, 1)
    
    ' Â çàâèñèìîñòè îò ýôôåêòà
    Select Case mEffect
    Case 0
        ' ==========Áåç ýôôåêòà (ïðîñòî èçìåíÿåì ïðîçðà÷íîñòü ôîíà)=========
        ' Îïðåäåëÿåì êîýôôèöèåíò èçìåíåíèÿ àëüôà êîìïîíåíòû
        d = Fade * 255
        ' Ïðîõîä ïî áèòàì ðèñóíêà
        For y = 0 To h: For x = 0 To w
            ' Ïîëó÷àåì àëüôó
            a = (((imgSpectrumData(x, y) And &HFF000000) \ &H1000000) And &HFF&)
            ' Óìåíüøàåì
            a = a - d
            ' Îãðàíè÷èâàåì
            If a < 0 Then a = 0
            ' Âûäåëÿåì òîëüêî êîìïîíåíòû öâåòà
            c = imgSpectrumData(x, y) And &HFFFFFF
            ' Çàïèñûâàåì íàçàä ñ èçìåíåííîé àëüôîé
            If a > 127 Then
                imgSpectrumData(x, y) = c Or ((a - 256) * &H1000000)
            Else: imgSpectrumData(x, y) = c Or (a * &H1000000)
            End If
        Next: Next
    Case 1
        ' ===========================Ðàçìûòèå================================
        ' Îïðåäåëÿåì êîýôôèöèåíò èçìåíåíèÿ àëüôà êîìïîíåíòû
        d = Fade * 10
        ' Ïðîõîä ïî áèòàì ðèñóíêà
        For y = 0 To h: For x = 0 To w
            ' Ðàçìûâàåì âíóòðè (1,1,w-1,h-1)
            If x > 0 And y > 0 And x < w - 1 And y < h - 1 Then
                ' Îáíóëÿåì çíà÷åíèÿ íàêîïëåíèÿ êîìïîíåíò
                r = 0: g = 0: b = 0: a = 0
                ' Ïðîõîä ïî ñîñåäíèì ïèêñåëÿì
                For dy = -1 To 1: For dx = -1 To 1
                    ' Âûäåëÿåì êàæäóþ êîìïîíåíòó è çàïèñûâàåì â àêêóìóëÿòîðû
                    c = imgSpectrumData(x + dx, y + dy)
                    a = a + (((c And &HFF000000) \ &H1000000) And &HFF&)
                    r = r + (c And &HFF0000) \ &H10000
                    g = g + (c And &HFF00&) \ &H100
                    b = b + (c And &HFF)
                Next: Next
                ' Óñðåäíÿåì çíà÷åíèÿ â àêêóìóëÿòîðàõ è óìåíüøàåì àëüôó
                r = r \ 9: g = g \ 9: b = b \ 9: a = a \ 9 - d
                ' Îãðàíè÷èâàåì àëüôó ñíèçó
                If a < 0 Then a = 0
                ' Íàõîäèì çíà÷åíèÿ â RGB
                c = b Or (g * &H100&) Or (r * &H10000)
                ' Äîáàâëÿåì àëüôó
                If a > 127 Then
                    imgSpectrumData(x, y) = c Or ((a - 256) * &H1000000)
                Else: imgSpectrumData(x, y) = c Or (a * &H1000000)
                End If
                ' Èíà÷å îáíóëÿåì (ïîëíîñòüþ ïðîçðà÷íûé)
            Else: imgSpectrumData(x, y) = 0
            End If
        Next: Next
    Case 2
        ' ============================Ãîðåíèå================================
        ' Îïðåäåëÿåì êîýôôèöèåíò èçìåíåíèÿ àëüôà êîìïîíåíòû
        d = Fade * 64
        ' Êîïèðóåì áèòû ðèñóíêà â áóôåð
        Buf = imgSpectrumData
        ' Âû÷èñëÿåì ñäâèãè è øèðèíó â çàâèñèìîñòè îò îòîáðàæåíèÿ
        If mSymmetrical Then o = 0: s = w * 2 Else o = 0.5: s = w
        ' Ïðîõîä ïî áèòàì ðèñóíêà
        For y = 0 To h: For x = 0 To w
            ' Òðàíñôîðìèðóåì êîîðäèíàòó â çàâèñèìîñòè îò öåíòðà
            cx = x / s - o: cy = y / h - 0.5
            ' Íàõîäèì äëèíó îòíîñèòåëüíî öåíòðà
            r = Sqr(cx * cx + cy * cy)
            ' Íàõîäèì ðåçóëüòòèðóþùèé ïèêñåëü
            dx = (cx + o + 0.01 * cx * ((r - 1) / 0.5)) * s
            dy = (cy + 0.5 + 0.01 * cy * ((r - 1) / 0.5)) * h
            ' Íàõîäèì è óìåíüøàåì åãî àëüôó
            a = (((Buf(dx, dy) And &HFF000000) \ &H1000000) And &HFF&) - d
            ' Îãðàíè÷èâàåì àëüôó ñíèçó
            If a < 0 Then a = 0
            ' Âûäåëÿåì òîëüêî êîìïîíåíòû öâåòà
            c = Buf(dx, dy) And &HFFFFFF
            ' Çàïèñûâàåì íàçàä ñ èçìåíåííîé àëüôîé
            If a > 127 Then
                imgSpectrumData(x, y) = c Or ((a - 256) * &H1000000)
            Else: imgSpectrumData(x, y) = c Or (a * &H1000000)
            End If
        Next: Next
    End Select
End Sub
 
' Ïðîöåäóðà êîíâåðòèðóåò öåëûå çíà÷åíèÿ àìïëèòóä â êîìïëåêñíóþ ôîðìó ìèêøèðóÿ ïðàâûé è ëåâûé êàíàë,
' à òàêæå äåëàåò îêîííîå ïðåîáðàçîâàíèå
Private Sub ToComplex(Dat() As Integer, Out() As Complex)
    Dim i As Long, p As Long
    ' Ïðîõîä ïî èñòî÷íèêó
    For i = 0 To mFFTSize * 2 - 1 Step 2
        Out(p).r = ((CLng(Dat(i)) + Dat(i + 1)) / 65536) * Window(p): Out(p).i = 0
        p = p + 1
    Next
End Sub
 
' Ïðîöåäóðà îáíîâëÿåò ðàçìåðû áóôåðîâ
Private Sub UpdateBuffers()
    ReDim MapData(mFFTSize \ 2 - 1)
    ReDim Spectrum(mFFTSize - 1)
    ' Èíèöèàëèçèðóåì îêíî Õåììèíãà
    InitHamming
End Sub
 
' Ïðîöåäóðà ñîçäàåò îòîáðàæåíèå, äëÿ òîãî ÷òîáû íå âû÷èñëÿòü êàæäûé ðàç êîîðäèíàòû
Private Sub CreateMap()
    Dim o As Long, i1 As Long, i2 As Long, fr As Single, _
        d As Single, sa As Single, ea As Single, s As Single, ma As Single, _
        sn As Single, cs As Single, hs As Single, a As Single
    
    ' Íàõîäèì ðàäèóñ
    hs = frmMain.ScaleWidth / 2
    ' Âû÷èñëÿåì ðàçìåð îêòàâû â ïèêñåëÿõ
    OctAreaSize = hs * (2 * mOctaveCount - 1) / (mOctaveCount * mOctaveCount * 2)
    ' Çàäàåì óãîë ðàçâåðòêè
    ma = IIf(Symmetrical, 180, 360)
    ' Çàäàåì íà÷àëüíûå çíà÷åíèÿ äëÿ ðàäèóñà è èíäåêñà ñïåêòðà
    s = OctAreaSize: i1 = 1
    
    ' Ïðîõîä ïî îêòàâàì
    For o = 0 To mOctaveCount - 1
        ' Íàõîäèì èíäåêñ ñëåäóþùåé îêòàâû
        i2 = i1 * 2
        ' Íàõîäèì ïðèðàùåíèå óãëà
        d = ma / (i2 - i1)
        ' Óñòàíàâëèâàåì íà÷àëüíûé óãîë
        a = -90 + d / 2
        ' Åñëè ðàçìåð äóãè < 2 ïèêñåëåé è ðåæèì îòîáðàæåíèÿ êîëüöàìè, òî ðèñóåì ëèíèþ
        If 6.28318530717959 * s * (d / 360) < 2 And View = 0 Then
            Do While i1 < i2
                ' Íàõîäèì êîîðäèíàòû ëèíèè
                MapData(i1).IsLine = True
                MapData(i1).fa = Cos(a * 1.74532925199433E-02)
                MapData(i1).ta = Sin(a * 1.74532925199433E-02)
                a = a + d: i1 = i1 + 1
            Loop
        Else
            Do While i1 < i2
                ' Íàõîäèì óãëû
                MapData(i1).IsLine = False
                MapData(i1).fa = a - d / 2: MapData(i1).ta = d
                a = a + d: i1 = i1 + 1
            Loop
        End If
        ' Ñìåùåíèå íà ðàçìåð îêòàâû â ïèêñåëÿõ
        s = s + OctAreaSize
    Next
End Sub
 
' Ñîçäàíèå ïàëèòðû ïî óìîë÷àíèþ äëÿ êîëüöåâîãî îòîáðàæåíèÿ
Private Sub CreateDefaultRingPalette()
    Dim i As Long, a As Long
    ' Åñëè çàãðóæåíà âíåøíÿÿ ïàëèòðà, òî âûõîäèì
    If ExternalPalette Then Exit Sub
    ReDim Palette(255)
    For i = 0 To 255
        a = (Log((i / 128) + 1) / 0.693147180559945) / 2 * 255
        Palette(i) = ARGB(a, RGB(255 - i, 0, i))
    Next
End Sub
' Ñîçäàíèå ïàëèòðû ïî óìîë÷àíèþ äëÿ ñåêòîðíîãî îòîáðàæåíèÿ
Private Sub CreateDefaultSectorPalette()
    Dim i As Long, a As Long
    ' Åñëè çàãðóæåíà âíåøíÿÿ ïàëèòðà, òî âûõîäèì
    If ExternalPalette Then Exit Sub
    ReDim Palette(255)
    For i = 0 To 255
        a = (Log((i / 128) + 1) / 0.693147180559945) / 2 * 255
        Palette(i) = ARGB(255, RGB(255 - i, 0, i))
    Next
End Sub
' Áûñòðîå ïðåîáðàçîâàíèå Ôóðüå
Private Sub FFT(Dat() As Complex)
    Dim i As Long, j As Long, n As Long, K As Long, io As Long, ie As Long, in_ As Long, nn As Long
    Dim u As Complex, tp As Complex, tq As Complex, w As Complex, sr As Single, t As Complex
    
    If Not FFTInit Then InitFFT: FFTInit = True
    
    nn = mFFTSize \ 2: ie = mFFTSize
    For n = 1 To mFFTLog
        w = Coef(mFFTLog - n)
        in_ = ie \ 2: u.r = 1: u.i = 0
        For j = 0 To in_ - 1
            For i = j To mFFTSize - 1 Step ie
                io = i + in_
                tp.r = Dat(i).r + Dat(io).r: tp.i = Dat(i).i + Dat(io).i
                tq.r = Dat(i).r - Dat(io).r: tq.i = Dat(i).i - Dat(io).i
                Dat(io).r = tq.r * u.r - tq.i * u.i
                Dat(io).i = tq.i * u.r + tq.r * u.i
                Dat(i) = tp
            Next
            sr = u.r
            u.r = u.r * w.r - u.i * w.i
            u.i = u.i * w.r + sr * w.i
        Next
        ie = ie \ 2
    Next
    j = 1
    For i = 1 To mFFTSize - 1
        If i < j Then
            io = i - 1: in_ = j - 1: tp = Dat(in_)
            Dat(in_) = Dat(io)
            Dat(io) = tp
        End If
        K = nn
        Do While K < j
            j = j - K: K = K \ 2
        Loop
        j = j + K
    Next
    If mView = 0 Then sr = (4096 * mGain) / mFFTSize Else sr = 1 / mFFTSize
    For i = 0 To mFFTSize \ 2 - 1
        Dat(i).r = Dat(i).r * sr: Dat(i).i = Dat(i).i * sr
    Next
End Sub
 
' Èíèöèàëèçàöèÿ êîýôôèöèåíòîâ FFT
Private Sub InitFFT()
    Dim n As Long, vRcoef As Variant, vIcoef As Variant
    vRcoef = Array(-1#, 0#, 0.707106781186547 _
          , 0.923879532511287, 0.98078528040323, 0.995184726672197 _
          , 0.998795456205172, 0.999698818696204, 0.999924701839145 _
          , 0.999981175282601, 0.999995293809576, 0.999998823451702 _
          , 0.999999705862882, 0.999999926465718)
    vIcoef = Array(0#, -1#, -0.707106781186547 _
         , -0.38268343236509, -0.195090322016128, -9.80171403295606E-02 _
         , -0.049067674327418, -2.45412285229122E-02, -1.22715382857199E-02 _
         , -6.1358846491544E-03, -3.0679567629659E-03, -1.5339801862847E-03 _
         , -7.669903187427E-04, -3.834951875714E-04)
    For n = 0 To 13
        Coef(n).r = vRcoef(n): Coef(n).i = vIcoef(n)
    Next
End Sub
 
' Èíèöèàëèçàöèÿ êîýôôèöèåíòîâ îêíà Õåììèíãà
Private Sub InitHamming()
    Dim n As Long
    ReDim Window(mFFTSize - 1)
    For n = 0 To mFFTSize - 1
        Window(n) = 0.53836 - 0.46164 * Cos(6.28318530717959 * n / (mFFTSize - 1))
    Next
End Sub

Option Explicit
 
' Ìîäóëü modAudio.bas äëÿ çàõâàòà çâóêà â ïðîãðàììå TrickSpectrum
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Public 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
 
Public 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 Type BUFFER                                              ' Ñòðóêòóðà áóôåðà
    Data() As Integer                                           ' Äàííûå
    Header As WAVEHDR                                           ' Çàãîëîâîê
End Type
 
Public Declare Function waveInOpen Lib "winmm.dll" (lphWaveIn As Long, ByVal uDeviceID As Long, lpFormat As WAVEFORMATEX, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Public Declare Function waveInPrepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInReset Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStart Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInStop Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInUnprepareHeader Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
Public Declare Function waveInClose Lib "winmm.dll" (ByVal hWaveIn As Long) As Long
Public Declare Function waveInGetErrorText Lib "winmm.dll" Alias "waveInGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long
Public Declare Function waveInAddBuffer Lib "winmm.dll" (ByVal hWaveIn As Long, lpWaveInHdr As WAVEHDR, ByVal uSize As Long) As Long
 
Public Const mSampleRate As Long = 44100                        ' ×àñòîòà äèñêðåòèçàöèè
Public Const BufSizeMS As Single = 0.03                         ' Ðàçìåð áóôåðà â ñåêóíäàõ
 
Public Const WAVE_MAPPER = -1&
Public Const CALLBACK_WINDOW = &H10000
Public Const WAVE_FORMAT_PCM = 1
Public Const MM_WIM_DATA = &H3C0
 
Dim hWave As Long                                               ' Äåñêðèïòîð çàïèñûâàþùåãî óñòðîéñòâà
Dim Fmt As WAVEFORMATEX                                         ' Ôîðìàò çàïèñè
Dim Buffers() As BUFFER                                         ' Áóôåðû
 
' Ôóíêöèÿ èíèöèàëèçèðóåò çàïèñü
Public Function InitCapture() As Boolean
    Dim ret As Long, msg As String, i As Long, count As Long
    
    ' Çàäàåì ôîðìàò çàïèñè
    With Fmt
        .cbSize = 0
        .wFormatTag = WAVE_FORMAT_PCM
        .wBitsPerSample = 16
        .nSamplesPerSec = mSampleRate
        .nChannels = 2
        .nBlockAlign = .nChannels * .wBitsPerSample / 8
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
    
    ' Âû÷èñëÿåì ðàçìåð áóôåðà â âûáîðêàõ
    count = Fmt.nAvgBytesPerSec * BufSizeMS
    count = count - (count Mod Fmt.nBlockAlign)
    
    ' Îòêðûâàåì óñòðîéñòâî çàïèñè
    ret = waveInOpen(hWave, WAVE_MAPPER, Fmt, frmMain.hwnd, 0, CALLBACK_WINDOW)
    
    If ret Then ShowMessage ret: Exit Function
    
    ' 4 áóôåðà
    ReDim Buffers(3)
    
    ' Ïîäãîòîâêà áóôåðîâ
    For i = 0 To UBound(Buffers)
         With Buffers(i)
             ReDim .Data(count - 1)
             .Header.lpData = VarPtr(.Data(0))
             .Header.dwBufferLength = count * 2
             .Header.dwFlags = 0
             .Header.dwLoops = 0
             ret = waveInPrepareHeader(hWave, .Header, Len(.Header))
             If ret Then ShowMessage ret: Exit Function
         End With
    Next i
    
    ' Îòïðàâêà áóôåðîâ óñòðîéñòâó
    For i = 0 To UBound(Buffers)
        ret = waveInAddBuffer(hWave, Buffers(i).Header, Len(Buffers(i).Header))
        If ret Then ShowMessage ret: Exit Function
    Next i
    
    ' Íà÷èíàåì çàïèñü
    ret = waveInStart(hWave)
    If ret Then ShowMessage ret: Exit Function
    
    ' Óñïåøíî
    InitCapture = True
End Function
 
' Ïðîöåäóðà îñòàíàâëèâàåò çàïèñü
Public Sub EndCapture()
    Dim i As Long
    ' Ñáðîñ óñòðîéñòâà è âîçâðàùåíèå âñåõ áóôåðîâ ïðèëîæåíèþ
    waveInReset hWave
    ' Îñòàíîâêà çàïèñè
    waveInStop hWave
    
    ' ÎÑâîáîæäåíèå çàãîëîâêîâ áóôåðîâ
    For i = 0 To UBound(Buffers)
        waveInUnprepareHeader hWave, Buffers(i).Header, Len(Buffers(i).Header)
    Next
    
    ' Çàêðûòèå óñòðîéñòâà çàïèñè
    waveInClose hWave
End Sub
 
' Ôóíêöèÿ âûçûâàåòñÿ ïðè î÷åðåäíîì çàïîëíåííîì áóôåðå
Public Function OnCapture(Hdr As WAVEHDR) As Boolean
    Dim i As Long
    ' Ïîëó÷àåì èíäåêñ áóôåðà
    i = modAudio.GetBufferIndex(Hdr.lpData)
    If i = -1 Then Exit Function
    ' Âûçûâàåì îòðèñîâêó
    modMain.Draw modAudio.Buffers(i).Data
    ' Îòïðàâêà áóôåðà óñòðîéñòâó
    waveInAddBuffer hWave, Buffers(i).Header, Len(Buffers(i).Header)
End Function
 
' Ôóíêöèÿ âîçâðàùàåò èíäåêñ áóôåðà ïî åãî óêàçàòåëþ
Private Function GetBufferIndex(ByVal Ptr As Long) As Long
    Dim i As Long
    For i = 0 To UBound(Buffers)
        If Buffers(i).Header.lpData = Ptr Then GetBufferIndex = i: Exit Function
    Next
    GetBufferIndex = -1
End Function
 
' Ïðîöåäóðà ïîêàçûâàåò ñîîáùåíèå îá îøèáêå
Private Sub ShowMessage(ByVal Code As Long)
    Dim msg As String
    msg = Space(255)
    waveInGetErrorText Code, msg, Len(msg)
    MsgBox "Error capture." & vbNewLine & msg
End Sub

Option Explicit
 
' Ìîäóëü modGraphics.bas äëÿ èíèöèàëèçàöèè è ðàáîòû GDI+ â ïðîãðàììå TrickSpectrum
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Public Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
 
Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, Graphics As Long) As Long
Public Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, Pen As Long) As Long
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Public Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Public Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal ARGB As Long, Brush As Long) As Long
Public Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, ByVal SmoothingMd As Long) As Long
Public Declare Function GdipGetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, SmoothingMd As Long) As Long
Public Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Public Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal Brush As Long, ByVal ARGB As Long) As Long
Public Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, Bitmap As Long) As Long
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Public Declare Function GdipFillEllipse Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Public Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Public Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics As Long) As Long
Public Declare Function GdipDrawImageI Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Public Declare Function GdipDrawLine Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single) As Long
Public Declare Function GdipDeletePen Lib "gdiplus" (ByVal Pen As Long) As Long
Public Declare Function GdipSetPenColor Lib "gdiplus" (ByVal Pen As Long, ByVal ARGB As Long) As Long
Public Declare Function GdipDrawArc Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single, ByVal startAngle As Single, ByVal sweepAngle As Single) As Long
Public Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal Pen As Long, ByVal Width As Single) As Long
Public Declare Function GdipSetPenMode Lib "gdiplus" (ByVal Pen As Long, ByVal penMode As Long) As Long
Public Declare Function GdipFillPie Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single, ByVal startAngle As Single, ByVal sweepAngle As Single) As Long
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, image As Long) As Long
Public Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal image As Long, PixelFormat As Long) As Long
Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Public Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal Bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As Long
 
Public Const UnitPixel = 2, _
             SmoothingModeAntiAlias = 4, _
             SmoothingModeHighSpeed = 1, _
             PixelFormat32bppARGB = &H26200A, _
             PixelFormat32bppPARGB = &HE200B, _
             FillModeAlternate = 0, _
             CombineModeExclude = 4, _
             PenAlignmentInset = 1
             
Dim token As Long
Dim si As GdiplusStartupInput
 
' Èíèöèàëèçàöèÿ GDI+
Public Function InitGDIPlus() As Boolean
    si.GdiplusVersion = 1
    InitGDIPlus = GdiplusStartup(token, si) = 0
End Function
 
' Äåèíèöèàëèçàöèÿ GDI+
Public Sub UninitGDIPlus()
    GdiplusShutdown token
End Sub
 
' Âîçâðàùàåò öâåò, ïåðåäàííûé â êà÷åñòâå ïàðàìåòðà ñ ïîäìåøèâàíèåì àëüôà êîìïîíåíòû
Public Function ARGB(ByVal Alpha As Byte, ByVal Col As Long) As Long
    If Alpha > 127 Then
        ARGB = Col And &HFFFFFF Or ((CLng(Alpha) - 256) * &H1000000)
    Else: ARGB = Col And &HFFFFFF Or (CLng(Alpha) * &H1000000)
    End If
End Function

Option Explicit
 
' Ìîäóëü modMenu.bas äëÿ ñîçäàíèÿ ìåíþ â ïðîãðàììå TrickSpectrum
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Public Type POINTAPI
    x As Long
    y As Long
End Type
 
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, lpTPMParams As Any) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Public Const WM_CLOSE = &H10
Public Const MF_CHECKED = &H8&
Public Const MF_UNCHECKED = &H0&
Public Const MF_APPEND = &H100&
Public Const TPM_LEFTALIGN = &H0&
Public Const MF_DISABLED = &H2&
Public Const MF_GRAYED = &H1&
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const MF_POPUP = &H10&
Public Const MF_BYPOSITION = &H400&
 
' Äåñêðèïòîðû ìåíþ
Public mnuMain As Long, _
       mnuOct As Long, _
       mnuTransparency As Long, _
       mnuFade As Long, _
       mnuGain As Long, _
       mnuEffects As Long, _
       mnuView As Long
 
' Ïðîöåäóðà èíèöèàëèçèðóåò âñïëûâàþùåå ìåíþ
Public Sub CreateMenu()
    Dim i As Long, z As Long
    
    mnuMain = CreatePopupMenu
    mnuOct = CreatePopupMenu
    mnuTransparency = CreatePopupMenu
    mnuFade = CreatePopupMenu
    mnuGain = CreatePopupMenu
    mnuEffects = CreatePopupMenu
    mnuView = CreatePopupMenu
    
    AppendMenu mnuMain, MF_STRING Or MF_POPUP, mnuView, "View"
    AppendMenu mnuMain, MF_STRING, z, "Symmetrical": z = z + 1
    AppendMenu mnuMain, MF_STRING, z, "Smoothing": z = z + 1
    AppendMenu mnuMain, MF_STRING, z, "Transparent": z = z + 1
    AppendMenu mnuMain, MF_STRING, z, "About...": z = z + 1
    AppendMenu mnuMain, MF_STRING Or MF_POPUP, mnuOct, "Octaves count"
    AppendMenu mnuMain, MF_STRING Or MF_POPUP, mnuTransparency, "Background opaque"
    AppendMenu mnuMain, MF_STRING Or MF_POPUP, mnuFade, "Fade"
    AppendMenu mnuMain, MF_STRING Or MF_POPUP, mnuGain, "Gain"
    AppendMenu mnuMain, MF_STRING Or MF_POPUP, mnuEffects, "Effects"
    AppendMenu mnuMain, MF_SEPARATOR, 0, vbNullString
    AppendMenu mnuMain, MF_STRING, z, "Load palette...": z = z + 1
    AppendMenu mnuMain, MF_SEPARATOR, 0, vbNullString
    AppendMenu mnuMain, MF_STRING, z, "Exit": z = z + 1
 
    AppendMenu mnuEffects, MF_STRING, 500, "None"
    AppendMenu mnuEffects, MF_STRING, 501, "Blur"
    AppendMenu mnuEffects, MF_STRING, 502, "Fire"
 
    AppendMenu mnuView, MF_STRING, 600, "Rings"
    AppendMenu mnuView, MF_STRING, 601, "Sectors"
    
    For i = 1 To 10
        If i > 1 Then AppendMenu mnuOct, MF_STRING, 100 + i, CStr(i)
        AppendMenu mnuTransparency, MF_STRING, 200 + i, Format(i / 10, "###%")
        AppendMenu mnuFade, MF_STRING, 300 + i, Format(i * i / 100, "###%")
        AppendMenu mnuGain, MF_STRING, 400 + i, Format(i, "###%")
    Next
    
End Sub
 
' Ïðîöåäóðà óäàëÿåò ìåíþ
Public Sub DeleteMenu()
    DestroyMenu mnuMain
    DestroyMenu mnuOct
    DestroyMenu mnuTransparency
    DestroyMenu mnuFade
    DestroyMenu mnuGain
    DestroyMenu mnuEffects
    DestroyMenu mnuView
End Sub
 
' Ôóíêöèÿ âûçûâàåòñÿ ïðè ïðàâîì êëèêå ìûøüþ íà îêíå
Public Function OnRButtonUp(ByVal x As Long, ByVal y As Long) As Long
    TrackPopupMenuEx mnuMain, TPM_LEFTALIGN, x, y, frmMain.hwnd, ByVal 0&
End Function
 
' Ôóíêöèÿ âûçûâàåòñÿ ïðè âûáîðå ïóíêòà ìåíþ
Public Function OnMenuClick(ByVal itemID As Long) As Long
    Dim s As String
    Select Case itemID
    Case 0 ' Symmetrical
        modMain.Symmetrical = Not modMain.Symmetrical
    Case 1 ' Smoothing
        modMain.Smoothing = Not modMain.Smoothing
    Case 2 ' Transparent
        modMain.Transparent = Not modMain.Transparent
    Case 3 ' About
        frmAbout.Show vbModal
    Case 4 ' LoadPalette
        s = modOpenFileName.GetFile()
        If Len(s) Then modMain.LoadPalette s
    Case 5 ' Exit
        Quit
        PostMessage frmMain.hwnd, WM_CLOSE, 0, 0
    Case 101 To 110 ' Octave count
        modMain.OctaveCount = itemID - 100
    Case 201 To 210 ' Background opaque
        modMain.Transparency = (itemID - 200) / 10
    Case 301 To 310 ' Fade
        modMain.Fade = ((itemID - 300) ^ 2) / 100
    Case 401 To 410 ' Gain
        modMain.Gain = itemID - 400
    Case 500 To 510 ' Effect
        modMain.Effect = itemID - 500
    Case 600 To 610 ' View
        modMain.View = itemID - 600
    End Select
End Function

Option Explicit
 
' Ìîäóëü modOpenFileName.bas äëÿ âûçîâà äèàëîãîâîãî îêíà îòêðûòèÿ ôàéëà â ïðîãðàììå TrickSpectrum
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Public Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As Long
    lpstrCustomFilter As Long
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As Long
    nMaxFile As Long
    lpstrFileTitle As Long
    nMaxFileTitle As Long
    lpstrInitialDir As Long
    lpstrTitle As Long
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type
 
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long
 
' Îòêðûòü äèàëîã âûáîðà ôàéëà è ïîëó÷èòü èìÿ âûáðàííîãî ôàéëà
Public Function GetFile() As String
    Dim ofn As OPENFILENAME
    Dim Out As String
    Dim i As Long
    
    ofn.nMaxFile = 260
    Out = String(260, vbNullChar)
    ofn.hwndOwner = frmMain.hwnd
    ofn.lpstrTitle = StrPtr("Open image")
    ofn.lpstrFile = StrPtr(Out)
    ofn.lStructSize = Len(ofn)
    ofn.lpstrFilter = StrPtr("PNG with alpha channel" & vbNullChar & "*.png" & vbNullChar)
    If GetOpenFileName(ofn) Then
        i = InStr(1, Out, vbNullChar, vbBinaryCompare)
        If i Then GetFile = Left$(Out, i - 1)
    End If
End Function

Option Explicit
 
' Ìîäóëü modWndProc.bas äëÿ ñàáêëàññèíãà îêíà â ïðîãðàììå TrickSpectrum
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Const HWND_TOPMOST As Long = -1
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE As Long = -20
Public Const GWL_WNDPROC = (-4)
Public Const ULW_ALPHA = &H2
Public Const AB_32Bpp255 = 33488896
Public Const HTCAPTION As Long = 2
Public Const WM_NCRBUTTONUP = &HA5
Public Const WM_NCLBUTTONDBLCLK = &HA3
Public Const WM_COMMAND = &H111
Public Const WM_NCHITTEST = &H84
Public Const WM_SIZE = &H5
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2&
 
Dim PrevWndProc As Long
 
' Ïðîöåäóðà ñàáêëàññèò îêíî
Public Sub Hook()
    SetWindowPos frmMain.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
    PrevWndProc = SetWindowLong(frmMain.hwnd, GWL_WNDPROC, AddressOf WndProc)
End Sub
 
' Ïðîöåäóðà ñíèìàåò ñàáêëàññèíã ñ îêíà
Public Sub Unhook()
    SetWindowLong frmMain.hwnd, GWL_WNDPROC, PrevWndProc
End Sub
 
' Îêîííàÿ ôóíêöèÿ îêíà
Private Function WndProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case msg
    Case MM_WIM_DATA
        ' Ïðè çàïîëíåíèè î÷åðåäíîãî áóôåðà
        Dim Hdr As WAVEHDR
        ' Êîïèðóåì çàãîëîâîê
        CopyMemory Hdr, ByVal lParam, Len(Hdr)
        ' Âûçûâàåì ôóíêöèþ
        OnCapture Hdr
    Case WM_NCHITTEST
        ' Îïðåäåëåíèå ïîëîæåíèÿ ìûøè
        WndProc = HTCAPTION
    Case WM_NCRBUTTONUP
        ' Îòïóñêàíèå ïðàâîé êíîïêè ìûøè â íåêëèåíòñêîé îáëàñòè
        WndProc = OnRButtonUp(IIf(lParam And &H8000&, lParam Or &HFFFF0000, lParam And &HFFFF&), lParam \ &H10000)
    Case WM_COMMAND
        ' Êëèê ïî ìåíþ
        If (wParam And &HFFFF0000) = 0 Then
            ' Åñëè ïî ìåíþ, òî âûçîâ ôóíêöèè
            WndProc = OnMenuClick(wParam)
        Else: WndProc = CallWindowProc(PrevWndProc, hwnd, msg, wParam, lParam)
        End If
    Case WM_SIZE
        ' Ïðè èçìåíåíèè ðàçìåðà
        OnResize
    Case Else: WndProc = CallWindowProc(PrevWndProc, hwnd, msg, wParam, lParam)
    End Select
End Function

Option Explicit
 
Private Sub Form_Load()
    Me.Caption = "About " & App.Title
    lblTitle.Caption = App.Title
    lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
End Sub