FreeBASIC GIF アニメーション(動画)を表示

'//------------------------------------//
'作成 2019/07/14、更新 2020/10/07
'プログラミングの考え方：さいころを 2つ使って足し算の問題を自動生成してみる
'注意: このソースは、ユニコードで、表示・編集して下さい。
'//------------------------------------//

'coded by UEZ build  2019-07-12
'https://www.freebasic.net/forum/viewtopic.php?t=23934
'Add Screencontrol 2020-06-15

#Ifdef __Fb_64bit__
    #Inclib "gdiplus"
    #Include "win/gdiplus-c.bi"
#Else
    #Include "win/gdiplus.bi"
    Using gdiplus
#Endif

#Include "fbgfx.bi"

' Sets the graphics method GDI
' 描画方法を GDI に設定
SetEnviron("fbgfx=GDI")

Using FB 

Dim Shared gdipToken As ULONG_PTR
Dim Shared GDIp As GdiplusStartupInput 

'アニメーションGIFをデコードして、フレームを選択
Function _GDIPlus_GIFAnimGetFrameDimensionsCount(Byval hImage As Any Ptr) As Ulong
   Dim As Ulong iFrameDimCount
   GdipImageGetFrameDimensionsCount(hImage, @iFrameDimCount)
   Return iFrameDimCount
End Function

Function _GDIPlus_GIFAnimGetFrameDimensionsList(Byval hImage As Any Ptr, Byval iFrameDimCount As Ulong) As GUID
   Dim As GUID FrameDimList
   GdipImageGetFrameDimensionsList(hImage, @FrameDimList, iFrameDimCount)
   Return FrameDimList
End Function

Function _GDIPlus_GIFAnimGetFrameCount(Byval hImage As Any Ptr, Byval tFrameDimList As GUID) As Ulong
   Dim As Ulong iFrameCount
   GdipImageGetFrameCount(hImage, @tFrameDimList, @iFrameCount)
   Return iFrameCount
End Function

Sub _GDIPlus_GIFAnimSelectActiveFrame(Byval hImage As Any Ptr, Byval tFrameDimList As GUID, Byval iCurrentFrame As Ulong)
   GdipImageSelectActiveFrame(hImage, @tFrameDimList, iCurrentFrame)
End Sub

Function _GDIPlus_ImageGetPropertyItem(Byval hImage As Any Ptr, Byval iPropID As PROPID) As PropertyItem Ptr
   Dim As Ulong iSize
   GdipGetPropertyItemSize(hImage, iPropID, @iSize)
   Dim As PropertyItem Ptr buffer
   buffer = Allocate(iSize * SizeOf(PropertyItem))
   GdipGetPropertyItem(hImage, iPropID, iSize, @buffer[0])
   Return buffer
End Function

Sub _GDIPlus_GIFAnimGetFrameDelays(Byval hImage As Any Ptr, Byval iAnimFrameCount As Ulong, aFrameDelay() As Ulong)
   Dim As PropertyItem Ptr PropItem = _GDIPlus_ImageGetPropertyItem(hImage, PROPERTYTAGFRAMEDELAY)
   Select Case PropItem->type
      Case 1
         Dim As Ubyte Ptr delay = PropItem->value
         For i As Ulong = 0 To Ubound(aFrameDelay)
            aFrameDelay(i) = delay[i] * 10
         Next
      Case 3
         Dim As Ushort Ptr delay = PropItem->value
         For i As Ulong = 0 To Ubound(aFrameDelay)
            aFrameDelay(i) = delay[i] * 10
         Next
      Case 4
         Dim As Ulong Ptr delay = PropItem->value
         For i As Ulong = 0 To Ubound(aFrameDelay)
            aFrameDelay(i) = delay[i] * 10
         Next
   End Select
End Sub
'GDIPlus GIFセクションを終了

Function _GDIPlus_Startup() As Bool
   GDIp.GdiplusVersion = 1
   If GdiplusStartup(@gdipToken, @GDIp, NULL) <> 0 Then
      Error 1
      Return False
   Endif
   Return True
End Function

Sub _GDIPlus_Shutdown()
   GdiplusShutdown(gdipToken)
End Sub

Function _GDIPlus_ImageLoadFromFile(Byval sFilename As String) As Any Ptr
   Dim GDIpImage As Any Ptr
   If (GdipLoadImageFromFile(Wstr(sFilename), @GDIpImage) <> 0) Then
      Error 1
      Return 0
   End If
   Return GDIpImage
End Function

Sub RollDices()
   'GDIPlus 初期化
   If _GDIPlus_Startup() = False Then End -1

   
   Dim As String sFile = "tenor2.gif" '<------- ここで GIF アニメのファイル名を指定
   
   
   Dim As Any Ptr hGIFAnim = _GDIPlus_ImageLoadFromFile(sFile) 'GIG アニメファイルを読み込む
   
   Dim As Single iW, iH
   
   GdipGetImageDimension(hGIFAnim, @iW, @iH)   'GIF アニメの寸法を取得
   
   If iW = 0 Then 
      GdiplusShutdown(gdipToken)
      Messagebox(0, "Something went wrong to load the GIF animation!", "ERROR", 16)
      End -2
   End If
   
   'アニメを表示する FB GUIを作成する
	iW =640 : iH =480
   Screencontrol SET_DRIVER_NAME, "GDI"
   Screenres iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH 
   'Dim As String sWinTitle = "GDIPlus GIF Anim Player by UEZ"
   Dim As String sWinTitle = "足し算の問題を自動生成　 　"
   
   Dim As Integer iDW, iDH
   Screencontrol GET_DESKTOP_SIZE, iDW, iDH
   Dim tWorkingArea As RECT
   SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
   Screencontrol SET_WINDOW_POS, (iDW - iW) \ 2, ((tWorkingArea.Bottom - iH) - (iDH - tWorkingArea.Bottom)) \ 2
   
   
   Dim As HWND hHWND
   Screencontrol(GET_WINDOW_HANDLE, Cast(Integer, hHWND)) 'GDI+ 描画ハンドルを表示するための FB GUIハンドルを取得
   
   'GIF アニメを表示するバッファ付きGDIデバイスを作成する
   Dim As Any Ptr    hCanvas, _
               hDC = GetDC(hHWND), _
               hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
               hDC_backbuffer = CreateCompatibleDC(hDC), _
               hDC_obj = SelectObject(hDC_backbuffer, hHBitmap)
   GdipCreateFromHDC(hDC_backbuffer, @hCanvas)   
   
   'GDI+ で GIF アニメーションを設定する
   Dim As Ulong iFrame = 0, iFrameDimCount = _GDIPlus_GIFAnimGetFrameDimensionsCount(hGIFAnim)
   Dim As GUID tFrameDimList = _GDIPlus_GIFAnimGetFrameDimensionsList(hGIFAnim, iFrameDimCount)
   Dim As Ulong iFrames = _GDIPlus_GIFAnimGetFrameCount(hGIFAnim, tFrameDimList)
   Dim As Ulong aFrameDelays(0 To iFrames - 1)
   _GDIPlus_GIFAnimGetFrameDelays(hGIFAnim, iFrames, aFrameDelays())
   
   'フレーム遅延を含めてリアルタイムでGUI でアニメーションをループせずに再生
   Do
      _GDIPlus_GIFAnimSelectActiveFrame(hGIFAnim, tFrameDimList, iFrame) 'フレーム抽出
      GdipDrawImageRect(hCanvas, hGIFAnim, 0, 0, iW, iH) 'GDI キャンバスにフレームをコピー
      BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY) 'GUI にブリットフレーム
      Sleep aFrameDelays(iFrame)
      Windowtitle sWinTitle & " * Frame: " & iFrame + 1 & " / " & iFrames
      iFrame += 1
   Loop Until iFrame = iFrames
   
   'Sleep
   
   'GDI / GDI+ リソースを解放
   SelectObject(hDC_backbuffer, hDC_obj)
   DeleteDC(hDC_backbuffer)
   DeleteObject(hHBitmap)
   ReleaseDC(hHWND, hDC)
   GdipDeleteGraphics(hCanvas)
   GdipDisposeImage(hGIFAnim)
   _GDIPlus_Shutdown()
   
   'End 0
End Sub

'//------------------------------------//
'作成 2019/07/14
'プログラミングの考え方：さいころを 2つ使って足し算の問題を自動生成してみる
'注意: このソースは、ユニコードで、表示・編集して下さい。
'//------------------------------------//

#Include Once "xfont.bi"

Dim A As Integer
Dim B As Integer
Dim S As Integer
Dim Dice1 As Any Ptr
Dim Dice2 As Any Ptr
Dim FileName1 As String
Dim FileName2 As String
Dim KeyMoji As String

Dim x As Integer
Dim y As Integer
Dim Japanese As WString * 20
Dim Shared As xfont.interface font
font.loadfont("MsGothic.xf", 1) 'FontIndex 1 に、登録します
font.fontindex = 1 'フォントを使います


Print "サイコロを使って、足し算の問題を自動生成します。"
Print "何かキー入力で回答を表示します。そして次の問題を生成してます。"
Print "問題生成のくり返えしは、[Esc]キーで抜けます。"
Print

Screen 18, 32

Dice1 = ImageCreate(170,170)  '画像のために、記憶装置を、割り当てて、初期化します。
Dice2 = ImageCreate(170,170)  '画像のために、記憶装置を、割り当てて、初期化します。

Randomize

Do

   ScreenRes 640, 480, 32
   A = Rnd * 6 + 0.5
   B = Rnd * 6 + 0.5
   S = A+B
   
   RollDices  'GIF アニメを再生

   Cls
   FileName1 = "dice" & Str(A) & ".bmp"
   FileName2 = "dice" & Str(B) & ".bmp"
   BLoad FileName1, Dice1
   BLoad FileName2, Dice2
   
   Put (70,200),Dice1
   Put (360,200),Dice2
   
   Print
   Print
   Print
   Print
   Print Using "  ## + ## = "; A; B;
   Sleep
   
   Japanese ="　" & Str(S) & "　　　[Esc]キーで抜ける"
   x = 70
   y = 100
   font.drawstring ( , Japanese , x, y,4,4) '文字の大きさ 4倍 size
   

   KeyMoji=InKey                      'キーボード・バッファで、キー入力を待って、最初のキーの文字を返します。

   Sleep(2000)
   KeyMoji=InKey                      'キーボード・バッファで、キー入力を待って、最初のキーの文字を返します。

Loop Until KeyMoji=Chr(27)  ' [27]=[Esc] キー入力するまで、繰返す

ImageDestroy(Dice1)     '画像のための記憶装置を破棄して、割り当てを解除します。
ImageDestroy(Dice2)