dcsimg
Results 1 to 16 of 16

Thread: [VB6] - Circular spectrum visualizer.

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    [VB6] - Circular spectrum visualizer.


    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:
    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

  2. #2

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    Re: [VB6] - Circular spectrum visualizer.

    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

  3. #3

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    Re: [VB6] - Circular spectrum visualizer.

    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

  4. #4

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    Re: [VB6] - Circular spectrum visualizer.

    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

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    Re: [VB6] - Circular spectrum visualizer.

    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

  6. #6

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    Re: [VB6] - Circular spectrum visualizer.

    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

  7. #7

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,367

    Re: [VB6] - Circular spectrum visualizer.

    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!
    Attached Files Attached Files

  8. #8

  9. #9
    Member
    Join Date
    May 2013
    Posts
    47

    Re: [VB6] - Circular spectrum visualizer.

    THANKS .very good ider for translate to en. but why not "Circular spectrum visualizer" code????
    Last edited by xxdoc; Apr 12th, 2016 at 10:40 PM.

  10. #10

  11. #11
    Addicted Member Black_Storm's Avatar
    Join Date
    Sep 2007
    Posts
    221

    Re: [VB6] - Circular spectrum visualizer.

    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?

  12. #12

  13. #13
    Addicted Member Black_Storm's Avatar
    Join Date
    Sep 2007
    Posts
    221

    Re: [VB6] - Circular spectrum visualizer.

    its like this
    Attached Images Attached Images  

  14. #14

  15. #15

  16. #16
    Super Moderator Shaggy Hiker's Avatar
    Join Date
    Aug 2002
    Location
    Idaho
    Posts
    34,313

    Re: [VB6] - Circular spectrum visualizer.

    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.
    Last edited by Shaggy Hiker; May 27th, 2018 at 06:28 PM.
    My usual boring signature: Nothing

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width