vbAccelerator - Contents of code file: frmEyes.frm

VERSION 5.00
Begin VB.Form frmEyes 
   BorderStyle     =   0  'None
   ClientHeight    =   3090
   ClientLeft      =   1950
   ClientTop       =   1965
   ClientWidth     =   4680
   ControlBox      =   0   'False
   Icon            =   "frmEyes.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   ShowInTaskbar   =   0   'False
   Begin VB.Timer tmrUpdate 
      Interval        =   50
      Left            =   2100
      Top             =   2460
   End
End
Attribute VB_Name = "frmEyes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND = &H112&
Private Const SC_MOVE = &HF010&
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
   (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
   (ByVal hwnd As Long, ByVal nIndex As Long, _
   ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)

'Requires Windows 2000 or later:
Private Const WS_EX_LAYERED = &H80000
Private Type BLENDFUNCTION
   BlendOp As Byte
   BlendFlags As Byte
   SourceConstantAlpha As Byte
   AlphaFormat As Byte
End Type
'//
'// currently defined blend function
'//

Private Const AC_SRC_OVER = &H0

'//
'// alpha format flags
'//
Private Const AC_SRC_ALPHA = &H1
Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
Private Const AC_SRC_NO_ALPHA = &H2
Private Const AC_DST_NO_PREMULT_ALPHA = &H10
Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function SetLayeredWindowAttributes Lib "user32" _
   (ByVal hwnd As Long, ByVal crKey As Long, _
   ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2

Private Declare Function UpdateLayeredWindow Lib "user32" _
   (ByVal hwnd As Long, ByVal hdcDst As Long, pptDst As Any, _
   psize As Any, ByVal hdcSrc As Long, _
   pptSrc As Any, crKey As Long, _
   ByVal pblend As Long, ByVal dwFlags As Long) As Long
Private Const ULW_COLORKEY = &H1
Private Const ULW_ALPHA = &H2
Private Const ULW_OPAQUE = &H4

Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long,
 lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_FRAME = &H400
Private Const RDW_INVALIDATE = &H1

' Set the position of a window:
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
Private Const HWND_BOTTOM = 1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long

Private m_cEyes As New cEyes

Private Sub AlwaysOnTop( _
        ByRef frmThis As Form, _
        ByVal blnState As Integer)
Dim lngParam As Long
Dim lngRet As Long
Dim lngLeft As Long
Dim lngTop As Long
Dim lngWidth As Long
Dim lngHeight As Long
    lngLeft = frmThis.Left
    lngTop = frmThis.Top
    lngWidth = frmThis.Width
    lngHeight = frmThis.Height
    If (blnState) Then
        lngParam = HWND_TOPMOST
    Else
        lngParam = HWND_NOTOPMOST
    End If
    lngRet = SetWindowPos((frmThis.hwnd), lngParam, 0, 0, 0, 0, (SWP_NOACTIVATE
     Or SWP_SHOWWINDOW))
    frmThis.Move lngLeft, lngTop, lngWidth, lngHeight
End Sub

Private Sub create()
   
   m_cEyes.FileName = App.Path & "\Large Eyes.bmp"
   Me.Width = m_cEyes.CellWidth * 2 * Screen.TwipsPerPixelX
   Me.Height = m_cEyes.CellHeight * Screen.TwipsPerPixelY
   
   Dim transColor As Long
   transColor = &HFF00FF
   Me.BackColor = transColor
   
   Dim lStyle As Long
   lStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
   lStyle = lStyle Or WS_EX_LAYERED
   SetWindowLong hwnd, GWL_EXSTYLE, lStyle
      
   SetLayeredWindowAttributes Me.hwnd, transColor, 235, LWA_COLORKEY Or
    LWA_ALPHA

   AlwaysOnTop Me, True
End Sub

Private Sub Form_Load()
   create
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   ' A better (more flexible) way of doing this is to use
   ' the vbAccelerator WM_NCHITTEST interception library.
   ' but if you want minimal code, here is the quick way!
    If Button = vbLeftButton Then
        'Fake a mouse down on the titlebar so form can be moved...
        ReleaseCapture
        SendMessageLong Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
   End If
End Sub


Private Sub mnuContext_Click(Index As Integer)
   Select Case Index
   Case 0
   Case 2
      Unload Me
   End Select
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As
 Single)
   If Button = vbRightButton Then
      Unload Me
      'Me.PopupMenu mnuContextTOP, , x, y
    End If

End Sub

Private Sub tmrUpdate_Timer()
   
   Dim cursorPoint As POINTAPI
   GetCursorPos cursorPoint
   
   Dim leftEyeCentre As POINTAPI
   leftEyeCentre.x = (Me.Left + Me.ScaleWidth \ 4) \ Screen.TwipsPerPixelX
   leftEyeCentre.y = (Me.Top + Me.ScaleHeight \ 4) \ Screen.TwipsPerPixelY
      
   Dim leftEyeAngle As Double
   leftEyeAngle = GetAngle(cursorPoint, leftEyeCentre) - 180
   If (leftEyeAngle < 0) Then
      leftEyeAngle = 360 + leftEyeAngle
   End If
   m_cEyes.Frame = (leftEyeAngle / 360) * 35 + 1
   If (cursorPoint.x > leftEyeCentre.x - m_cEyes.CellWidth \ 2) And
    (cursorPoint.x < leftEyeCentre.x + m_cEyes.CellWidth \ 2) Then
      If (cursorPoint.y > leftEyeCentre.y - m_cEyes.CellHeight \ 2) And
       (cursorPoint.y < leftEyeCentre.y + m_cEyes.CellHeight \ 2) Then
         m_cEyes.Frame = 0
      End If
   End If
   m_cEyes.Draw Me.hDC, 0, 0
   
   Dim rightEyeCentre As POINTAPI
   rightEyeCentre.x = leftEyeCentre.x + Me.ScaleWidth \ (2 *
    Screen.TwipsPerPixelX)
   rightEyeCentre.y = leftEyeCentre.y
   
   Dim rightEyeAngle As Double
   rightEyeAngle = GetAngle(cursorPoint, rightEyeCentre) - 180
   If (rightEyeAngle < 0) Then
      rightEyeAngle = 360 + rightEyeAngle
   End If
   m_cEyes.Frame = (rightEyeAngle / 360) * 35 + 1
   If (cursorPoint.x > rightEyeCentre.x - m_cEyes.CellWidth \ 2) And
    (cursorPoint.x < rightEyeCentre.x + m_cEyes.CellWidth \ 2) Then
      If (cursorPoint.y > rightEyeCentre.y - m_cEyes.CellHeight \ 2) And
       (cursorPoint.y < rightEyeCentre.y + m_cEyes.CellHeight \ 2) Then
         m_cEyes.Frame = 0
      End If
   End If
   m_cEyes.Draw Me.hDC, m_cEyes.CellWidth - 8, 0
   
   
   
End Sub
Private Function GetAngle(cursorPoint As POINTAPI, eyeCentre As POINTAPI) As
 Double
   
   ' work out the angle of the vectors:
   If (eyeCentre.y = cursorPoint.y) Then
      If (eyeCentre.x < cursorPoint.x) Then
         GetAngle = 90
      Else
         GetAngle = 270
      End If
   Else
      Dim eyeAngle As Double
      eyeAngle = Atn((eyeCentre.x - cursorPoint.x) / (eyeCentre.y -
       cursorPoint.y)) * 45 / Atn(1)
      If (eyeCentre.y > cursorPoint.y) Then
         If (eyeCentre.x > cursorPoint.x) Then
            GetAngle = 360 - eyeAngle
         Else
            GetAngle = -eyeAngle
         End If
      Else
         If (eyeCentre.x > cursorPoint.x) Then
            GetAngle = 180 - eyeAngle
         Else
            GetAngle = 180 - eyeAngle
         End If
      End If
   End If

End Function