[VB6] - Circular spectrum visualizer.

http://www.youtube.com/watch?v=h9qteZBkwww

Hello everyone! I wrote the source code of the graphical audio spectrum visualizer. The sound is analyzed through a standard recording device, i.e. you can select the microphone and view its spectrum, or you can select stereo mixer and view a spectrum of a playback sound.
This visualizer allows to adjust the number of displayed octaves, transparency of background and amplification.
You can also load a palette from an external PNG file with 32ARGB format. It also supports the following effects: "blur" and "burning". You can view a spectrum of a signal represented in the two modes: arcs (rings) and sectors (pies). If you use the ring view an octave is mapped to radial coordinate and a semitone to angle. The separated harmonics are placed along the same line; color represents an intensity. The sectors view maps the amount of signal to the radial coordinate, the frequency in octaves to the color, the frequency in semitones to the angular coordinate.
This idea was suggested to me by Vladislav Petrovky (aka Hacker). His idea was a little different.

HOW DOES IT WORK?

Initially it creates the buffers for sound and buffer bitmaps. Further it starts the sound capture process and waits when a buffer will be filled. When a buffer has been filled it begins processing. Firstly it performs the Fast Fourier Transform in order to transform a signal to the frequency domain form. Before performing it applies the Hamming window in order to reduce distortions because a signal has discontinuity at the edges of a buffer. When a signal has been translated to the frequency domain the buffer contains complex value that represent the vectors. The module (length) of a vector implies the energy of signal in that frequency and the argument (angle) implies phase of a harmonic in that frequency:

http://www.vbforums.com/images/ieimages/2015/02/1.gif

We need the energy of frequency although the phase information allows to determine the frequency more accurately considering the phase difference. I don't use phase information in this project. The drawing method is different for each appearance mode. In order to boost the work it uses the precalculated coordinates named MapData. This array contains the angles of arcs and sectors for the current appearance mode. When coordinates has been calculated it calculates the amount of frequency for each FFT bin figuring out the length of a vector. This value is uses as the index in the color palette after converting the value to a range from 0 to 255. Further GDI+ draws the necessary primitives depending on the appearance mode. Note that all drawing occur onto the buffer bitmap not on window. I specially have not mentioned about the Release procedure that animates the background. This procedure applies an effect to the buffer bitmap before signal processing. It uses the Fade property that determines the speed of the disappearance of previous drawing bitmap. It just decrease the alpha value of the entire bitmap. When you use an effect it also works with the bits of the buffer bitmap and decreases the alpha value. For instance, if the blur effect has been selected it averages the near pixels (analog of low-pass filtering) then it decreases the alpha value for all pixels depending on Fade property. Eventually it draws buffer bitmap onto the main window. Thus it draws the energy of the spectrum of signal in the polar coordinates. It can be used as the start point for the notes or chord recognition. Thank for attention!
Regards,
Кривоус Анатолий (The trick).

modAudio.bas module:

Code:

---

' // modAudio.bas - module for audio capture
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Public Type WAVEFORMATEX      ' // Audio format structure
    wFormatTag      As Integer ' // Audio type (WAVE/MP3/etc.)
    nChannels      As Integer ' // Number of channels (mono/stereo)
    nSamplesPerSec  As Long    ' // Sample rate
    nAvgBytesPerSec As Long    ' // Number of bytes per second
    nBlockAlign    As Integer ' // One block (all channels) align in bytes
    wBitsPerSample  As Integer ' // Number of bits per sample
    cbSize          As Integer ' // Number of extra bytes
End Type

Public Type WAVEHDR            ' // Buffer header structure
    lpData          As Long    ' // Pointer to buffer data
    dwBufferLength  As Long    ' // Size of buffer in bytes
    dwBytesRecorded As Long    ' // Number of written bytes
    dwUser          As Long    ' // User data
    dwFlags        As Long    ' // Flags
    dwLoops        As Long    ' // Number of playings
    lpNext          As Long
    Reserved        As Long
End Type

Public Type BUFFER            ' // Buffer structure
    Data()          As Integer ' // Data
    Header          As WAVEHDR ' // Header
End Type

Public Declare Function waveInOpen Lib "winmm.dll" ( _
                        ByRef lphWaveIn As Long, _
                        ByVal uDeviceID As Long, _
                        ByRef 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, _
                        ByRef 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, _
                        ByRef 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, _
                        ByRef lpWaveInHdr As WAVEHDR, _
                        ByVal uSize As Long) As Long

Public Const mSampleRate    As Long = 44100    ' // Default sample rate
Public Const BufSizeMS      As Single = 0.03  ' // Size of buffer in ms
Public Const WAVE_MAPPER    As Long = -1&
Public Const CALLBACK_WINDOW As Long = &H10000
Public Const WAVE_FORMAT_PCM As Long = 1
Public Const MM_WIM_DATA    As Long = &H3C0

Dim hWave      As Long        ' // Handle of wave input device
Dim Fmt        As WAVEFORMATEX ' // Current format of capture
Dim Buffers()  As BUFFER      ' // Buffers

' // This function initializes capture
Public Function InitCapture() As Boolean
    Dim ret    As Long
    Dim msg    As String
    Dim i      As Long
    Dim count  As Long
   
    ' // Set format of capture
    With Fmt
        .cbSize = 0
        .wFormatTag = WAVE_FORMAT_PCM
        .wBitsPerSample = 16
        .nSamplesPerSec = mSampleRate
        .nChannels = 2
        .nBlockAlign = .nChannels * .wBitsPerSample / 8
        .nAvgBytesPerSec = .nSamplesPerSec * .nBlockAlign
    End With
   
    ' // Calculate size of buffer in samples
    count = Fmt.nAvgBytesPerSec * BufSizeMS
    count = count - (count Mod Fmt.nBlockAlign)
   
    ' // Open default recording device
    ret = waveInOpen(hWave, WAVE_MAPPER, Fmt, frmMain.hwnd, 0, CALLBACK_WINDOW)
   
    If ret Then ShowMessage ret: Exit Function
   
    ' // Create 4 buffers
    ReDim Buffers(3)
   
    ' // Prepare buffers
    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
   
    ' // Send buffers to device
    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
   
    ' // Begin recording (capture)
    ret = waveInStart(hWave)
    If ret Then ShowMessage ret: Exit Function
   
    ' // Success
    InitCapture = True
   
End Function

' // Stop capture
Public Sub EndCapture()
    Dim i As Long
   
    ' // Reset device and return all the buffers to application
    waveInReset hWave
    ' // Stop capture
    waveInStop hWave
   
    ' // Release buffers headers
    For i = 0 To UBound(Buffers)
        waveInUnprepareHeader hWave, Buffers(i).Header, Len(Buffers(i).Header)
    Next
   
    ' // Close capture device
    waveInClose hWave
   
End Sub

' // This function is called when a buffer has been filled
Public Function OnCapture( _
                ByRef Hdr As WAVEHDR) As Boolean
    Dim i As Long
   
    ' // Get buffer index
    i = modAudio.GetBufferIndex(Hdr.lpData)
    If i = -1 Then Exit Function
   
    ' // Redraw
    modMain.Draw modAudio.Buffers(i).Data
   
    ' // Send buffer to device
    waveInAddBuffer hWave, Buffers(i).Header, Len(Buffers(i).Header)
   
End Function

' // This function returns buffer index by pointer
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

' // This procedure shows an error message
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

---

modMain.bas module:

Code:

---

' // modMain.bas - the main module of TrickSpectrum application
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Private Type View      ' // Type of appearance
    fa      As Single  ' // Start angle
    ta      As Single  ' // Width angle
    IsLine  As Boolean ' // Determine if it is line
End Type

Public Type Complex    ' // Complex number
    r      As Single
    i      As Single
End Type

Private mFFTSize        As Long    ' // Size of FFT
Private mFFTLog        As Long    ' // Log2(FFTSize)
Private mOctaveCount    As Long    ' // Number of octaves
Private mSymmetrical    As Boolean ' // Symmetrical appearance
Private mFade          As Single  ' // Fade background coefficient
Private mTransparency  As Single  ' // Transparency
Private mEffect        As Long    ' // Current background effect
Private mGain          As Long    ' // Gain
Private mTransparent    As Boolean ' // Use transparent window
Private mView          As Long    ' // Appearance mode (0 - Rings, 1 - Sectors)

Dim MapData()          As View    ' // Mapping of frequency onto coordinate
Dim Spectrum()          As Complex ' // FFT result
Dim Window()            As Single  ' // Hamming window
Dim Palette()          As Long    ' // Palette
Dim imgSpectrum        As Long    ' // Image of spectrum
Dim imgSpectrumData()  As Long    ' // Pixels of specturm image
Dim grWindow            As Long    ' // GDI+ graphics of window
Dim grSpectrum          As Long    ' // GDI+ graphics of buffer
Dim Brush              As Long    ' // Brush for filling of circle and segments
Dim Pen                As Long    ' // Pen for drawing of arcs and lines
Dim OctAreaSize        As Single  ' // Size of octave area in pixels
Dim Coef(13)            As Complex ' // Rotaion coefficients for FFT
Dim FFTInit            As Boolean ' // Is initialized FFT coefficients
Dim ExternalPalette    As Boolean ' // Is external palette loaded

' // FFT size property
Public Property Let FFTSize( _
                    ByVal lNewValue As Long)
    Dim lg As Single
   
    ' // Check if it is multiple of 2
    lg = Log(lNewValue) / 0.693147180559945
    If lg <> Fix(lg) Then Exit Property
    ' // Check out of range
    If lg > mOctaveCount Or lg < 8 Then Exit Property
    mFFTSize = lNewValue
    mFFTLog = lg
   
    ' // Update buffers sizes
    UpdateBuffers
    ' // Update map coordiantes
    CreateMap
   
End Property
Public Property Get FFTSize() As Long
    FFTSize = mFFTSize
End Property

' // Number of shown octaves
Public Property Let OctaveCount( _
                    ByVal lNewValue As Long)

    ' // Check out of range
    If lNewValue > mFFTLog Or lNewValue < 2 Then Exit Property
    ' // Uncheck previous menu item
    CheckMenuItem mnuOct, mOctaveCount - 2, MF_BYPOSITION Or MF_UNCHECKED
    mOctaveCount = lNewValue
    ' // Check new menu item
    CheckMenuItem mnuOct, mOctaveCount - 2, MF_BYPOSITION Or MF_CHECKED
    ' // Update map coordiantes
    CreateMap
   
End Property
Public Property Get OctaveCount() As Long
    OctaveCount = mOctaveCount
End Property

' // Antialiasing property
Public Property Let Smoothing( _
                    ByVal bNewValue As Boolean)

    GdipSetSmoothingMode grSpectrum, IIf(bNewValue, SmoothingModeAntiAlias, SmoothingModeHighSpeed)
    ' // Check menu item
    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

' // Symmetric appearance property
Public Property Let Symmetrical( _
                    ByVal bNewValue As Boolean)

    mSymmetrical = bNewValue
    ' // Check menu item
    CheckMenuItem mnuMain, 0, IIf(bNewValue, MF_CHECKED, MF_UNCHECKED)
    ' // Update map coordiantes
    CreateMap
    ' // Create buffer bitmap
    CreateSpectrumBitmap
   
End Property
Public Property Get Symmetrical() As Boolean
    Symmetrical = mSymmetrical
End Property

' // Is transparent window or not?
Public Property Let Transparent( _
                    ByVal bNewValue As Boolean)
    Dim hRgn As Long
   
    mTransparent = bNewValue
    ' // Check menu item
    CheckMenuItem mnuMain, 2, IIf(bNewValue, MF_CHECKED, MF_UNCHECKED)
   
    If mTransparent Then
   
        ' // If transparent
        ' // Reset window region
        SetWindowRgn frmMain.hwnd, 0, True
        ' // Set layered style to window
        SetWindowLong frmMain.hwnd, GWL_EXSTYLE, GetWindowLong(frmMain.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
       
    Else
   
        ' // If opaque
        ' // Remove layered style
        SetWindowLong frmMain.hwnd, GWL_EXSTYLE, GetWindowLong(frmMain.hwnd, GWL_EXSTYLE) And (Not WS_EX_LAYERED)
        ' // Create round region
        hRgn = CreateEllipticRgn(0, 0, frmMain.ScaleWidth, frmMain.ScaleWidth)
        ' // Set it to window
        SetWindowRgn frmMain.hwnd, hRgn, True
       
    End If
   
End Property
Public Property Get Transparent() As Boolean
    Transparent = mTransparent
End Property

' // Background effect property
Public Property Let Effect( _
                    ByVal lNewValue As Long)

    ' // Uncheck previous menu item
    CheckMenuItem mnuEffects, mEffect, MF_BYPOSITION Or MF_UNCHECKED
    mEffect = lNewValue
    ' // Check menu item
    CheckMenuItem mnuEffects, mEffect, MF_BYPOSITION Or MF_CHECKED
   
End Property
Public Property Get Effect() As Long
    Effect = mEffect
End Property

' // Fade background property
Public Property Let Fade( _
                    ByVal fNewValue As Single)

    ' // Uncheck previous menu item
    CheckMenuItem mnuFade, Sqr(mFade * 100) - 1, MF_BYPOSITION Or MF_UNCHECKED
    mFade = fNewValue
    ' // Check menu item
    CheckMenuItem mnuFade, Sqr(mFade * 100) - 1, MF_BYPOSITION Or MF_CHECKED
   
End Property
Public Property Get Fade() As Single
    Fade = mFade
End Property

' // Gain during drawing property
Public Property Let Gain( _
                ByVal fNewValue As Single)

    ' // Uncheck previous menu item
    CheckMenuItem mnuGain, mGain - 1, MF_BYPOSITION Or MF_UNCHECKED
    mGain = fNewValue
    ' // Check menu item
    CheckMenuItem mnuGain, mGain - 1, MF_BYPOSITION Or MF_CHECKED
   
End Property
Public Property Get Gain() As Single
    Gain = mGain
End Property

' // Transparency of background property
Public Property Let Transparency( _
                    ByVal fNewValue As Single)

    ' // Uncheck previous menu item
    CheckMenuItem mnuTransparency, mTransparency * 10 - 1, MF_BYPOSITION Or MF_UNCHECKED
    mTransparency = fNewValue
    ' // Check menu item
    CheckMenuItem mnuTransparency, mTransparency * 10 - 1, MF_BYPOSITION Or MF_CHECKED
   
End Property
Public Property Get Transparency() As Single
    Transparency = mTransparency
End Property

' // Appearance mode property
Public Property Let View( _
                    ByVal lNewValue As Long)

    ' // Uncheck previous menu item
    CheckMenuItem mnuView, mView, MF_BYPOSITION Or MF_UNCHECKED
    mView = lNewValue
    CheckMenuItem mnuView, mView, MF_BYPOSITION Or MF_CHECKED
   
    ' // Check menu item
    If mView = 1 Then
        ' // If view mode is sectors
        ' // Set pen width equal 1 pixel for drawing thin sectors
        GdipSetPenWidth Pen, 1
        ' // Create palette without transparencies
        CreateDefaultSectorPalette
        ' // Else create plette with transparencies
    Else: CreateDefaultRingPalette
    End If
   
    ' // Update map coordiantes
    CreateMap
   
End Property
Public Property Get View() As Long
    View = mView
End Property

' // Load palette from the file
Public Function LoadPalette( _
                ByRef FileName As String) As Boolean
    Dim bmp As Long:    Dim pix As Long
    Dim w  As Long:    Dim x  As Long
    Dim i  As Long:    Dim d  As Single
   
    ' // Try to load image
    If GdipLoadImageFromFile(StrPtr(FileName), bmp) Then
        MsgBox "Error opening image"
        Exit Function
    End If
   
    ' // Check pixels format
    GdipGetImagePixelFormat bmp, pix
   
    ' // It should be 32bppARGB
    If pix <> PixelFormat32bppARGB Then
        MsgBox "Unsupported pixel format"
        GdipDisposeImage bmp
        Exit Function
    End If
   
    ' // Check width, valid only greater than 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
   
    ' // Set colors of palette according to image pixels
    For i = 0 To 255
        x = i * d
        GdipBitmapGetPixel bmp, x, 0, Palette(i)
    Next
   
    ExternalPalette = True
   
    GdipDisposeImage bmp
   
End Function

' // Start of program
Public Sub Main()

    ' // Load form
    Load frmMain
   
    ' // Set default parameters
    mFFTSize = 2048: mFFTLog = 11: mOctaveCount = 7: mFade = 0.81
    mTransparency = 0.5: mSymmetrical = False: mGain = 4
    Transparent = False
   
    ' // Update sizes of buffers
    UpdateBuffers
   
    ' // Update map coordiantes
    CreateMap
   
    ' // Initialize GDI+
    If Not InitGDIPlus Then Unload frmMain: Exit Sub
   
    ' // Create pen and brush
    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
   
    ' // Make square form
    frmMain.Height = frmMain.Width
   
    ' // Create default palette
    CreateDefaultRingPalette
   
    ' // Create menu
    CreateMenu
   
    ' // Subclass form
    Hook
   
    ' // Set default checkboxes in menu
    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
   
    ' // Start sound capture
    If Not InitCapture Then Unload frmMain: Exit Sub
   
    ' // Show form
    frmMain.Show
   
End Sub

' // Quit application
Public Sub Quit()

    ' // Clean GDI+ resources
    If grWindow Then GdipDeleteGraphics grWindow
    If imgSpectrum Then GdipDisposeImage imgSpectrum: GdipDeleteGraphics grSpectrum
    If Pen Then GdipDeletePen Pen
    If Brush Then GdipDeleteBrush Brush
   
    ' // GDI+ uninitialization
    UninitGDIPlus
   
    ' // Destroy menu
    DeleteMenu
   
    ' // Unsubclass
    Unhook
   
    ' // Stop sound capture
    EndCapture
   
End Sub

' // This procedure is called when size of form is being changed
Public Sub OnResize()

    ' // If GDI+ graphics object of form has been created then delete it
    If grWindow Then GdipDeleteGraphics grWindow: grWindow = 0
   
    ' // Create new GDI+ graphics object
    If GdipCreateFromHDC(frmMain.hdc, grWindow) Then
        MsgBox "Error create GDI+ graphics"
        Unload frmMain: Exit Sub
    End If
   
    ' // Enable antialiasing
    GdipSetSmoothingMode grWindow, SmoothingModeAntiAlias
   
    ' // Create buffer bitmap ang GDI+ graphics
    If Not CreateSpectrumBitmap Then Exit Sub
   
    ' // Update map coordiantes
    CreateMap
   
End Sub

---

modMain.bas module (continue):

Code:

---

' // This procedure is called when spectum should be drawn
Public Sub Draw( _
          ByRef Wav() As Integer)
    Dim i1  As Long:        Dim i2  As Long
    Dim c  As Long:        Dim sz  As Currency
    Dim pts As Currency:    Dim o  As Long
    Dim Sh  As Single:      Dim Sw  As Single
    Dim q1  As Single:      Dim q2  As Single
    Dim b  As Long:        Dim fl  As Boolean
    Dim m  As Long:        Dim x  As Single
    Dim y  As Single:      Dim a  As Single
    Dim ci  As Long
   
    ' // Transform integer stereo samples to single mono samples.
    ' // Real part of data consist normalized samples, imaginary part consists zeroes
    ToComplex Wav(), Spectrum()
   
    ' // Make FFT
    FFT Spectrum()
   
    ' // If symmetric appearance
    If mSymmetrical Then
        ' // Set horizontal offset to zero
        Sw = 0
    Else
        ' // else half of form
        Sw = (frmMain.ScaleWidth - 1) / 2
    End If
   
    ' // Vertical offset equals half of form
    Sh = (frmMain.ScaleWidth - 1) / 2
   
    ' // Clear window
    GdipGraphicsClear grWindow, ARGB(255, 0)
    ' // Set background transparency
    GdipSetSolidFillColor Brush, ARGB(Transparency * 255, 0)
    ' // Fill background
    GdipFillEllipse grWindow, Brush, 0, 0, frmMain.ScaleWidth - 1, frmMain.ScaleHeight - 1

    ' // Animate background
    Release
   
    ' // First harmonic
    i1 = 1
   
    ' // Check view mode
    Select Case View
    Case 0
        ' // Rings
        ' // Go thru octaves
        For o = 0 To mOctaveCount - 1
       
            ' // Transition flag
            fl = True
            ' // Increase radius of size octave
            q2 = q2 + OctAreaSize
            ' // Get index of next octave
            i2 = i1 * 2
           
            ' // Go thru spectum indexes
            Do While i1 < i2
           
                ' // Calculate amplitude of bin
                b = Sqr(Spectrum(i1).r * Spectrum(i1).r + Spectrum(i1).i * Spectrum(i1).i)
               
                ' // Check out of range
                If b > 255 Then b = 255
               
                ' // Set color depending on amplitude
                GdipSetPenColor Pen, Palette(b)
               
                ' // If line-appearance
                If MapData(i1).IsLine Then
               
                    ' // If transition flag set pen width equals 1 pixels
                    If Not fl Then GdipSetPenWidth Pen, 1: fl = True: q1 = q1 + 4: q2 = q2 + 2
                    ' // Draw line
                    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 transition flag set pen width equals size of octave
                    If fl Then GdipSetPenWidth Pen, OctAreaSize - 2: fl = False
                    ' // Draw arc
                    GdipDrawArc grSpectrum, Pen, Sw - q2, Sh - q2, q2 * 2 - 1, q2 * 2 - 1, MapData(i1).fa, MapData(i1).ta
                   
                End If
               
                ' // Next bin
                i1 = i1 + 1
               
            Loop
           
            ' // Increase radius of size octave
            q1 = q1 + OctAreaSize
           
        Next
       
    Case 1
        ' // Segments
        ' // Gain coefficient
        q1 = (mGain * Gain + 9)
        ' // Index coefficient
        q2 = 255 / ((2 ^ (mOctaveCount + 1)) \ 2)
       
        ' // Go thru octaves
        For o = 0 To mOctaveCount - 1
       
            ' // Get index of next octave
            i2 = i1 * 2
            ' // Go thru spectrum
            Do While i1 < i2
           
                ' // Calculate amplitude and amplify it
                b = (Log(Sqr(Spectrum(i1).r * Spectrum(i1).r + Spectrum(i1).i * Spectrum(i1).i) _
                    + 0.0001) + 9.21034037197618) * q1
                ' // Check out of range
                If b > Sh - 1 Then b = Sh - 1
               
                ' // Omit weak signal
                If b > 1 Then
               
                    ' // Get palette index
                    ci = i1 * q2
                   
                    ' // If width of segment less than 2 pixels then draw line
                    If 6.28318530717959 * b * (MapData(i1).ta / 360) < 2 Then
                   
                        ' // Get angle in radians
                        a = MapData(i1).fa * 1.74532925199433E-02
                        ' // Get coordinates of end of line
                        x = Cos(a) * b + Sw: y = Sin(a) * b + Sh
                        ' // Set pen color depending on frequency
                        GdipSetPenColor Pen, Palette(ci)
                        ' // Draw line
                        GdipDrawLine grSpectrum, Pen, Sw, Sh, x, y
                       
                    Else
                   
                        ' // Set brush color depending on frequency
                        GdipSetSolidFillColor Brush, Palette(ci)
                        ' // Fill pie
                        GdipFillPie grSpectrum, Brush, Sw - b, Sh - b, b * 2, b * 2, MapData(i1).fa, MapData(i1).ta
                       
                    End If
                   
                End If
               
                ' // Next bin
                i1 = i1 + 1
               
            Loop
           
        Next
       
    End Select
   
    ' // Disable antialiasing for fast drawing
    GdipSetSmoothingMode grWindow, SmoothingModeHighSpeed
   
    ' // If set symmetrical view
    If mSymmetrical Then
        ' // Draw two mirrored buffers
        GdipDrawImageRectI grWindow, imgSpectrum, Sh, 0, -Sh, Sh * 2 + 1
        GdipDrawImageI grWindow, imgSpectrum, Sh, 0
    Else
        ' // Draw directly
        GdipDrawImageI grWindow, imgSpectrum, 0, 0
    End If
   
    ' // Set antialiasing
    GdipSetSmoothingMode grWindow, SmoothingModeAntiAlias
   
    ' // Draw to window DC
    frmMain.Refresh
   
    ' // Initialize variable of size
    sz = (frmMain.ScaleWidth + CCur(frmMain.ScaleHeight) * 4294967296#) / 10000
   
    ' // If window is layered update its state
    If mTransparent Then
        UpdateLayeredWindow frmMain.hwnd, frmMain.hdc, ByVal 0, sz, frmMain.hdc, pts, 0, AB_32Bpp255, ULW_ALPHA
    End If
   
End Sub

' // This function creates buffer bitmap and its GDI+ graphics object
Private Function CreateSpectrumBitmap() As Boolean
    Dim s  As Boolean: Dim w  As Long
   
    ' // Save smoothing mode
    s = Smoothing
    ' // Delete GDI+ resources, if any
    If imgSpectrum Then GdipDisposeImage imgSpectrum: GdipDeleteGraphics grSpectrum
    ' // Calculate width of buffer bitmap
    w = IIf(mSymmetrical, frmMain.ScaleWidth / 2, frmMain.ScaleWidth)
    ' // Allocate memory for bits of bitmap
    ReDim imgSpectrumData(w - 1, frmMain.ScaleHeight - 1)
   
    ' // Create bitmap based on imgSpectrumData array
    If GdipCreateBitmapFromScan0(w, frmMain.ScaleHeight, w * 4, PixelFormat32bppARGB, imgSpectrumData(0, 0), imgSpectrum) Then
        MsgBox "Error create GDI+ bitmap"
        Unload frmMain: Exit Function
    End If
   
    ' // Extract GDI+ graphics object belonging to its bitmap
    If GdipGetImageGraphicsContext(imgSpectrum, grSpectrum) Then
        MsgBox "Error create buffer graphics"
        Unload frmMain: Exit Function
    End If
   
    ' // Restore smoothing mode
    Smoothing = s
    ' // Success
    CreateSpectrumBitmap = True
   
End Function

' // Animate background
Private Sub Release()
    Dim x      As Long:    Dim y      As Long
    Dim c      As Long:    Dim d      As Long
    Dim w      As Long:    Dim h      As Long
    Dim r      As Long:    Dim g      As Long
    Dim b      As Long:    Dim a      As Long
    Dim dx      As Long:    Dim dy      As Long
    Dim cx      As Single:  Dim cy      As Single
    Dim Buf()  As Long:    Dim o      As Single
    Dim s      As Single
   
    ' // Get width and height of bitmap - 1
    h = UBound(imgSpectrumData, 2): w = UBound(imgSpectrumData, 1)
   
    ' // Select effect
    Select Case mEffect
    Case 0
        ' // 0. No effect (just change transparency of background)
        ' // Determine value of changing of alpha channel
        d = Fade * 255
       
        ' // Go thru bits
        For y = 0 To h: For x = 0 To w
       
            ' // Extract alpha channel of pixel
            a = (((imgSpectrumData(x, y) And &HFF000000) \ &H1000000) And &HFF&)
            ' // Decrease
            a = a - d
            ' // Limit it
            If a < 0 Then a = 0
            ' // Get color components without alpha
            c = imgSpectrumData(x, y) And &HFFFFFF
            ' // Update it changing alpha value
            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
        ' // 1. Blur
        ' // Determine value of changing of alpha channel
        d = Fade * 10
       
        ' // Go thru bits
        For y = 0 To h: For x = 0 To w
           
            ' // Smooth it (1,1, w-1,h-1)
            If x > 0 And y > 0 And x < w - 1 And y < h - 1 Then
               
                ' // Clean accumulation values of color components
                r = 0: g = 0: b = 0: a = 0
               
                ' // Process neighbor pixels
                For dy = -1 To 1: For dx = -1 To 1
               
                    ' // Extract each component and add it to accumulator
                    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
               
                ' // Average accumulation values and change alpha considering fade
                r = r \ 9: g = g \ 9: b = b \ 9: a = a \ 9 - d
                ' // Limit alpha
                If a < 0 Then a = 0
                ' // Get Long color without alpha
                c = b Or (g * &H100&) Or (r * &H10000)
               
                ' // Update alpha
                If a > 127 Then
                    imgSpectrumData(x, y) = c Or ((a - 256) * &H1000000)
                Else: imgSpectrumData(x, y) = c Or (a * &H1000000)
                End If
               
                ' // Else set to zero component (absolutely transparent)
            Else: imgSpectrumData(x, y) = 0
            End If
        Next: Next
    Case 2
        ' // 2. Fire effect
        ' // Determine value of changing of alpha channel
        d = Fade * 64
       
        ' // Copy bits of bitmap to buffer
        Buf = imgSpectrumData
       
        ' // Calculate offsets and width depending on appearance
        If mSymmetrical Then o = 0: s = w * 2 Else o = 0.5: s = w
       
        ' // Go thru bits
        For y = 0 To h: For x = 0 To w
           
            ' // Normalize coordiante [0,1];[-0.5;0.5]
            cx = x / s - o: cy = y / h - 0.5
            ' // Get distance on center
            r = Sqr(cx * cx + cy * cy)
            ' // Calculate result pixel coordinate
            dx = (cx + o + 0.01 * cx * ((r - 1) / 0.5)) * s
            dy = (cy + 0.5 + 0.01 * cy * ((r - 1) / 0.5)) * h
            ' // Extract alpha and decrease it
            a = (((Buf(dx, dy) And &HFF000000) \ &H1000000) And &HFF&) - d
            ' // Limit alpha
            If a < 0 Then a = 0
            ' // Get color components without alpha
            c = Buf(dx, dy) And &HFFFFFF
           
            ' // Update it changing alpha value
            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

' // This procedure converts integer values of amplitudes to complex form
' // mixing left and right channels as well as applies window
Private Sub ToComplex( _
            ByRef Dat() As Integer, _
            ByRef Out() As Complex)
    Dim i  As Long:    Dim p  As Long
   
    ' // Go thru buffer
    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

' // Update sizes of buffers
Private Sub UpdateBuffers()

    ReDim MapData(mFFTSize \ 2 - 1)
    ReDim Spectrum(mFFTSize - 1)
   
    ' // Initialize Hamming window
    InitHamming
   
End Sub

' // This procedure create map that contains values of angles for each frequency
Private Sub CreateMap()
    Dim o  As Long:    Dim i1  As Long
    Dim i2  As Long:    Dim fr  As Single
    Dim d  As Single:  Dim sa  As Single
    Dim ea  As Single:  Dim s  As Single
    Dim ma  As Single:  Dim sn  As Single
    Dim cs  As Single:  Dim hs  As Single
    Dim a  As Single
   
    ' // Get radius
    hs = frmMain.ScaleWidth / 2
    ' // Calculate size of octave in pixels
    OctAreaSize = hs * (2 * mOctaveCount - 1) / (mOctaveCount * mOctaveCount * 2)
    ' // Determine angle of view
    ma = IIf(Symmetrical, 180, 360)
    ' // Set initial values for radius and spectrum index
    s = OctAreaSize: i1 = 1
   
    ' // Go thru octaves
    For o = 0 To mOctaveCount - 1
   
        ' // Get index of next octave
        i2 = i1 * 2
        ' // Get angle increment
        d = ma / (i2 - i1)
        ' // Set initial angle
        a = -90 + d / 2
       
        ' // If size of arc less than 2 pixels and has been enabled ring appearance then draw line
        If 6.28318530717959 * s * (d / 360) < 2 And View = 0 Then
       
            Do While i1 < i2
           
                ' // Get coordinates of lines
                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
           
                ' // Get angles
                MapData(i1).IsLine = False
                MapData(i1).fa = a - d / 2: MapData(i1).ta = d
                a = a + d: i1 = i1 + 1
               
            Loop
           
        End If
       
        ' // Offset to octave size
        s = s + OctAreaSize
       
    Next
End Sub

---

modMain.bas module (continue):

Code:

---

' // Create default palette for ring appearance
Private Sub CreateDefaultRingPalette()
    Dim i  As Long:    Dim a  As Long
   
    ' // If external palette was loaded then exit
    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

' // Create default palette for sector (pie) appearance
Private Sub CreateDefaultSectorPalette()
    Dim i  As Long:    Dim a  As Long
   
    ' // If external palette was loaded then exit
    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

' // Fast Fourier transform
Private Sub FFT( _
            ByRef Dat() As Complex)
    Dim i  As Long:    Dim j  As Long
    Dim n  As Long:    Dim K  As Long
    Dim io  As Long:    Dim ie  As Long
    Dim in_ As Long:    Dim nn  As Long
    Dim u  As Complex: Dim tp  As Complex
    Dim tq  As Complex: Dim w  As Complex
    Dim sr  As Single:  Dim 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 initialization of rotation coefficient
Private Sub InitFFT()
    Dim n      As Long:    Dim vRcoef  As Variant
    Dim 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

' // Hamming window initialization
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

---

modGraphics.bas module:

Code:

---

' // modGraphics.bas - GDI+ initialization and working with it
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

Public Type GdiplusStartupInput
    GdiplusVersion              As Long
    DebugEventCallback          As Long
    SuppressBackgroundThread    As Long
    SuppressExternalCodecs      As Long
End Type

Public Declare Function GdiplusStartup Lib "gdiplus" ( _
                        ByRef token As Long, _
                        ByRef inputbuf As GdiplusStartupInput, _
                        Optional ByVal outputbuf As Long = 0) As Long
Public Declare Function GdipCreateFromHDC Lib "gdiplus" ( _
                        ByVal hdc As Long, _
                        ByRef Graphics As Long) As Long
Public Declare Function GdipCreatePen1 Lib "gdiplus" ( _
                        ByVal color As Long, _
                        ByVal Width As Single, _
                        ByVal unit As Long, _
                        ByRef 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, _
                        ByRef 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, _
                        ByRef 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, _
                        ByRef scan0 As Any, _
                        ByRef 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, _
                        ByRef 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, _
                        ByRef image As Long) As Long
Public Declare Function GdipGetImagePixelFormat Lib "gdiplus" ( _
                        ByVal image As Long, _
                        ByRef PixelFormat As Long) As Long
Public Declare Function GdipGetImageWidth Lib "gdiplus" ( _
                        ByVal image As Long, _
                        ByRef Width As Long) As Long
Public Declare Function GdipBitmapGetPixel Lib "gdiplus" ( _
                        ByVal Bitmap As Long, _
                        ByVal x As Long, _
                        ByVal y As Long, _
                        ByRef color As Long) As Long

Public Const UnitPixel              As Long = 2
Public Const SmoothingModeAntiAlias  As Long = 4
Public Const SmoothingModeHighSpeed  As Long = 1
Public Const PixelFormat32bppARGB    As Long = &H26200A
Public Const PixelFormat32bppPARGB  As Long = &HE200B
Public Const FillModeAlternate      As Long = 0
Public Const CombineModeExclude      As Long = 4
Public Const PenAlignmentInset      As Long = 1
           
Dim token  As Long
Dim si      As GdiplusStartupInput

' // GDI+ initialization
Public Function InitGDIPlus() As Boolean

    si.GdiplusVersion = 1
    InitGDIPlus = GdiplusStartup(token, si) = 0
   
End Function

' // Uninitialization of GDI+
Public Sub UninitGDIPlus()
    GdiplusShutdown token
End Sub

' // Calculate ARGB color from RGB color and Alpha
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

---

modMenu.bas module:

Code:

---

' // modMenu.bas - work with menu
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

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, _
                        ByRef lpTPMParams As Any) As Long
Public Declare Function GetCursorPos Lib "user32" ( _
                        ByRef 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        As Long = &H10
Public Const MF_CHECKED      As Long = &H8&
Public Const MF_UNCHECKED    As Long = &H0&
Public Const MF_APPEND      As Long = &H100&
Public Const TPM_LEFTALIGN  As Long = &H0&
Public Const MF_DISABLED    As Long = &H2&
Public Const MF_GRAYED      As Long = &H1&
Public Const MF_SEPARATOR    As Long = &H800&
Public Const MF_STRING      As Long = &H0&
Public Const MF_POPUP        As Long = &H10&
Public Const MF_BYPOSITION  As Long = &H400&

' // Menu descriptors
Public mnuMain        As Long
Public mnuOct          As Long
Public mnuTransparency As Long
Public mnuFade        As Long
Public mnuGain        As Long
Public mnuEffects      As Long
Public mnuView        As Long

' // This procedure creates popup menu
Public Sub CreateMenu()
    Dim i  As Long:    Dim 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

' // This procedure destroys all menu
Public Sub DeleteMenu()

    DestroyMenu mnuMain
    DestroyMenu mnuOct
    DestroyMenu mnuTransparency
    DestroyMenu mnuFade
    DestroyMenu mnuGain
    DestroyMenu mnuEffects
    DestroyMenu mnuView
   
End Sub

' // This function is called when right click occurs
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

' // This function is called when a menu item has been selected
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 ' // Transparency
        modMain.Transparent = Not modMain.Transparent
    Case 3 ' // About
        frmAbout.Show vbModal
    Case 4 ' // Load palette
        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

---

modOpenFileName.bas module:

Code:

---

' // modOpenFileName.bas - work with open-file dialog box
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

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" ( _
                        ByRef pOpenfilename As OPENFILENAME) As Long

' // Show open file dialog and get selected file name
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

---

modWndProc.bas module:

Code:

---

' // modWndProc.bas - window subclassing module
' // © Krivous Anatoly Anatolevich (The trick), 2014

Option Explicit

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, _
                        ByRef pptDst As Any, _
                        ByRef psize As Any, _
                        ByVal hdcSrc As Long, _
                        ByRef pptSrc As Any, _
                        ByVal crKey As Long, _
                        ByRef 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, _
                        ByRef 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" ( _
                  ByRef Destination As Any, _
                  ByRef Source As Any, _
                  ByVal Length As Long)

Public Const HWND_TOPMOST        As Long = -1
Public Const WS_EX_LAYERED      As Long = &H80000
Public Const GWL_EXSTYLE        As Long = -20
Public Const GWL_WNDPROC        As Long = (-4)
Public Const ULW_ALPHA          As Long = &H2
Public Const AB_32Bpp255        As Long = 33488896
Public Const HTCAPTION          As Long = 2
Public Const WM_NCRBUTTONUP      As Long = &HA5
Public Const WM_NCLBUTTONDBLCLK  As Long = &HA3
Public Const WM_COMMAND          As Long = &H111
Public Const WM_NCHITTEST        As Long = &H84
Public Const WM_SIZE            As Long = &H5
Public Const SWP_NOSIZE          As Long = &H1
Public Const SWP_NOMOVE          As Long = &H2&

Dim PrevWndProc As Long

' // Start subclassing
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

' // Stop subclassing
Public Sub Unhook()
    SetWindowLong frmMain.hwnd, GWL_WNDPROC, PrevWndProc
End Sub

' // Main window procedure
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
   
        ' // If buffer has been filled
        Dim Hdr As WAVEHDR
        ' // Copy header
        CopyMemory Hdr, ByVal lParam, Len(Hdr)
        ' // Call call-back function
        OnCapture Hdr
       
    Case WM_NCHITTEST
   
        ' // Moving form by clicking anywhere on it
        WndProc = HTCAPTION
       
    Case WM_NCRBUTTONUP
   
        ' // Up mouse button
        WndProc = OnRButtonUp(IIf(lParam And &H8000&, lParam Or &HFFFF0000, lParam And &HFFFF&), lParam \ &H10000)
       
    Case WM_COMMAND

        If (wParam And &HFFFF0000) = 0 Then
            ' // If click on menu
            WndProc = OnMenuClick(wParam)
        Else: WndProc = CallWindowProc(PrevWndProc, hwnd, msg, wParam, lParam)
        End If
    Case WM_SIZE
   
        ' // When resize window
        OnResize
       
    Case Else: WndProc = CallWindowProc(PrevWndProc, hwnd, msg, wParam, lParam)
    End Select
   
End Function

---

From frmAbout.frm:

Code:

---

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

---

In the archives of a small set of palettes.

Good luck!

New version.
I've translated all the sources to english and i've added the explanation of work of the program at the first post.
You can download it in the #7 post.

THANKS .very good ider for translate to en. but why not "Circular spectrum visualizer" code????

Quote:

---

Originally Posted by xxdoc

THANKS .very good ider for translate to en. but why not "Circular spectrum visualizer" code????

---

Oh...:blush: Sorry, i've fixed it :)

why not run for me? my sound card or any audio is ok but program show this message:

Error capture.
A device ID has been used that is out of range for your system.



how can fix it?

What the default recording device do you use?
https://image.ibb.co/fKJdbT/b1.png

its like this

Can you please show me Properties->Advanced
https://image.ibb.co/idEvO8/b2.png

Quote:

---

Originally Posted by Black_Storm

advenced tab:

---

It's very strange because it uses the default recording device. I'll check how to produce that error and the possibles solutions.

I removed some off topic posts from this thread that were trying to hijack the thread to ask a totally unrelated question for which another thread already exists. Please do not do that.

Hello, I was sent here by message by someone when I was asking this; How do I make a frequency spectrum that plays 3-channel audio files, 1 for each color pixel?

I want horizontal to be time, vertical to be frequency/pitch.

If anyone knows a way, or for more information, please help me and read this.

https://www.vbforums.com/showthread....al-Studio-2019

Can anyone help?