vbAccelerator - Contents of code file: vbalWaveRender.ctl

VERSION 5.00
Begin VB.UserControl vbalWaveRender 
   AutoRedraw      =   -1  'True
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "vbalWaveRender.ctx":0000
End
Attribute VB_Name = "vbalWaveRender"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As
 Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY1D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 0) As SAFEARRAYBOUND
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr()
 As Any) As Long

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal
 lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long)
 As Long

Public Enum EWaveViewerZoom
   e24to1 = -24
   e16to1 = -16
   e8to1 = -8
   e6to1 = -6
   e4to1 = -4
   e3to1 = -3
   e2to1 = -2
   e1to1 = 1
   e1to2 = 2
   e1to4 = 4
   e1to8 = 8
   e1to16 = 16
   e1to32 = 32
   e1to64 = 64
   e1to128 = 128
   e1to256 = 256
   e1to512 = 512
   e1to1024 = 1024
   e1to2048 = 2048
   e1to4196 = 4196
   e1to8192 = 8192
   e1to16384 = 16384
End Enum

Public Enum EWaveViewerBorderStyle
   eNone = 0
   e3D = 1
End Enum


Private m_cWAVRead As cWavReader
Private WithEvents m_cScroll As cScrollBars
Attribute m_cScroll.VB_VarHelpID = -1
Private m_lSampleStep As Long
Private m_lPixelStep As Long
Private m_lSamplePerPixelStep As Long
Private m_bSetting As Boolean
Private m_hMod As Long

Private m_lZoom As EWaveViewerZoom
Private m_eBorderStyle As EWaveViewerBorderStyle
Private m_oWaveBackcolor As OLE_COLOR
Private m_oNoWaveBackcolor As OLE_COLOR
Private m_oWaveForecolor As OLE_COLOR
Private m_oColorStereoDivider As OLE_COLOR
Private m_oColorMidDivider As OLE_COLOR
Private m_oColorHalfAmplitudeDivider As OLE_COLOR

Public Property Get BorderStyle() As EWaveViewerBorderStyle
   BorderStyle = UserControl.BorderStyle
End Property
Public Property Let BorderStyle(ByVal value As EWaveViewerBorderStyle)
   UserControl.BorderStyle = value
   PropertyChanged "BorderStyle"
End Property
Public Property Get WaveBackColor() As OLE_COLOR
   WaveBackColor = UserControl.BackColor
End Property
Public Property Let WaveBackColor(ByVal value As OLE_COLOR)
   UserControl.BackColor = value
   renderWave
   PropertyChanged "WaveBackColor"
End Property
Public Property Get NoWaveBackColor() As OLE_COLOR
   NoWaveBackColor = m_oNoWaveBackcolor
End Property
Public Property Let NoWaveBackColor(ByVal value As OLE_COLOR)
   m_oNoWaveBackcolor = value
   renderWave
   PropertyChanged "NoWaveBackColor"
End Property
Public Property Get WaveForeColor() As OLE_COLOR
   WaveForeColor = m_oWaveForecolor
End Property
Public Property Let WaveForeColor(ByVal value As OLE_COLOR)
   m_oWaveForecolor = value
   renderWave
   PropertyChanged "WaveForeColor"
End Property
Public Property Get ColorStereoDivider() As OLE_COLOR
   ColorStereoDivider = m_oColorStereoDivider
End Property
Public Property Let ColorStereoDivider(ByVal value As OLE_COLOR)
   m_oColorStereoDivider = value
   renderWave
   PropertyChanged "ColorStereoDivider"
End Property
Public Property Get ColorMidDivider() As OLE_COLOR
   ColorMidDivider = m_oColorMidDivider
End Property
Public Property Let ColorMidDivider(ByVal value As OLE_COLOR)
   m_oColorMidDivider = value
   renderWave
   PropertyChanged "ColorMidDivider"
End Property
Public Property Get ColorHalfAmplitudeDivider() As OLE_COLOR
   ColorHalfAmplitudeDivider = m_oColorHalfAmplitudeDivider
End Property
Public Property Let ColorHalfAmplitudeDivider(ByVal value As OLE_COLOR)
   m_oColorHalfAmplitudeDivider = value
   renderWave
   PropertyChanged "ColorHalfAmplitudeDivider"
End Property

Public Property Get WaveFile() As String
   WaveFile = m_cWAVRead.FileName
End Property
Public Property Let WaveFile(ByVal sFile As String)
   If (Len(sFile) = 0) Then
      Set m_cWAVRead = New cWavReader
   Else
      m_cWAVRead.FileName = sFile
      setScroll
      renderWave
   End If
End Property

Public Property Get Zoom() As EWaveViewerZoom
   Zoom = m_lZoom
End Property
Public Property Let Zoom(ByVal eZoom As EWaveViewerZoom)
   If Not (m_lZoom = eZoom) Then
      m_lZoom = eZoom
      setScroll
      renderWave
   End If
End Property

Private Sub setScroll()
Dim lMax As Long

   m_bSetting = True

   If (m_lZoom <= 1) Then
      m_lSampleStep = 1
      m_lPixelStep = Abs(m_lZoom)
      m_lSamplePerPixelStep = 1
      lMax = m_cWAVRead.AudioLength
   Else
      m_lSamplePerPixelStep = m_lZoom
      m_lSampleStep = m_lSamplePerPixelStep \ 32
      If (m_lSampleStep < 1) Then
         m_lSampleStep = 1
      End If
      m_lPixelStep = 1
      Debug.Print m_lSamplePerPixelStep, (m_cWAVRead.AudioLength \
       m_lSamplePerPixelStep), UserControl.ScaleWidth
      lMax = (m_cWAVRead.AudioLength \ m_lSamplePerPixelStep) -
       UserControl.ScaleWidth
   End If

   If lMax <= 0 Then
      m_cScroll.value(efsHorizontal) = 0
      m_cScroll.Visible(efsHorizontal) = False
   Else
      m_cScroll.SmallChange(efsHorizontal) = UserControl.ScaleWidth \ 32
      m_cScroll.LargeChange(efsHorizontal) = UserControl.ScaleWidth
      m_cScroll.Max(efsHorizontal) = lMax
      m_cScroll.Visible(efsHorizontal) = True
   End If
   
   m_bSetting = False
   
End Sub


Private Sub renderWave()
Dim lX As Long
Dim lEnd As Long
Dim bComplete As Boolean
Dim tSA As SAFEARRAY2D
Dim iWav() As Integer
Dim iSample As Long
Dim iLeft As Integer
Dim iRight As Integer
Dim lY As Long
Dim lMidY As Long
Dim lAbsSizeY As Long
Dim lLastX As Long
Dim lLastLeftY As Long
Dim lLastRightY As Long
Dim tJunk As POINTAPI
Dim lhDC As Long
Dim bRectangles As Boolean
Dim bInHere As Boolean
Dim lMax As Long
Dim lWavEnd As Long

   UserControl.Cls
   lhDC = UserControl.hdc
   
   bRectangles = (m_lPixelStep >= 8)

   lX = 0
   lEnd = UserControl.ScaleWidth + m_lPixelStep
   lMidY = UserControl.ScaleHeight \ 2
   lAbsSizeY = lMidY \ 2
      
   If Not (m_cScroll.Visible(efsHorizontal)) Then
      lWavEnd = m_cWAVRead.AudioLength \ m_lSamplePerPixelStep
      UserControl.Line (lWavEnd, 0)-(UserControl.ScaleWidth,
       UserControl.ScaleHeight), m_oNoWaveBackcolor, BF
   End If
                        
   UserControl.ForeColor = m_oColorStereoDivider
   MoveToEx lhDC, 0, lMidY, tJunk
   LineTo lhDC, lEnd, lMidY
      
   UserControl.ForeColor = m_oColorHalfAmplitudeDivider
   MoveToEx lhDC, 0, lAbsSizeY, tJunk
   LineTo lhDC, lEnd, lAbsSizeY
   MoveToEx lhDC, 0, lMidY + lAbsSizeY, tJunk
   LineTo lhDC, lEnd, lMidY + lAbsSizeY
   UserControl.ForeColor = m_oColorMidDivider
   MoveToEx lhDC, 0, lAbsSizeY \ 2, tJunk
   LineTo lhDC, lEnd, lAbsSizeY \ 2
   MoveToEx lhDC, 0, (lAbsSizeY * 3) \ 2, tJunk
   LineTo lhDC, lEnd, (lAbsSizeY * 3) \ 2
   MoveToEx lhDC, 0, lMidY + lAbsSizeY \ 2, tJunk
   LineTo lhDC, lEnd, lMidY + lAbsSizeY \ 2
   MoveToEx lhDC, 0, lMidY + (3 * lAbsSizeY) \ 2, tJunk
   LineTo lhDC, lEnd, lMidY + (3 * lAbsSizeY) \ 2
      
   UserControl.ForeColor = m_oWaveForecolor
   
   If (m_bSetting) Or (m_cWAVRead.AudioLength = 0) Then
      Exit Sub
   End If

   With tSA
      .cbElements = 2
      .cDims = 2
      .Bounds(0).lLbound = 0
      .Bounds(0).cElements = m_cWAVRead.ReadBufferSize
      .Bounds(1).lLbound = 0
      .Bounds(1).cElements = 2
   End With
   
   If (m_lZoom <= 1) Then
      m_cWAVRead.SeekAbsolute m_cScroll.value(efsHorizontal)
   Else
      m_cWAVRead.SeekAbsolute m_cScroll.value(efsHorizontal) *
       m_lSamplePerPixelStep
   End If
   
   lLastLeftY = lAbsSizeY
   lLastRightY = lMidY + lAbsSizeY
   
   Do While (lX < lEnd) And Not (bComplete)
      
      bComplete = Not (m_cWAVRead.Read)
      
      tSA.pvData = m_cWAVRead.ReadBufferPtr
      CopyMemory ByVal VarPtrArray(iWav()), VarPtr(tSA), 4
         
      For iSample = 0 To m_cWAVRead.ReadSize - 1 Step m_lSampleStep
               
         ' Left channel
         lY = lAbsSizeY + (iWav(0, iSample) * lAbsSizeY) / &H8000&
         MoveToEx lhDC, lLastX, lLastLeftY, tJunk
         LineTo lhDC, lX, lY
         If (bRectangles) Then
            Rectangle lhDC, lX - 2, lY - 2, lX + 3, lY + 3
         End If
         lLastLeftY = lY
         
         ' Right channel
         lY = lMidY + lAbsSizeY + (iWav(1, iSample) * lAbsSizeY) / &H8000&
         MoveToEx lhDC, lLastX, lLastRightY, tJunk
         LineTo lhDC, lX, lY
         If (bRectangles) Then
            Rectangle lhDC, lX - 2, lY - 2, lX + 3, lY + 3
         End If
         lLastRightY = lY
         lLastX = lX
         
         If (iSample Mod m_lSamplePerPixelStep) = 0 Then
            lX = lX + m_lPixelStep
         End If
         
         If (lX >= lEnd) Then
            Exit For
         End If
         
      Next iSample
      
   Loop
   
   CopyMemory ByVal VarPtrArray(iWav()), 0&, 4
      
   UserControl.Refresh
   
End Sub

Private Sub pInitialise()
   Set m_cScroll = New cScrollBars
   m_cScroll.Create UserControl.hwnd
   Set m_cWAVRead = New cWavReader
End Sub

Private Sub m_cScroll_Change(eBar As EFSScrollBarConstants)
   m_cScroll_Scroll eBar
End Sub

Private Sub m_cScroll_Scroll(eBar As EFSScrollBarConstants)
   '
   If (m_cWAVRead.AudioLength > 0) Then
      renderWave
   End If
   '
End Sub

Private Sub UserControl_Initialize()
   
   m_hMod = LoadLibrary("shell32.dll")
 
   m_lZoom = e1to1
   m_eBorderStyle = e3D
   
   m_oWaveBackcolor = vbWindowBackground
   m_oNoWaveBackcolor = vb3DShadow
   m_oWaveForecolor = &H600000
   m_oColorStereoDivider = &H0
   m_oColorMidDivider = vbButtonFace
   m_oColorHalfAmplitudeDivider = &HFF0000
     
End Sub

Private Sub UserControl_InitProperties()
   '
   pInitialise
   '
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   '
   pInitialise
   
   Zoom = PropBag.ReadProperty("Zoom", e1to1)
   BorderStyle = PropBag.ReadProperty("BorderStyle", e3D)
   m_oWaveBackcolor = PropBag.ReadProperty("WaveBackColor", vbWindowBackground)
   m_oNoWaveBackcolor = PropBag.ReadProperty("NoWaveBackColor", vb3DShadow)
   m_oWaveForecolor = PropBag.ReadProperty("WaveForeColor", &H600000)
   m_oColorStereoDivider = PropBag.ReadProperty("ColorStereoDivider", &H0)
   m_oColorMidDivider = PropBag.ReadProperty("ColorMidDivider", vbButtonFace)
   m_oColorHalfAmplitudeDivider =
    PropBag.ReadProperty("ColorHalfAmplitudeDivider", &HFF0000)
   '
End Sub

Private Sub UserControl_Resize()
   setScroll
   renderWave
End Sub

Private Sub UserControl_Terminate()
   Set m_cScroll = Nothing
   If Not (m_hMod = 0) Then
      FreeLibrary m_hMod
      m_hMod = 0
   End If
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
   '
   PropBag.WriteProperty "Zoom", Zoom, e1to1
   PropBag.WriteProperty "BorderStyle", BorderStyle, e3D
   PropBag.WriteProperty "WaveBackColor", m_oWaveBackcolor, vbWindowBackground
   PropBag.WriteProperty "NoWaveBackColor", m_oNoWaveBackcolor, vb3DShadow
   PropBag.WriteProperty "WaveForeColor", m_oWaveForecolor, &H600000
   PropBag.WriteProperty "ColorStereoDivider", m_oColorStereoDivider, &H0
   PropBag.WriteProperty "ColorMidDivider", m_oColorMidDivider, vbButtonFace
   PropBag.WriteProperty "ColorHalfAmplitudeDivider",
    m_oColorHalfAmplitudeDivider, &HFF0000
   '
End Sub