vbAccelerator - Contents of code file: mDIBSectEffects.bas

Attribute VB_Name = "mDIBSectEffects"
Option Explicit

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

Public Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Public 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
Public Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As
 Any) As Long


Public Sub BlowApart(ByRef cDibPic As cDIBSection, ByRef cDibDisp As
 cDIBSection, ByVal lAmount As Long)
Dim tSAPic As SAFEARRAY2D
Dim tSADisp As SAFEARRAY2D
Dim bPic() As Byte
Dim bDisp() As Byte
Dim x As Long, y As Long
Dim xC As Long, yC As Long
Dim xNew As Long, yNew As Long
Dim xEnd As Long, yEnd As Long
Dim bFinish As Boolean
    
    ' Get the bits in the from DIB section:
    With tSAPic
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cDibPic.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cDibPic.BytesPerScanLine()
        .pvData = cDibPic.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bPic()), VarPtr(tSAPic), 4

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

    ' Copy the display picture to the dib:
    cDibPic.LoadPictureBlt cDibDisp.hdc

    xEnd = (cDibPic.Width - 1) * 3
    yEnd = cDibPic.Height - 1
    xC = xEnd \ 2
    yC = yEnd \ 2
    
    For y = 0 To yEnd
        For x = 0 To xEnd Step 3
            If (bPic(x, y) <> 0) Then
                bFinish = False
               xNew = x + (lAmount \ 2 - (Rnd * lAmount)) * 3
               If (xNew > xEnd) Then
                   bFinish = True
                ElseIf (xNew < 0) Then
                   bFinish = True
                End If
               yNew = y + (lAmount \ 2 - Rnd * lAmount)
               If (yNew < 0) Then
                   bFinish = True
                ElseIf (yNew > yEnd) Then
                   bFinish = True
               End If
               
                If Not (bFinish) Then
                    bDisp(xNew, yNew) = bPic(x, y)
                    bDisp(xNew + 1, yNew) = bPic(x + 1, y)
                    bDisp(xNew + 2, yNew) = bPic(x + 2, y)
                    
                    bPic(xNew, yNew) = bPic(x, y)
                    bPic(xNew + 1, yNew) = bPic(x + 1, y)
                    bPic(xNew + 2, yNew) = bPic(x + 2, y)
                End If
            End If
        Next x
    Next y
    
    ' Clear the temporary array descriptor
    ' (This does not appear to be necessary, but
    ' for safety do it anyway)
    CopyMemory ByVal VarPtrArray(bPic), 0&, 4
    CopyMemory ByVal VarPtrArray(bDisp), 0&, 4


End Sub
Public Sub DoStatic(ByRef cDibPic As cDIBSection, ByRef cDibDisp As
 cDIBSection, ByVal lAmount As Long, ByVal lOffset As Long)
Dim tSAPic As SAFEARRAY2D
Dim tSADisp As SAFEARRAY2D
Dim bPic() As Byte
Dim bDisp() As Byte
Dim x As Long, y As Long
Dim lRnd As Long
Dim xEnd As Long
Dim lR As Long, lG As Long, lB As Long
    
    ' Get the bits in the from DIB section:
    With tSAPic
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cDibPic.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cDibPic.BytesPerScanLine()
        .pvData = cDibPic.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bPic()), VarPtr(tSAPic), 4

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

    xEnd = (cDibPic.Width - 1) * 3
    For y = 0 To cDibPic.Height - 1
        For x = 0 To xEnd Step 3
            'If (bPic(x, y) <> 0) Or (bPic(x + 1, y) <> 0) Or (bPic(x + 2, y)
             <> 0) Then
                lRnd = Rnd * (lAmount - lOffset)
                lB = (lRnd + lOffset) * bPic(x, y) \ 255
                lG = (lRnd + lOffset) * bPic(x + 1, y) \ 255
                lR = (lRnd + lOffset) * bPic(x + 2, y) \ 255
                bDisp(x, y) = lB
                bDisp(x + 1, y) = lG
                bDisp(x + 2, y) = lR
            'End If
        Next x
    Next y

    ' Clear the temporary array descriptor
    ' (This does not appear to be necessary, but
    ' for safety do it anyway)
    CopyMemory ByVal VarPtrArray(bPic), 0&, 4
    CopyMemory ByVal VarPtrArray(bDisp), 0&, 4

End Sub
Public Sub DoFade(ByRef cDibPic As cDIBSection, ByRef cDibDisp As cDIBSection,
 ByVal lAmount As Long)
Dim tSAPic As SAFEARRAY2D
Dim tSADisp As SAFEARRAY2D
Dim bPic() As Byte
Dim bDisp() As Byte
Dim x As Long, y As Long
Dim lRnd As Long
Dim xEnd As Long
Dim lR As Long, lG As Long, lB As Long
    
    ' Get the bits in the from DIB section:
    With tSAPic
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cDibPic.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cDibPic.BytesPerScanLine()
        .pvData = cDibPic.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bPic()), VarPtr(tSAPic), 4

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

    xEnd = (cDibPic.Width - 1) * 3
    For y = 0 To cDibPic.Height - 1
        For x = 0 To xEnd Step 3
            lB = lAmount * bPic(x, y) \ 255
            lG = lAmount * bPic(x + 1, y) \ 255
            lR = lAmount * bPic(x + 2, y) \ 255
            bDisp(x, y) = lB
            bDisp(x + 1, y) = lG
            bDisp(x + 2, y) = lR
        Next x
    Next y

    ' Clear the temporary array descriptor
    ' (This does not appear to be necessary, but
    ' for safety do it anyway)
    CopyMemory ByVal VarPtrArray(bPic), 0&, 4
    CopyMemory ByVal VarPtrArray(bDisp), 0&, 4

End Sub