Option Explicit

Type strcBild
  X       As Single
  Y       As Single
  Dir     As Single
  Width   As Single
  Height  As Single
End Type

Public BILD1 As strcBild
Public BILD2 As strcBild
 
Public Const SCREENWIDTH As Single = 800
Public Const SCREENHEIGHT As Single = 600

Option Explicit

Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim bmpBild1 As DirectDrawSurface7
Dim bmpBild2 As DirectDrawSurface7
Dim WithClip As Boolean

Dim running As Boolean
Dim FPSCounter As Single
Dim FPS As Single
Dim FPSTickLast As Long

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

  Me.Show
  Me.Refresh

  Initialization
  BitmapLaden

  BILD1.X = 100: BILD1.Y = 100: BILD1.Dir = -1
  BILD2.X = 200: BILD2.Y = 100: BILD2.Dir = -1

  running = True

  Do
    With SrcRect
      .Left = 0: .Right = BILD1.Width
      .Top = 0: .Bottom = BILD1.Height
    End With
    DisplaySprite _
          Destrect, bmpBild1, SrcRect, WithClip, BILD1.X, BILD1.Y
    If BILD1.Dir = -1 Then
      BILD1.X = BILD1.X - 1
      If BILD1.X < ((BILD1.Width + 20) * -1) Then BILD1.Dir = 1
    Else
      BILD1.X = BILD1.X + 1
      If BILD1.X > BILD1.Width Then BILD1.Dir = -1
    End If

    With SrcRect
      .Left = 0: .Right = BILD2.Width
      .Top = 0: .Bottom = BILD2.Height
    End With
    DisplaySprite _
          Destrect, bmpBild2, SrcRect, WithClip, BILD2.X, BILD2.Y
    If BILD2.Dir = -1 Then
      BILD2.Y = BILD2.Y - 1
      If BILD2.Y < ((BILD2.Height + 20) * -1) Then BILD2.Dir = 1
    Else
      BILD2.Y = BILD2.Y + 1
      If BILD2.Y > BILD2.Height Then BILD2.Dir = -1
    End If

    BackBuffer.SetForeColor vbRed
    BackBuffer.SetFont Me.Font
    BackBuffer.DrawText _
        10, 10, "DirectDraw und Bitmaps clippen", False
    BackBuffer.DrawText _
        10, 30, "<Esc> beendet das Programm", False
    BackBuffer.DrawText _
        10, 50, "FPS: " & Format(FPS, "0.0"), False
    BackBuffer.DrawText _
        10, 70, "<Space> Bitmaps zuschneiden: " & WithClip, False

    PrimarySurface.Flip Nothing, DDFLIP_WAIT

    ClearBuffer vbBlack

    If FPSCounter = 30 Then
      If FPSTickLast <> 0 Then _
            FPS = 1000 * 30 / (GetTime - FPSTickLast) + 1
      FPSTickLast = GetTime
      FPSCounter = 0
    End If
    FPSCounter = FPSCounter + 1

    DoEvents
  Loop While running

  Terminate
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
  If (KeyAscii = vbKeyEscape) Then
    running = False
  End If
  If (KeyAscii = vbKeySpace) Then
    If WithClip Then
      WithClip = False
    Else
      WithClip = True
    End If
  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

    BILD1.Width = 73: BILD1.Height = 85
    BmpDesc.lWidth = 73: BmpDesc.lHeight = 85

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

    BILD2.Width = 218: BILD2.Height = 36
    BmpDesc.lWidth = 218: BmpDesc.lHeight = 36

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

Sub Terminate()
  Set bmpBild1 = Nothing
  Set bmpBild2 = 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

Sub DisplaySprite(Destrect As RECT, Sprite As _
      DirectDrawSurface7, SrcRect As RECT, Clip As Boolean, _
      ByVal xCoord As Long, ByVal yCoord As Long)

  Dim XSrcRect As RECT

  If Clip = True Then
    XSrcRect = SrcRect
    With SrcRect
      If xCoord > (SCREENWIDTH - (.Right - .Left)) Then .Right = _
            (.Right - (xCoord - (SCREENWIDTH - (.Right - .Left))))
      If xCoord < 0 Then
        .Left = .Left + (xCoord * -1)
        xCoord = 0
      End If
      If yCoord > (SCREENHEIGHT - (.Bottom - .Top)) Then _
            .Bottom = (.Bottom - (yCoord - (SCREENHEIGHT - _
            (.Bottom - .Top))))
      If yCoord < 0 Then
        .Top = .Top + (yCoord * -1)
        yCoord = 0
      End If
    End With
    BackBuffer.BltFast _
          xCoord, yCoord, Sprite, SrcRect, DDBLTFAST_WAIT
    SrcRect = XSrcRect
  Else
    BackBuffer.BltFast _
          xCoord, yCoord, Sprite, SrcRect, DDBLTFAST_WAIT
  End If

End Sub