vbAccelerator - Contents of code file: frmMutilate.frm

VERSION 5.00
Begin VB.Form frmMutilate 
   Caption         =   "Form1"
   ClientHeight    =   6135
   ClientLeft      =   3270
   ClientTop       =   2295
   ClientWidth     =   6795
   LinkTopic       =   "Form1"
   ScaleHeight     =   409
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   453
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   315
      Left            =   120
      TabIndex        =   0
      Top             =   60
      Width           =   1215
   End
End
Attribute VB_Name = "frmMutilate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" ( _
   ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any,
    lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function Ellipse 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 Function BeginPath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function StrokeAndFillPath Lib "gdi32" (ByVal hDC As Long) As
 Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long


Private m_cDib As cDIBSection
Private m_cDibBrush As cDIBSection
Private m_cDibWork As cDIBSection

Private Enum EBrushType
   eBrushSquare
   eBrushRound
End Enum
Private Enum EEffectType
   eEffectPaint
   eEffectRank1
   eEffectRank2
   eEffectBlur
   eEffectSharpen
   eEffectRandomise
   eEffectStatic
End Enum

Private m_bNoPaint As Boolean
Private m_eType As EEffectType

Private Sub ApplyBrush(ByVal x As Long, ByVal y As Long)
   If Not m_cDibBrush Is Nothing Then
      x = x - m_cDibBrush.Height \ 2
      y = y - m_cDibBrush.Width \ 2
      Select Case m_eType
      Case eEffectPaint
         DoPaint m_cDib, m_cDibWork, m_cDibBrush, x, y, &HCC6633, 200
      Case eEffectStatic
         DoStatic m_cDib, m_cDibWork, m_cDibBrush, x, y, 128
      Case eEffectRank1
         DoRankFilter m_cDib, m_cDibWork, m_cDibBrush, x, y, eRFMedian, -1, 0
      Case eEffectRank2
         DoRankFilter m_cDib, m_cDibWork, m_cDibBrush, x, y, eRFMaximum, 1, 0
      Case eEffectBlur
         DoStandardFilter m_cDib, m_cDibWork, m_cDibBrush, x, y, eRFBlur, 1, 0
      Case eEffectSharpen
         DoStandardFilter m_cDib, m_cDibWork, m_cDibBrush, x, y, eRFSharpen, 1,
          0
      Case eEffectRandomise
         DoStatic2 m_cDib, m_cDibWork, m_cDibBrush, x, y, 2
      End Select
      m_cDibWork.PaintPicture m_cDib.hDC, x, y
      m_cDib.PaintPicture Me.hDC, x, y, m_cDibBrush.Width, m_cDibBrush.Height,
       x, y
   End If
End Sub

Private Sub Reset()
Dim lHDC As Long
   lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   If lHDC <> 0 Then
      m_cDib.LoadPictureBlt lHDC
      DeleteDC lHDC
   Else
      ThrowError 3
   End If
End Sub

Private Sub CreateBrush( _
      ByVal eType As EBrushType, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long _
   )
Dim tR As RECT, tER As RECT
Dim hBr As Long, hBrOld As Long
Dim hPen As Long, hPenOld As Long
Dim bFail As Boolean
Dim i As Long
Dim lCOl As Long
         
   If (lWidth <> m_cDibBrush.Width) Or (lHeight <> m_cDibWork.Height) Then
      If Not m_cDibBrush.Create(lWidth, lHeight) Then
         ThrowError eeFailCreateBrush
         bFail = True
      ElseIf Not m_cDibWork.Create(lWidth, lHeight) Then
         ThrowError eeFailCreateBrush
         bFail = True
      End If
      If bFail Then
         Set m_cDibBrush = Nothing
         Set m_cDibWork = Nothing
         Exit Sub
      End If
   End If
         
   ' Set up for brush type:
   tR.right = lWidth
   tR.bottom = lHeight
   Select Case eType
   Case eBrushRound
      hBr = CreateSolidBrush(&H0&)
      FillRect m_cDibBrush.hDC, tR, hBr
      DeleteObject hBr
      LSet tER = tR
      For i = tR.bottom - tR.top \ 2 To 1 Step -2
         lCOl = 255 - ((i * 255) \ (tR.bottom - tR.top))
         hBr = CreateSolidBrush(RGB(lCOl, lCOl, lCOl))
         hBrOld = SelectObject(m_cDibBrush.hDC, hBr)
         hPen = CreatePen(0&, 1, RGB(lCOl, lCOl, lCOl))
         hPenOld = SelectObject(m_cDibBrush.hDC, hPen)
         Ellipse m_cDibBrush.hDC, tER.left, tER.top, tER.right, tER.bottom
         SelectObject m_cDibBrush.hDC, hPenOld
         DeleteObject hPen
         SelectObject m_cDibBrush.hDC, hBrOld
         DeleteObject hBr
         InflateRect tER, -1, -1
      Next i
      
   Case eBrushSquare
      hBr = CreateSolidBrush(&HFFFFFF)
      FillRect m_cDibBrush.hDC, tR, hBr
      DeleteObject hBr
      
   End Select
   
End Sub

Private Sub Command1_Click()
Static x As Long
Static y As Long
Static xDir As Long
Static yDir As Long
Static iStep As Long
   
   Randomize Timer
   xDir = 0: yDir = 0: iStep = 0
   m_eType = eEffectPaint
   If Command1.Caption <> "&Stop" Then
      Command1.Caption = "&Stop"
   Else
      Command1.Caption = "&Start"
   End If
   x = Rnd * m_cDib.Width
   y = Rnd * m_cDib.Height
   Do While Abs(xDir) < 4
      xDir = (Rnd * 6 - 3) * 2
   Loop
   Do While Abs(yDir) < 4
      yDir = (Rnd * 6 - 3) * 2
   Loop
   
   Do While Command1.Caption = "&Stop"
      ApplyBrush x, y
      x = x + xDir * Rnd
      y = y + yDir * Rnd
      If x > m_cDib.Width Or x < 0 Then
         xDir = -1 * xDir
      End If
      If y > m_cDib.Height Or y < 0 Then
         yDir = -1 * yDir
      End If
      iStep = iStep + 1
      If (iStep Mod 40) = 0 Then
         xDir = 0: yDir = 0
         Do While Abs(xDir) < 4
            xDir = (Rnd * 6 - 3) * 2
         Loop
         Do While Abs(yDir) < 4
            yDir = (Rnd * 6 - 3) * 2
         Loop
      End If
      If (iStep Mod 70) = 0 Then
         m_eType = m_eType + 1
         If (m_eType > eEffectRandomise) Then
            m_eType = eEffectPaint
         End If
      End If
      DoEvents
   Loop
   
End Sub

Private Sub Form_Load()

   'm_eType = eEffectBlur
   m_eType = eEffectPaint
   DoChannel(eBlue) = True
   DoChannel(eRed) = True
   DoChannel(eGreen) = True
   
   Set m_cDib = New cDIBSection
   Set m_cDibBrush = New cDIBSection
   Set m_cDibWork = New cDIBSection

   If m_cDib.Create(Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \
    Screen.TwipsPerPixelY) Then
      Reset
      CreateBrush eBrushRound, 96, 96
   Else
      Set m_cDib = Nothing
      Set m_cDibBrush = Nothing
      Set m_cDibWork = Nothing
      ThrowError 1
   End If
   
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   If Button = vbLeftButton Then
      ApplyBrush x, y
   End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   If Button = vbLeftButton Then
      ApplyBrush x, y
   End If
End Sub

Private Sub Form_Paint()
   If Not m_cDib Is Nothing Then
      m_cDib.PaintPicture Me.hDC, 0, 0
   End If
End Sub