'[To show animated icons (Not gif's)]
'It does not support embedded(resource) ani's at the moment.

'For suggestions,
'E.B. Knoppert, ProFinance WOERDEN Netherlands
'ebknoppert@hotmail.com

// USERCONTROL

Option Explicit

Dim hIcon           As Long
Dim hStatic         As Long
Dim m_AniFileName   As String
Dim m_AniResourceID As Long

Const GWL_STYLE = (-16)
Const IMAGE_ICON = 1
Const LR_LOADFROMFILE = &H10
Const SS_ICON = &H3&
Const STM_SETIMAGE = &H172
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Sub UserControl_Initialize()

    On Error Resume Next

    'Make use of a static control to show the animated icon upon.
    'Statics have a windowstyle for this.
    hStatic = CreateWindowEx(0, "STATIC", "", WS_CHILD Or WS_VISIBLE Or SS_ICON _
    , 0, 0, 32, 32 _
    , UserControl.hwnd, -1, App.hInstance, 0)

End Sub

Private Sub UserControl_Terminate()

    On Error Resume Next

    If hStatic Then DestroyWindow hStatic
    If hIcon Then DestroyIcon hIcon

    hIcon = 0
    hStatic = 0

End Sub

Private Sub UserControl_Resize()

    On Error Resume Next

    'Force icon size.
    UserControl.Size (32 + (UserControl.BorderStyle * 2)) * Screen.TwipsPerPixelX _
    , (32 + (UserControl.BorderStyle * 2)) * Screen.TwipsPerPixelY

End Sub

Private Sub UserControl_Show()

    UserControl_Resize

End Sub

Private Sub Refresh()

    On Error Resume Next

    Dim T As String

    If hIcon Then DestroyIcon hIcon

    hIcon = 0

    If Trim$(m_AniFileName) > "" Then T = Dir$(Trim$(m_AniFileName))

    If T > "" Then

        hIcon = LoadImage(ByVal 0&, m_AniFileName, IMAGE_ICON, 0, 0, LR_LOADFROMFILE)

    ElseIf m_AniResourceID Then

        'NOT tested!
        hIcon = LoadImage(ByVal App.hInstance, ByVal m_AniResourceID, IMAGE_ICON, 0, 0, 0)

    End If

    'Hint: It's possible to load the icon during creation of static control.
    'Then you should supply the icon as windowtext.
    If hIcon Then SendMessage hStatic, STM_SETIMAGE, IMAGE_ICON, ByVal hIcon

End Sub

Public Property Get AniFileName() As String

    AniFileName = m_AniFileName

End Property

Public Property Let AniFileName(ByVal vNewValue As String)

    m_AniFileName = vNewValue
    Refresh

End Property

Public Property Get AniResourceID() As Long

    AniResourceID = m_AniResourceID

End Property

Public Property Let AniResourceID(ByVal vNewValue As Long)

    m_AniResourceID = vNewValue
    Refresh

End Property

Public Property Get BackColor() As OLE_COLOR

    BackColor = UserControl.BackColor

End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)

    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"

End Property

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    On Error Resume Next

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("AniFileName", m_AniFileName, "")
    Call PropBag.WriteProperty("AniResourceID", m_AniResourceID, 0)

    Err.Clear

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    On Error Resume Next

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    m_AniFileName = PropBag.ReadProperty("AniFileName", "")
    m_AniResourceID = PropBag.ReadProperty("AniResourceID", 0)

    Refresh

    Err.Clear

End Sub
