frmanimatedlogo.frm

This application provides much functionality for creating data-driven reports, including preview, gr

VERSION 5.00
Begin VB.Form frmAnimatedLogo 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   2760
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4710
   LinkTopic       =   "Form1"
   ScaleHeight     =   184
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   314
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox picLogo 
      AutoSize        =   -1  'True
      Height          =   540
      Left            =   540
      ScaleHeight     =   480
      ScaleWidth      =   1755
      TabIndex        =   0
      Top             =   135
      Visible         =   0   'False
      Width           =   1815
   End
   Begin VB.Timer tmrLogo 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   45
      Top             =   45
   End
End
Attribute VB_Name = "frmAnimatedLogo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type RECT
    rleft As Long
    rtop As Long
    rright As Long
    rbot As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type WINDOWPLACEMENT
    Length As Long
    flags As Long
    showCmd As Long
    ptMinPosition As POINTAPI
    ptMaxPosition As POINTAPI
    rcNormalPosition As RECT
End Type

Private Declare Function GetForegroundWindow Lib "user32" () As Long
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 Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName$, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SetWindowPlacement Lib "user32" (ByVal hWnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long

Private Const SRCCOPY& = &HCC0020 ' (DWORD) dest = source
Private Const SRCAND& = &H8800C6  ' (DWORD) dest = source AND dest

Private Const SW_HIDE& = 0
Private Const SW_SHOWNOACTIVATE& = 4

Private Const HWND_TOPMOST& = -1
Private Const SWP_NOACTIVATE& = &H10
Private Const SWP_FRAMECHANGED& = &H20
Private Const SWP_SHOWME& = SWP_FRAMECHANGED& Or SWP_NOACTIVATE&

Private currWinP As WINDOWPLACEMENT

Private lngHWnd As Long, lngHDC As Long
Private lngScreenDC As Long

Private lngPicHeight As Long, lngPicWidth As Long
Private intFrmX As Integer, intFrmY As Integer
Public blnWinVis As Boolean
Private sngRad As Single

Private lngStageDC As Long
Private lngLogoDC As Long
Private lngBackDC As Long

Private intAngle_x As Integer, intAngle_y As Integer, intSpeed As Integer


Public Sub LoadLogo(ByVal AngleX As Integer, _
                                        ByVal AngleY As Integer, _
                                        ByVal Speed As Integer, _
                                        ByVal PictureLogo As IPictureDisp)

    UnloadLogo

    intAngle_x = AngleX
    intAngle_y = AngleY
    intSpeed = Speed
    picLogo.Picture = PictureLogo

    sngRad = 3.14159265359 / 180

    With frmAnimatedLogo
        lngHWnd = .hWnd
        lngHDC = .hDC
    End With

    With picLogo
        lngPicHeight = .Height
        lngPicWidth = .Width
    End With

    intFrmX = Screen.Width / Screen.TwipsPerPixelX - lngPicWidth / 1.5
    intFrmY = 0

    lngScreenDC = CreateDC("DISPLAY", vbNullString, vbNullString, 0&)    'get screen device context

    lngLogoDC = NewDC(lngHDC, lngPicWidth, lngPicHeight)    'create work areas for logo
    lngBackDC = NewDC(lngHDC, lngPicWidth, lngPicHeight)
    lngStageDC = NewDC(lngHDC, lngPicWidth, lngPicHeight)

    Call SelectObject(lngLogoDC, picLogo)
    Call BitBlt(lngBackDC, 0, 0, lngPicWidth, lngPicHeight, lngScreenDC, intFrmX, intFrmY, SRCCOPY)

    currWinP.Length = Len(currWinP)
    currWinP.flags = 0&
    currWinP.showCmd = SW_SHOWNOACTIVATE

    blnWinVis = False
    tmrLogo.Enabled = True
End Sub

Public Sub UnloadLogo()
    tmrLogo.Enabled = False

    picLogo.Picture = LoadPicture()

    Call DeleteObject(lngStageDC)
    Call DeleteObject(lngBackDC)
    Call DeleteObject(lngLogoDC)

    lngStageDC = 0
    lngBackDC = 0
    lngLogoDC = 0

    Unload Me
End Sub

Private Sub tmrLogo_Timer()
    Static lngOldFocus As Long, oldRect As RECT
    Dim i As Integer, MousePos As POINTAPI
    Dim lngCurFocus As Long, curRect As RECT
    Dim sngTmp As Single

    lngCurFocus = GetForegroundWindow()
    Call GetCursorPos(MousePos)
    Call GetWindowRect(lngCurFocus, curRect)

    If (MousePos.X > intFrmX And MousePos.Y < lngPicHeight) Or lngCurFocus <> lngOldFocus Or EqualRect(curRect, oldRect) = 0 Then
        lngOldFocus = lngCurFocus
        Call CopyRect(oldRect, curRect)
        If blnWinVis Then
            currWinP.showCmd = SW_HIDE
            Call SetWindowPlacement(lngHWnd, currWinP)
            blnWinVis = False
        End If
    Else
        If MousePos.X < intFrmX Or MousePos.Y > intFrmY + lngPicHeight Then
            If blnWinVis = False Then
                Call BitBlt(lngBackDC, 0, 0, lngPicWidth, lngPicHeight, lngScreenDC, intFrmX, intFrmY, SRCCOPY)
                currWinP.showCmd = SW_SHOWNOACTIVATE
                Call SetWindowPlacement(lngHWnd, currWinP)
                Call SetWindowPos(lngHWnd, HWND_TOPMOST, intFrmX, intFrmY, lngPicWidth, lngPicHeight, SWP_SHOWME)
                blnWinVis = True
            End If
        End If

        Call BitBlt(lngStageDC, 0, 0, lngPicWidth, lngPicHeight, lngBackDC, 0, 0, SRCCOPY)

        sngTmp = lngPicWidth / 3.2
        For i = lngPicWidth To 1 Step -1
            Call BitBlt(lngStageDC, Cos(DegToRad(intAngle_x + i)) * sngTmp + sngTmp, Sin(DegToRad(intAngle_y + i)) * 5 + 2.5, 1, lngPicHeight, lngLogoDC, i, 0, SRCAND)
        Next i

        Call BitBlt(lngHDC, 0, 0, lngPicWidth, lngPicHeight, lngStageDC, 0, 0, SRCCOPY)

        intAngle_x = intAngle_x + intSpeed
        intAngle_y = intAngle_y + intSpeed

        If intAngle_x >= 360 Or intAngle_x <= -360 Then
            intAngle_x = 0
        End If
        If intAngle_y >= 360 Or intAngle_y <= -360 Then
            intAngle_y = 0
        End If
    End If
End Sub

Private Function DegToRad(Angle As Single)
   DegToRad = Angle * sngRad
End Function

Private Function NewDC(hdcScreen As Long, HorRes As Long, VerRes As Long) As Long
Dim hdcCompatible As Long
Dim hbmScreen As Long

    hdcCompatible = CreateCompatibleDC(hdcScreen)
    hbmScreen = CreateCompatibleBitmap(hdcScreen, HorRes, VerRes)
    If SelectObject(hdcCompatible, hbmScreen) = vbNull Then
        NewDC = vbNull
    Else
        NewDC = hdcCompatible
    End If
End Function