vbAccelerator - Contents of code file: cSlowGrow.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cSlowGrow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' 12:45 - Restate my assumptions.
' 10:38 - Hit Return
Private Const PI As Double = 3.14159265358979

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 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 SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, ByVal crColor As Long) As Long

Private Enum SlowGrowState
   MakeNewPoint
   MovePoint
End Enum


Private m_bAnimate As Boolean
Private m_lState As SlowGrowState
Private m_lPoints As Long
Private m_lWidth As Long
Private m_lHeight As Long
Private m_lRadius As Long
Private m_lMaxDist As Long
Private m_lX() As Long
Private m_lY() As Long
Private m_lTrailSize As Long
Private m_lMaxPoints As Long
Private m_lColor As Long
Private m_cDib As cDIBSection256

Public Event PointAdded()

Public Property Get Animate() As Boolean
   Animate = m_bAnimate
End Property
Public Property Let Animate(ByVal bState As Boolean)
   m_bAnimate = bState
End Property

Public Property Get Color() As OLE_COLOR
   Color = m_lColor
End Property
Public Property Let Color(ByVal lColor As OLE_COLOR)
   m_lColor = lColor
   setColors
End Property
Public Property Get Width() As Long
   Width = m_lWidth
End Property
Public Property Let Width(ByVal lWidth As Long)
   m_lWidth = lWidth
   Reset
End Property
Public Property Get Height() As Long
   Height = m_lHeight
End Property
Public Property Let Height(ByVal lHeight As Long)
   m_lHeight = lHeight
   Reset
End Property
Public Property Get TrailSize() As Long
   TrailSize = m_lTrailSize
End Property
Public Property Let TrailSize(ByVal lTrailSize As Long)
   m_lTrailSize = lTrailSize
   ReDim m_lX(0 To m_lTrailSize) As Long
   ReDim m_lY(0 To m_lTrailSize) As Long
End Property
Public Property Get Points() As Long
   Points = m_lPoints
End Property
Public Property Get MaxPoints() As Long
   MaxPoints = m_lMaxPoints
End Property
Public Property Let MaxPoints(ByVal lMaxPoints As Long)
   m_lMaxPoints = lMaxPoints
End Property
Public Sub Step()
Dim newAngle As Double
Dim actionRand As Double
Dim x As Long
Dim y As Long
Dim xErase As Long
Dim yErase As Long
Dim distX As Long
Dim distY As Long
Dim i As Long
Dim j As Long
Dim bDib() As Byte
Dim tSA As SAFEARRAY2D
Dim bContact As Boolean

   If (m_lState = MakeNewPoint) Then
      newAngle = 2 * PI * Rnd()
      x = m_lRadius * (1# + Cos(newAngle))
      y = m_lRadius * (1# + Sin(newAngle))
      m_lX(0) = x
      m_lY(0) = y
      m_lState = MovePoint
   End If
      
   actionRand = Rnd()
   x = m_lX(0)
   y = m_lY(0)
   If (actionRand <= 0.25) Then
      x = m_lX(0) + 1
   ElseIf (actionRand > 0.25 And actionRand <= 0.5) Then
      x = m_lX(0) - 1
   ElseIf (actionRand > 0.5 And actionRand <= 0.75) Then
      y = m_lY(0) + 1
   Else
      y = m_lY(0) - 1
   End If

   ' Check if we've escaped from the circle:
   distX = x - m_lRadius
   distY = y - m_lRadius
   If (distX * distX + distY * distY > m_lMaxDist) Then
      newAngle = 2 * PI * Rnd()
      x = m_lRadius * (1# + Cos(newAngle))
      y = m_lRadius * (1# + Sin(newAngle))
   End If
   
   ' Apply the motion:
   xErase = m_lX(m_lTrailSize)
   yErase = m_lY(m_lTrailSize)
   For i = m_lTrailSize - 1 To 0 Step -1
      m_lX(i + 1) = m_lX(i)
      m_lY(i + 1) = m_lY(i)
   Next i
   m_lX(0) = x
   m_lY(0) = y
   
   With tSA
       .cbElements = 1
       .cDims = 2
       .Bounds(0).lLbound = 0
       .Bounds(0).cElements = m_cDib.Height
       .Bounds(1).lLbound = 0
       .Bounds(1).cElements = m_cDib.BytesPerScanLine()
       .pvData = m_cDib.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
   
   ' Check if we've joined the crowd
   If m_lState = MovePoint Then
   
      bContact = False
      For i = -1 To 1
         For j = -1 To 1
            If Not (x + i = m_lX(1) And y + j = m_lY(1)) Then
               If (bDib(x + 1 + i, y + 1 + j) = m_lTrailSize + 1) Then
                  bContact = True
                  Exit For
               End If
            End If
         Next j
         If (bContact) Then
            Exit For
         End If
      Next i
      
      If (bContact) Then
         ' set bDib(x,y) and then create a new point
         m_lState = MakeNewPoint
      End If
   
   End If
   
   ' Draw the points:
   If m_bAnimate Then
      bDib(xErase + 1, yErase + 1) = 0
      For i = m_lTrailSize To 0 Step -1
         bDib(m_lX(i) + 1, m_lY(i) + 1) = (m_lTrailSize + 1) - i
      Next i
   Else
      If (bContact) Then
         bDib(m_lX(0) + 1, m_lY(0) + 1) = (m_lTrailSize + 1)
      End If
   End If
   
   ' Clear the temporary array descriptor
   CopyMemory ByVal VarPtrArray(bDib), 0&, 4
   
   If bContact Then
      m_lPoints = m_lPoints + 1
      RaiseEvent PointAdded
   End If
   
End Sub
Public Sub Paint( _
      ByVal lHDC As Long, _
      Optional ByVal lLeft As Long = 0, _
      Optional ByVal lTop As Long = 0 _
   )
   m_cDib.PaintPicture lHDC, lLeft, lTop, m_lWidth, m_lHeight
End Sub
Public Sub Reset()
Dim bDib() As Byte
Dim tSA As SAFEARRAY2D
Dim lPoints() As Long
Dim x As Long
Dim y As Long
   
   If Not (m_lWidth = m_cDib.Width - 3) Or Not (m_lHeight = m_cDib.Height - 3)
    Then
      m_cDib.Create m_lWidth + 3, m_lHeight + 3
   End If

   m_lRadius = Min(m_lWidth \ 2, m_lHeight \ 2)
   m_lMaxDist = m_lRadius * m_lRadius + 1

   With tSA
       .cbElements = 1
       .cDims = 2
       .Bounds(0).lLbound = 0
       .Bounds(0).cElements = m_cDib.Height
       .Bounds(1).lLbound = 0
       .Bounds(1).cElements = m_cDib.BytesPerScanLine()
       .pvData = m_cDib.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4

   For x = 0 To m_cDib.Width - 1
      For y = 0 To m_cDib.Height - 1
         bDib(x, y) = 0
      Next y
   Next x
   bDib(m_lRadius + 1, m_lRadius + 1) = m_lTrailSize + 1
   
   ' Clear the temporary array descriptor
   CopyMemory ByVal VarPtrArray(bDib), 0&, 4
   
   m_lPoints = 0
   ReDim m_lX(0 To m_lTrailSize) As Long
   ReDim m_lY(0 To m_lTrailSize) As Long
   setColors
   
   m_lState = MakeNewPoint
   
   '
End Sub

Private Sub setColors()
Dim r As Long
Dim g As Long
Dim b As Long
Dim i As Long
Dim lColors() As Long
   ReDim lColors(0 To m_lTrailSize + 1) As Long
   r = m_lColor And &HFF&
   g = (m_lColor And &HFF00&) \ &H100&
   b = (m_lColor And &HFF0000) \ &H10000
   For i = 1 To m_lTrailSize + 1
      lColors(i) = RGB( _
         (i * r) \ (m_lTrailSize + 1), _
         (i * g) \ (m_lTrailSize + 1), _
         (i * b) \ (m_lTrailSize + 1) _
         )
   Next i
   m_cDib.SetPalette lColors
End Sub

Private Function Min(ParamArray v()) As Variant
Dim i As Long
Dim vRet As Variant
   vRet = v(1)
   For i = LBound(v) + 1 To UBound(v)
      If (v(i) < vRet) Then
         vRet = v(i)
      End If
   Next i
   Min = vRet
End Function

Private Sub Class_Initialize()
   
   m_bAnimate = True
   m_lMaxPoints = 2000
   m_lTrailSize = 254
   m_lWidth = 256
   m_lHeight = 256
   m_lColor = RGB(96, 128, 255)
   Set m_cDib = New cDIBSection256
   Reset
   
End Sub