VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cS2DScreenEffects"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'<:-) :WARNING: Option Explicit makes coding much safer but will cause difficulties until you declare all variables.
'<:-) (Code Fixer identifies most of them as Missing Dims)
'<:-) Run code using [Ctrl]+[F5] to find any others yourself.
'<:-) To auto-insert 'Option Explicit' in all new code: Tools|Options...|Editor tab, check 'Require Variable Declaration'.
Private CFm_MyDC                 As Long
'<:-) :WARNING: Public Variables are poor Class coding, This variable has been converted to a private and a Property added to use it
Private CFm_mBitmap              As Long
'<:-) :WARNING: Public Variables are poor Class coding, This variable has been converted to a private and a Property added to use it
'<:-) Multiple Declarations on one line expanded to one per line
Private Type Clip
    x                         As Single
    y                         As Single
    offsetx                   As Single
    offsety                   As Single
End Type
Private Clips()             As Clip
''Private Sine1()             As Single
'<:-) :WARNING: Unused Variable Sine1
'<:-) May be a prototype Variable you have not yet implimented or left over from a deleted Control.
''Private Sine2()             As Single
'<:-) :WARNING: Unused Variable Sine2
'<:-) May be a prototype Variable you have not yet implimented or left over from a deleted Control.
Private i                   As Integer
'<:-) :WARNING: Single letter Variables make code difficult to read, use a meaningful name.
'<:-) :SUGGESTION: Change the variable name to (intI).
'<:-) If you are only using it as a For structures counter use a Dim instead
'<:-) (may cause local Dims to be marked as duplicates)
Private ii                  As Integer
Private Const TileSize      As Integer = 16

Public Property Get MyDC() As Long

  '<:-) Property created to replace Public Variable in Class

    MyDC = CFm_MyDC

End Property

Public Property Let MyDC(ByVal PropVal As Long)

  '<:-) :WARNING: 'ByVal ' inserted for Parameter  'PropVal As Long'
  '<:-) Property created to replace Public Variable in Class

    CFm_MyDC = PropVal

End Property

Public Property Get mBitmap() As Long

  '<:-) Property created to replace Public Variable in Class

    mBitmap = CFm_mBitmap

End Property

Public Property Let mBitmap(ByVal PropVal As Long)

  '<:-) :WARNING: 'ByVal ' inserted for Parameter  'PropVal As Long'
  '<:-) Property created to replace Public Variable in Class

    CFm_mBitmap = PropVal

End Property

Private Sub Class_Initialize()

  Dim Asm '<:-) Missing Dim Auto-inserted (Unable to Auto-Type)'<:-) : UnTyped Variable. Will behave as Variant

    '<:-) May be Control name using default property or a control(probably Form) Property being used with default assignment (not a good idea; be explicit)
    Asm = frmMain
    CFm_MyDC = CreateCompatibleDC(GetDC(0))
    CFm_mBitmap = CreateCompatibleBitmap(GetDC(0), ScreenWidth, ScreenHeight)
    SelectObject CFm_MyDC, CFm_mBitmap

End Sub

Private Function RndRange(ByVal sngMin As Single, _
                          ByVal sngMax As Single) As Single

  '<:-) :WARNING: Poorly named Parameters 'Min', 'Max'
  '<:-) :UPDATED: 'sngMin', 'sngMax'

    RndRange = (Rnd * (sngMax - sngMin + 1)) + sngMin

End Function

''
''Public Sub Walk()
''
'''<:-) :WARNING: Unused Sub Walk
'''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
''Dim Count As Double
''BitBlt CFm_MyDC, 0, 0, ScreenWidth, ScreenHeight, engine.DestinationHdC, 0, 0, vbSrcCopy
''ReDim Clips(ScreenWidth / TileSize, ScreenHeight / TileSize)
''Do
''Count = Count + 1
''For i = 0 To ScreenWidth / TileSize
''For ii = 0 To ScreenHeight / TileSize
''With Clips(i, ii)
''.X = i * TileSize
''.Y = ii * TileSize
''.offsetx = .offsetx + RndRange(-4, 3)
''.offsety = .offsety + RndRange(-4, 3)
''BitBlt engine.DestinationHdC, .X + Clips(i, ii).offsetx, .Y + Clips(i, ii).offsety, TileSize, TileSize, CFm_MyDC, i * TileSize, ii * TileSize, SRCCOPY
''End With 'Clips(i, ii)
''Next '  II
''Next '  I
''Loop Until Count > 500
''End Function
''':)Code Fixer V2.0.0 (22.04.2004 22:05:13) 14 + 215 = 229 Lines Thanks Ulli for inspiration and lots of code.
'''~~~'
'''~~~'Public Sub Filter()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub Filter
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :SUGGESTION: Empty Routine.
'''~~~''<:-)  If Empty Routine is required(for Add-In Designers for example)
'''~~~''<:-)  just add a comment starting with '<STUB> Reason:', fill out any reason you like, and Code Fixer will ignore it in future.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~''SaveScreen
'''~~~''Private Enum FoxEffectFlags
'''~~~''    FOX_USE_MASK = &H1
'''~~~''    FOX_ANTI_ALIAS = &H2
'''~~~''    FOX_SRC_INVERT = &H100
'''~~~''    FOX_DST_INVERT = &H200
'''~~~''    FOX_MASK_INVERT = &H400
'''~~~''    FOX_SRC_GREYSCALE = &H1000
'''~~~''    FOX_DST_GREYSCALE = &H2000
'''~~~''    FOX_FLIP_X = &H40000
'''~~~''    FOX_FLIP_Y = &H80000
'''~~~''    FOX_TURN_LEFT = &H10000
'''~~~''    FOX_TURN_RIGHT = FOX_FLIP_X Or FOX_FLIP_Y
'''~~~''    FOX_TURN_90DEG = FOX_TURN_LEFT
'''~~~''    FOX_TURN_180DEG = FOX_TURN_RIGHT
'''~~~''    FOX_TURN_270DEG = FOX_FLIP_X Or FOX_FLIP_Y Or FOX_TURN_LEFT
'''~~~''End Enum
'''~~~''Private Declare Function FoxBumpMap Lib "FoxCBmp3.dl" (ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcDC As Long, ByVal SrcX As Long, ByVal SrcY As Long, Optional ByVal MskColor As Long, Optional ByVal Flags As FoxEffectFlags) As Long
'''~~~''Private Declare Function FoxAlphaBlend Lib "FoxCBmp3.dl" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hScrDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal Alpha As Byte, Optional ByVal MaskColor As Long, Optional ByVal Flags As FoxEffectFlags) As Long
'''~~~''Private Declare Function FoxBlur Lib "FoxCBmp3.dl" (ByVal hDC As Long, ByVal Handle As Long, ByVal hSrcDC As Long, ByVal SrcHandle As Long, Blur As Long, Optional ByVal MaskColor As Long, Optional ByVal Flags As FoxEffectFlags) As Long
'''~~~''Private Declare Function FoxGreyScale Lib "FoxCBmp3.dl" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, Optional ByVal MaskColor As Long, Optional ByVal Flags As FoxEffectFlags) As Long
'''~~~''FoxAlphaBlend MyDC, 0, 0, 320, 240, MyDC, -1, -1, 128, 0, FOX_DST_INVERT + FOX_DST_GREYSCALE + FOX_SRC_GREYSCALE
'''~~~''frmMain.picMain.Cls
'''~~~''FoxGreyScale frmMain.picMain.hDC, 0, 0, 320, 240, MyDC, 0, 0
'''~~~''BitBlt frmMain.picMain.HDC, 0, 0, ScreenWidth, ScreenHeight, MyDC, 0, 0, vbSrcCopy
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub ManyRectsIn()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub ManyRectsIn
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim a     As Long     '<:-) Missing Dim Auto-inserted (Auto-Type may not be correct)
'''~~~''<:-) May be Control name using default property or a control(probably Form) Property being used with default assignment (not a good idea; be explicit)
'''~~~'Dim Count As Double
'''~~~'For a = 0 To 240 Step 40
'''~~~'For i = 0 To 320 Step 40
'''~~~'Do
'''~~~'Count = Count + 0.001
'''~~~'Rectangle engine.DestinationHdC, i + Count, a + Count, i + 40 - Count, a + 40 - Count
'''~~~'Loop Until Count > 20
'''~~~'Count = 0
'''~~~'Next i
'''~~~'Next a
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub ManyRectsOut()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub ManyRectsOut
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim a     As Long     '<:-) Missing Dim Auto-inserted (Auto-Type may not be correct)
'''~~~''<:-) May be Control name using default property or a control(probably Form) Property being used with default assignment (not a good idea; be explicit)
'''~~~'Dim Count As Double
'''~~~'For a = 20 To 240 Step 40
'''~~~'For i = 20 To 320 Step 40
'''~~~'Do
'''~~~'Count = Count + 0.001
'''~~~'Rectangle engine.DestinationHdC, i + Count, a + Count, i - Count, a - Count
'''~~~'Loop Until Count > 20
'''~~~'Count = 0
'''~~~'Next i
'''~~~'Next a
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub Melt()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub Melt
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim blnLoop '<:-) Missing Dim Auto-inserted (Unable to Auto-Type)
'''~~~''<:-) May be Control name using default property or a control(probably Form) Property being used with default assignment (not a good idea; be explicit)
'''~~~'Dim StartX  As Integer
'''~~~'Dim StartY  As Integer
'''~~~'Dim RandomI As Integer
'''~~~'Dim RandomJ As Integer
'''~~~'Dim Width   As Integer
'''~~~'Dim Height  As Integer
'''~~~'Dim Count   As Integer
'''~~~'Width = ScreenWidth
'''~~~'Height = ScreenHeight
'''~~~'Randomize
'''~~~'blnLoop = vbTrue
'''~~~'Do
'''~~~'Count = Count + 1
'''~~~'StartX = (Width - 128) * Rnd
'''~~~'StartY = (Height - 128) * Rnd
'''~~~'RandomI = 2 * Rnd - 1
'''~~~'RandomJ = 2 * Rnd - 1
'''~~~'BitBlt engine.DestinationHdC, StartX + RandomI, StartY + RandomJ, 128, 128, engine.DestinationHdC, StartX, StartY, vbSrcCopy
'''~~~'If GetInputState() <> 0 Then
'''~~~'DoEvents
'''~~~'End If
'''~~~'Loop Until Count > 20000
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub RectIn()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub RectIn
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim Count As Double
'''~~~'Do
'''~~~'Count = Count + 0.005
'''~~~'Rectangle engine.DestinationHdC, 0 + Count, 0 + Count, ScreenWidth - Count, ScreenHeight - Count
'''~~~'Loop Until Count > ScreenWidth / 2
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub RectOut()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub RectOut
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim Count As Double
'''~~~'SetPixel engine.DestinationHdC, ScreenWidth / 2, ScreenHeight / 2, vbBlack
'''~~~'Do
'''~~~'Count = Count + 0.005
'''~~~'Rectangle engine.DestinationHdC, ScreenWidth / 2 + Count, ScreenHeight / 2 + Count, ScreenWidth / 2 - Count, ScreenHeight / 2 - Count
'''~~~'Loop Until Count > ScreenWidth / 2
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub ResetScreen()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub ResetScreen
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'BitBlt engine.DestinationHdC, 0, 0, ScreenWidth, ScreenHeight, CFm_MyDC, 0, 0, vbSrcCopy
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub SaveScreen()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub SaveScreen
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'BitBlt CFm_MyDC, 0, 0, ScreenWidth, ScreenHeight, engine.DestinationHdC, 0, 0, vbSrcCopy
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub SlideOut(Optional Speed As Double = 0.4)
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub SlideOut
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim a     As Long     '<:-) Missing Dim Auto-inserted (Auto-Type may not be correct)
'''~~~''<:-) May be Control name using default property or a control(probably Form) Property being used with default assignment (not a good idea; be explicit)
'''~~~'Dim Count As Double
'''~~~'BitBlt CFm_MyDC, 0, 0, ScreenWidth, ScreenHeight, engine.DestinationHdC, 0, 0, vbSrcCopy
'''~~~'Do
'''~~~'If GetInputState() <> 0 Then
'''~~~'DoEvents
'''~~~'End If
'''~~~'Count = Count + Speed
'''~~~'With engine
'''~~~'For a = 0 To .ScreenHeight Step 10
'''~~~'BitBlt .DestinationHdC, Count, a, .ScreenWidth, 5, CFm_MyDC, 0, a, vbSrcCopy
'''~~~'Rectangle .DestinationHdC, 0, a, Count, a + 5
'''~~~'BitBlt .DestinationHdC, -Count, a + 5, .ScreenWidth, 5, CFm_MyDC, 0, a + 5, vbSrcCopy
'''~~~'Rectangle .DestinationHdC, .ScreenWidth, a + 5, .ScreenWidth - Count, a + 10
'''~~~'Next a
'''~~~'End With 'engine
'''~~~'Loop Until Count > ScreenWidth
'''~~~'End Function
'''~~~'
'''~~~'
'''~~~'Public Sub UnderWater()
'''~~~'
'''~~~''<:-) :WARNING: Unused Sub UnderWater
'''~~~''<:-) May be a prototype Sub you have not yet implimented or left over from a deleted Control.
'''~~~''<:-) :WARNING: Function changed to Sub as nothing is returned via the Function Name.
'''~~~'Dim Count As Double
'''~~~'BitBlt CFm_MyDC, 0, 0, ScreenWidth, ScreenHeight, engine.DestinationHdC, 0, 0, vbSrcCopy
'''~~~'ReDim Clips(ScreenWidth / TileSize, ScreenHeight / TileSize)
'''~~~'Do
'''~~~'Count = Count + 1
'''~~~'For i = 0 To ScreenWidth / TileSize
'''~~~'For ii = 0 To ScreenHeight / TileSize
'''~~~'With Clips(i, ii)
'''~~~'.X = i * TileSize
'''~~~'.Y = ii * TileSize
'''~~~'.offsetx = .offsetx + 0.5 * Sin(Timer * i)
'''~~~'.offsety = .offsety + 0.5 * Sin(Timer * ii)
'''~~~'BitBlt engine.DestinationHdC, .X + Clips(i, ii).offsetx, .Y + Clips(i, ii).offsety, TileSize, TileSize, CFm_MyDC, i * TileSize, ii * TileSize, SRCCOPY
'''~~~'End With 'Clips(i, ii)
'''~~~'Next ii
'''~~~'Next i
'''~~~'Loop Until Count > 500
'''~~~'End Function
'''~~~'
''
':)Code Fixer V2.0.0 (22.04.2004 22:46:44) 30 + 288 = 318 Lines Thanks Ulli for inspiration and lots of code.

