vbAccelerator - Contents of code file: mPixelDrip256.bas

Attribute VB_Name = "mPixelMelt"
Option Explicit

' implements a pixel drip algorithm for 256 colour
' DIBs.

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 "msvbvm60.dll" Alias "VarPtr" (Ptr()
 As Any) As Long

Private m_xDir(0 To 255) As Long
Private m_yDir(0 To 255) As Long

Public Sub Init()
Dim i As Long
   Randomize Timer
   For i = 0 To 255
      m_xDir(i) = Rnd * 8 - 4
      m_yDir(i) = Rnd * 8 - 4
   Next i
End Sub

Public Sub PixelMelt( _
      cDibIn As cDIBSection256, _
      cDibOut As cDIBSection256 _
   )
Dim tSAIn As SAFEARRAY2D
Dim bDibIn() As Byte
Dim tSAOut As SAFEARRAY2D
Dim bDibOut() As Byte

Dim xEnd As Long, yEnd As Long, xHalf As Long
Dim x As Long, y As Long, y2 As Long, x2 As Long
Dim lC As Long
Static b As Boolean
    
   ' Get the bits in the from DIB section:
   With tSAIn
       .cbElements = 1
       .cDims = 2
       .Bounds(0).lLbound = 0
       .Bounds(0).cElements = cDibIn.Height
       .Bounds(1).lLbound = 0
       .Bounds(1).cElements = cDibIn.BytesPerScanLine()
       .pvData = cDibIn.DIBSectionBitsPtr
   End With
   CopyMemory ByVal VarPtrArray(bDibIn()), VarPtr(tSAIn), 4

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

   xEnd = cDibIn.Width - 1
   yEnd = cDibIn.Height - 1
   For y = yEnd To 0 Step -1
      For x = 0 To xEnd
         y2 = y + m_yDir(bDibIn(x, y))
         x2 = x + m_xDir(bDibIn(x, y))
         If (y2 > 0) And (y2 <= yEnd) And (x2 > 0) And (x2 <= xEnd) Then
            bDibOut(x2, y2) = bDibIn(x, y)
         End If
      Next x
   Next y
   
   b = Not (b)

   ' Clear the temporary array descriptor
   CopyMemory ByVal VarPtrArray(bDibIn), 0&, 4
   CopyMemory ByVal VarPtrArray(bDibOut), 0&, 4
   
End Sub