Attribute VB_Name = "gen_GIFAnim_0000"
Option Explicit
Option Base 0

'Private Const STM_SETICON = &H170
Public Const GIFANIM_SetGIFImage As Long = &H170&
'Public Const GIFANIM_SetBackhWnd As Long = &H170& '?????????




#Const VBSafe = True
#Const InIDE = True

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
  End Type

Public Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
'Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As Any) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

#If VBSafe And InIDE Then
  Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
  #End If

' ----==== User32 API Deklarationen ====----
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
' ----==== GDI+ Konstanten ====----
'Private Const GdiPlusVersion As Long = 1&
Private Const FrameDimensionTime As String = "{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"
Private Const PropertyTagFrameDelay As Long = &H5100&
'Private Const PropertyTagLoopCount As Long = &H5101&
' ----==== GDI+ Typen ====----

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
  End Type

Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As GDIPlus_Status
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GDIPlus_Status
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As GDIPlus_Status
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As GDIPlus_Status
Private Declare Function GdipGetImageBounds Lib "gdiplus" (ByVal Image As Long, ByRef srcRect As RECTF, ByRef srcUnit As Long) As GDIPlus_Status
'Private Declare Function GdipGetPropertyCount Lib "gdiplus" (ByVal Image As Long, ByRef numOfProperty As Long) As GDIPlus_Status
'Private Declare Function GdipGetPropertyIdList Lib "gdiplus" (ByVal Image As Long, ByVal numOfProperty As Long, ByRef list As Long) As GDIPlus_Status
Private Declare Function GdipGetPropertyItem Lib "gdiplus" (ByVal Image As Long, ByVal propId As Long, ByVal propSize As Long, ByRef buffer As Any) As GDIPlus_Status
Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" (ByVal Image As Long, ByVal propId As Long, ByRef Size As Long) As GDIPlus_Status
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal Color As Long) As GDIPlus_Status
Private Declare Function GdipImageGetFrameCount Lib "gdiplus" (ByVal Image As Long, ByRef dimensionID As GUID, ByRef Count As Long) As GDIPlus_Status
Private Declare Function GdipImageSelectActiveFrame Lib "gdiplus" (ByVal Image As Long, ByRef dimensionID As GUID, ByVal frameIndex As Long) As GDIPlus_Status
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal Filename As Long, ByRef Image As Long) As GDIPlus_Status
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (Stream As Any, ByRef Image As Long) As GDIPlus_Status
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
'Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private tGuidFDT As GUID




Private Type GIFAnim_Data
  lGifBitmap As Long
  lShowFrame As Long
  lFrameCount As Long
  BackColor As Long
  hwnd As Long
  hTimer As Long
  CurInterval As Long
  TimerProc As Long
  Width As Long
  Height As Long
  DelaysPtrReal As Long
  DelaysPtr As Long
  DelaysMode As Long
  #If InIDE Then
    'ProcID As Long
    'ThreadID As Long
    #End If
  End Type
#If VBSafe And InIDE Then
  Private ChkProcID As Long
  #End If
Private Const GIFAnim_DataSize As Long = 52&






Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long



Public Const GIFAnim_ClassName As String = "STATIC_GIFANIM"
Private GIFAnim_OldProc As Long
Private Const GIFAnim_Style_AutoDiscardGIFs As Long = &H1&

Public Function GIFAnim_Register() As Boolean
  Dim xType1 As WNDCLASSEX
  
  If GetClassInfoEx("STATIC", xType1) Then
    GIFAnim_OldProc = xType1.lpfnWndProc
    xType1.ClassName = GIFAnim_ClassName
    'Stop
    xType1.hbrBackground = 0&
    GIFAnim_Register = RegisterClassEx(xType1, AddressOf GIFAnim_ClassHandler)
    Call CLSIDFromString(StrPtr(FrameDimensionTime), tGuidFDT)
    End If
  End Function

Public Function GIFAnim_Unregister()
  Call UnregisterClass(GIFAnim_ClassName)
  End Function

Private Sub GifAnim_Discard(ByRef hGifAnim As Long, ByVal WindowStyle As Long)
  Dim xType1 As GIFAnim_Data
  
  'Stop
  If Not hGifAnim = 0& Then
    Call RtlMoveMemory(xType1, ByVal hGifAnim, GIFAnim_DataSize)
    With xType1
      If Not .hTimer = 0& Then Call KillTimer(.hwnd, .hTimer)
      If Not .DelaysPtrReal = 0& Then Call LocalFree(.DelaysPtrReal)
      If Not .lGifBitmap = 0& Then Call GdipDisposeImage(.lGifBitmap)
      End With
    Call LocalFree(hGifAnim)
    hGifAnim = 0&
    Call UnUseGDIPlus
    End If
  End Sub

Private Function GIFAnim_Use(ByVal hwnd As Long, ByVal hImage As Long, ByVal WindowStyle As Long) As Long
  Dim xType1 As GIFAnim_Data
  Dim xType2 As RECTF
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xLong3 As Long
  Dim tPropItem As PropertyItem
  
  #If VBSafe And InIDE Then
    Call GetWindowThreadProcessId(hwnd, ChkProcID)
    #End If
    
  If Not hImage = 0& Then
    With xType1
      If GdipImageGetFrameCount(hImage, tGuidFDT, .lFrameCount) = OK Then
        If GdipGetPropertyItemSize(hImage, PropertyTagFrameDelay, xLong1) = OK Then
          If xLong1 >= 16& Then
            .DelaysPtrReal = LocalAlloc(0&, xLong1 + &H10&)
            If Not .DelaysPtrReal = 0& Then
              If GdipGetPropertyItem(hImage, PropertyTagFrameDelay, xLong1, ByVal .DelaysPtrReal) = OK Then
                Call RtlMoveMemory(tPropItem, ByVal .DelaysPtrReal, 16&)
                Select Case (tPropItem.type And &HFFF&)
                  Case 1&: .DelaysMode = 1&
                  Case 3&: .DelaysMode = 2&
                  Case 4&: .DelaysMode = 4&
                  End Select
                If Not .DelaysMode = 0& And .DelaysMode * .lFrameCount = tPropItem.length Then
                  .DelaysPtr = tPropItem.Value
                  If GdipGetImageBounds(hImage, xType2, 2&) = OK Then
                    .hwnd = hwnd
                    .lGifBitmap = hImage
                    .Width = xType2.Right - xType2.Left
                    .Height = xType2.Bottom - xType2.Top
                    GIFAnim_Use = LocalAlloc(0&, GIFAnim_DataSize)
                    If Not GIFAnim_Use = 0& Then
                      .TimerProc = GetAddressOf(AddressOf GifAnim_FrameTimerEvent)
                      Call RtlMoveMemory(ByVal GIFAnim_Use, xType1, GIFAnim_DataSize)
                      If .lFrameCount > 1& Then
                        Call GifAnim_FrameTimerEvent(hwnd, 275&, GIFAnim_Use, 0&)
                        Else
                        Call GIFAnim_RealEraseTransparent(hwnd)
                        Call SendMessage(.hwnd, &HF&, 0&, 0&)
                        End If
                      Exit Function
                      End If
                    End If
                  End If
                End If
              Call LocalFree(.DelaysPtrReal)
              End If
            End If
          End If
        End If
      End With
    End If
  End Function

Private Function GIFAnim_ClassHandler(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Select Case Msg
    Case GIFANIM_SetGIFImage
      lParam = GetWindowLong(hwnd, -21&)
      Msg = GetWindowLong(hwnd, -16&)
      If Not lParam = 0& Then Call GifAnim_Discard(lParam, Msg)
      GIFAnim_ClassHandler = GIFAnim_Use(hwnd, wParam, Msg)
      Call SetWindowLong(hwnd, -21&, GIFAnim_ClassHandler)
      If GIFAnim_ClassHandler = 0& Then
        Call GIFAnim_RealEraseTransparent(hwnd)
        End If
      Debug.Print "SetImage: ", GIFAnim_ClassHandler
    Case &HF&
      If IsUnicode Then
        GIFAnim_ClassHandler = DefWindowProcWide(hwnd, Msg, wParam, lParam)
        Else
        GIFAnim_ClassHandler = DefWindowProcAnsi(hwnd, Msg, wParam, lParam)
        End If
      Call GIFAnim_RealDrawFrame(hwnd)
'      GoTo ForceProc
      'If Not GetWindowLong(hwnd, -21&) = 0& Then GoTo ForceProc
    Case &H85&
      GIFAnim_ClassHandler = 1&
    Case &H14&
      'call GIFAnim_RealEraseTransparent (hwnd)
      GIFAnim_ClassHandler = 1&
    Case &H2&
      lParam = GetWindowLong(hwnd, -21&)
      If Not lParam = 0& Then Call GifAnim_Discard(lParam, GetWindowLong(hwnd, -16&))
    Case Else
ForceProc:
    If IsUnicode Then
      GIFAnim_ClassHandler = CallWindowProcWide(GIFAnim_OldProc, hwnd, Msg, wParam, lParam)
      Else
      GIFAnim_ClassHandler = CallWindowProcAnsi(GIFAnim_OldProc, hwnd, Msg, wParam, lParam)
      End If
    End Select
  End Function











































Private Function GifAnim_FrameTimerEvent(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
  Dim xType1 As GIFAnim_Data
  Dim xLong1 As Long

'Stop
Static xBool1 As Boolean
If Not xBool1 Then
xBool1 = True
'Exit Function
  
  
  Call RtlMoveMemory(xType1, ByVal idEvent, GIFAnim_DataSize)
  With xType1
    Call GIFAnim_RealEraseTransparent(.hwnd)
    Call SendMessage(.hwnd, &HF&, 0&, 0&)
    #If VBSafe And InIDE Then
      Call GetWindowThreadProcessId(hwnd, uMsg)
      If Not uMsg = ChkProcID Then
        Debug.Print "GifAnimation/VBSafe+InIDE: Object discarded to safe the IDE"
        Call GifAnim_Discard(idEvent, GetWindowLong(hwnd, -16&))
        End If
      #End If
    
    
    'Call GIFAnim_RealDrawFrame(xType1)
form1.Caption = "Drawing: " & .lShowFrame
    .lShowFrame = (.lShowFrame + 1) Mod .lFrameCount
    
    'ReDim xLongA1(.lFrameCount - 1&)
    'Call GetGifFrameDelays(lGifBitmap, .lFrameCount, xLongA1())

    xLong1 = .DelaysPtr
    Call UIntAddUInt(xLong1, .lShowFrame * .DelaysMode)
    Call RtlMoveMemory(ByVal VarPtr(xLong1), ByVal xLong1, .DelaysMode)
    If xLong1 < 1& Then xLong1 = 1&
    xLong1 = xLong1 * 10&
    If .hTimer = 0& Then
      GoTo AlwaysCreateTimer
      ElseIf Not xLong1 = .CurInterval Then
      Call KillTimer(.hwnd, idEvent)
AlwaysCreateTimer:
'Stop
      .hTimer = SetTimer(.hwnd, idEvent, xLong1, .TimerProc)
      End If
    'Call GetGifLoopCount(.lGifBitmap, .lFrameLoopCount)
    End With
  Call RtlMoveMemory(ByVal idEvent, xType1, GIFAnim_DataSize)
  
  
xBool1 = False
End If
  End Function

Private Sub GIFAnim_RealEraseTransparent(ByVal hwnd As Long)
  Dim xType1 As RECT
  
  If Not GetWindowRect(hwnd, xType1) = 0& Then
    hwnd = GetParent(hwnd)
    If Not ScreenToClient(hwnd, xType1) = 0& Then
      If Not ScreenToClient(hwnd, ByVal VarPtr(xType1.Right)) = 0& Then
        Call RedrawWindow(hwnd, xType1, 0&, &H30F)
        End If
      End If
    End If
  End Sub




Private Sub GIFAnim_RealDrawFrame(ByVal hwnd As Long)
  Dim xType1 As GIFAnim_Data
  Dim lGifGraphics As Long
  Dim hdc As Long
  
  If Not GetWindowLong(hwnd, -21&) = 0& Then Debug.Print hwnd;
'  Stop
  hwnd = GetWindowLong(hwnd, -21&)
  If Not hwnd = 0& Then
    Call RtlMoveMemory(xType1, ByVal hwnd, GIFAnim_DataSize)
    With xType1
      If GdipImageSelectActiveFrame(.lGifBitmap, tGuidFDT, .lShowFrame) = OK Then
Debug.Print , .hwnd
        hdc = GetDC(.hwnd)
        If Not hdc = 0& Then
          If GdipCreateFromHDC(hdc, lGifGraphics) = OK Then
            Call GdipDrawImageRect(lGifGraphics, .lGifBitmap, 0&, 0&, .Width, .Height)
            Call GdipDeleteGraphics(lGifGraphics)
            End If
          Call ReleaseDC(.hwnd, hdc)
          End If
        End If
      End With
    End If
  End Sub

