Option Explicit

Type strcBild
  Width    As Single
  Height   As Single
  AniCount As Single
  AniMax   As Single
End Type

Public Animation1 As strcBild
Public Animation2 As strcBild

Public Const SCREENWIDTH As Single = 800
Public Const SCREENHEIGHT As Single = 600

Public FrameTime As Long
Public Const FrameRate = 50

Option Explicit

Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim bmpAnimation1 As DirectDrawSurface7
Dim bmpAnimation2 As DirectDrawSurface7

Dim running As Boolean

Private Sub Form_Load()
  Dim Destrect As RECT
  Dim SrcRect As RECT
  Dim hlpY As Single

  Me.Show
  Me.Refresh

  Initialization
  BitmapLaden

  running = True

  Do
    If GetTime - FrameTime < FrameRate Then
      DoEvents
    Else
      With SrcRect
        .Left = (Animation1.Width * Animation1.AniCount): _
              .Right = (.Left + Animation1.Width)
        .Top = 0: .Bottom = Animation1.Height
      End With
      BackBuffer.BltFast _
            100, 100, bmpAnimation1, SrcRect, DDBLTFAST_WAIT

      With Animation1
        .AniCount = .AniCount + 1
        If .AniCount > .AniMax Then .AniCount = 0
      End With

      With SrcRect
        hlpY = Int(Animation2.AniCount / 11)
        .Left = (Animation2.AniCount - (hlpY * 11)) * _
            Animation2.Width: .Right = (.Left + Animation2.Width)
        .Top = (hlpY * Animation2.Height): _
            .Bottom = (.Top + Animation2.Height)
      End With
      BackBuffer.BltFast _
            300, 100, bmpAnimation2, SrcRect, DDBLTFAST_WAIT

      With Animation2
        .AniCount = .AniCount + 1
        If .AniCount > .AniMax Then .AniCount = 0
      End With

      BackBuffer.SetForeColor vbRed
      BackBuffer.SetFont Me.Font
      BackBuffer.DrawText _
            10, 10, "DirectDraw und Bitmaps-Animation", False
      BackBuffer.DrawText _
            10, 30, "<Esc> beendet das Programm", False

      PrimarySurface.Flip Nothing, DDFLIP_WAIT
      FrameTime = GetTime

      ClearBuffer vbBlack

      DoEvents
    End If
  Loop While running

  Terminate
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
  If (KeyAscii = vbKeyEscape) Then
    running = False
  End If
End Sub

Sub Initialization()
  Set DD7 = DX7.DirectDrawCreate("")
  DD7.SetCooperativeLevel Me.hWnd, DDSCL_EXCLUSIVE Or _
        DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT
  DD7.SetDisplayMode SCREENWIDTH, SCREENHEIGHT, 16, 0, _
        DDSDM_DEFAULT

  With SurfaceDesc
    .lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
    .ddsCaps.lCaps = _
        DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
    .lBackBufferCount = 1
  End With
  Set PrimarySurface = DD7.CreateSurface(SurfaceDesc)
  SurfaceDesc.ddsCaps.lCaps = DDSCAPS_BACKBUFFER

  Set BackBuffer = _
        PrimarySurface.GetAttachedSurface(SurfaceDesc.ddsCaps)
End Sub

Sub BitmapLaden()
  Dim BmpDesc As DDSURFACEDESC2

  BmpDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  BmpDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN

  Animation1.Width = 49: Animation1.Height = 104
  Animation1.AniCount = 0: Animation1.AniMax = 31
  BmpDesc.lWidth = 1568: BmpDesc.lHeight = 104

  Set bmpAnimation1 = DD7.CreateSurfaceFromFile _
        (App.Path & "\Animation1.bmp", BmpDesc)

  Animation2.Width = 35: Animation2.Height = 35
  Animation2.AniCount = 0: Animation2.AniMax = 43
  BmpDesc.lWidth = 385: BmpDesc.lHeight = 140

  Set bmpAnimation2 = DD7.CreateSurfaceFromFile _
        (App.Path & "\Animation2.bmp", BmpDesc)
End Sub

Sub Terminate()
  Set bmpAnimation1 = Nothing
  Set bmpAnimation2 = Nothing
  DD7.RestoreDisplayMode
  DD7.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
  Set PrimarySurface = Nothing
  Set DD7 = Nothing
  Set DX7 = Nothing
  End
End Sub

Sub ClearBuffer(Color As Long)
  Dim Destrect As RECT

  With Destrect
    .Bottom = SCREENHEIGHT
    .Left = 0
    .Right = SCREENWIDTH
    .Top = 0
  End With
  BackBuffer.BltColorFill Destrect, Color
End Sub

Function GetTime() As Long
  GetTime = DX7.TickCount
End Function