Option Explicit

Public Enum COLOR_SEQUENZ
  C_RGB = 1
  C_BGR = 2
End Enum

Public Enum c16BIT
  Mode555 = 1
  Mode565 = 2
End Enum

Public RGBForm As COLOR_SEQUENZ
Public Mode16 As c16BIT
Public GruenMax As Single
Public BitDepth As Integer
Public GBitMask As Single
Public RBitMask As Single
Public BBitMask As Single

Public Type cRGB
  r As Byte
  g As Byte
  b As Byte
End Type

Public Sub GetColorMode(ddPS As DirectDrawSurface7)
  Dim ddsd As DDSURFACEDESC2

  ddPS.GetSurfaceDesc ddsd

  With ddsd.ddpfPixelFormat
    BitDepth = .lRGBBitCount
    If .lRBitMask > .lBBitMask Then
      RGBForm = C_BGR
    Else
      RGBForm = C_RGB
    End If

    If BitDepth = 16 Then
      If .lGBitMask = &H7E0 Then
        Mode16 = Mode565
        GruenMax = 63
      Else
        Mode16 = Mode555
        GruenMax = 31
      End If
    End If

    GBitMask = .lGBitMask
    RBitMask = .lRBitMask
    BBitMask = .lBBitMask
  End With
End Sub

Public Function GetRGB16(Color As Long) As cRGB
  Dim bsG As Single
  Dim bsR As Single
  Dim bsB As Single

  bsG = &H20
  If Mode16 = Mode555 Then
    If RGBForm = C_BGR Then
      bsR = &H400
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H400
      bsR = 1
    End If
  ElseIf Mode16 = Mode565 Then
    If RGBForm = C_BGR Then
      bsR = &H800
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H800
      bsR = 1
    End If
  End If

  With GetRGB16
    .r = (Color And RBitMask) / bsR
    .g = (Color And GBitMask) / bsG
    .b = (Color And BBitMask) / bsB
  End With
End Function

Public Function Get16BitColor(Color As cRGB) As Long
  Dim bsG As Single
  Dim bsR As Single
  Dim bsB As Single

  bsG = &H20
  If Mode16 = Mode555 Then
    If RGBForm = C_BGR Then
      bsR = &H400
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H400
      bsR = 1
    End If
  ElseIf Mode16 = Mode565 Then
    If RGBForm = C_BGR Then
      bsR = &H800
      bsB = 1
    ElseIf RGBForm = C_RGB Then
      bsB = &H800
      bsR = 1
    End If
  End If

  Get16BitColor = Color.r * bsR Or Color.g * bsG Or Color.b * bsB
End Function

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 counter As Byte

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

Private Sub Form_Load()
  Dim srcrect As RECT

  Me.Show
  Me.Refresh
  counter = 0

  Initialization
  BitmapLaden

  running = True

  Do
    With srcrect
      .Left = 0: .Right = 73
      .Top = 0: .Bottom = 85
    End With

    BackBuffer.BltFast 150, 100, bmpBild1, srcrect, DDBLTFAST_WAIT
    Fade
    BackBuffer.BltFast 250, 100, bmpBild2, srcrect, DDBLTFAST_WAIT

    BackBuffer.SetForeColor vbRed
    BackBuffer.SetFont Me.Font
    BackBuffer.DrawText _
          10, 10, "DirectDraw und Bitmaps Fade In/Out", False
    BackBuffer.DrawText _
          10, 30, "<Esc> beendet das Programm", False
    BackBuffer.DrawText _
          10, 50, "FPS: " & Format(FPS, "0.0"), False
    BackBuffer.DrawText 10, 70, "Farbtiefe: " & BitDepth, False

    If RGBForm = C_BGR Then
      BackBuffer.DrawText 10, 90, "Farbreihenfolge: BGR", False
    Else
      BackBuffer.DrawText 10, 90, "Farbreihenfolge: RGB", False
    End If

    If Mode16 = Mode555 Then
      BackBuffer.DrawText 10, 110, "Modus: 555", False
    Else
      BackBuffer.DrawText 10, 110, "Modus: 565", False
    End If
    BackBuffer.DrawText 10, 130, "<Cursor rauf> Fade out", False
    BackBuffer.DrawText 10, 150, "<Cursor runter> Fade in", False

    PrimarySurface.Flip Nothing, DDFLIP_WAIT

    ClearBuffer 0

    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 Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If (KeyCode = vbKeyUp) Then
    If counter < 33 Then counter = counter + 1
  End If

  If (KeyCode = vbKeyDown) Then
    If counter > 0 Then counter = counter - 1
  End If
End Sub

Sub Initialization()
  Set DD7 = DX7.DirectDrawCreate("")

  DD7.SetCooperativeLevel Me.hWnd, DDSCL_EXCLUSIVE Or _
        DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT
  DD7.SetDisplayMode 800, 600, 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)

  GetColorMode PrimarySurface
End Sub

Sub BitmapLaden()
  Dim BmpDesc As DDSURFACEDESC2

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

  BmpDesc.lWidth = 73
  BmpDesc.lHeight = 85

  Set bmpBild1 = _
        DD7.CreateSurfaceFromFile(App.Path & "\DX7.bmp", BmpDesc)
  Set bmpBild2 = _
        DD7.CreateSurfaceFromFile(App.Path & "\DX7.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 = 600
    .Left = 0
    .Right = 800
    .Top = 0
  End With
  BackBuffer.BltColorFill destrect, Color
End Sub

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

Sub Fade()
  Dim destrect As RECT
  Dim BmpDesc As DDSURFACEDESC2
  Dim Pixel As Long
  Dim x As Integer
  Dim y As Integer
  Dim PixelRGB As cRGB
  Dim einbyte As Single

  On Error GoTo ErrEnd

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

  BmpDesc.lWidth = 73
  BmpDesc.lHeight = 85

  bmpBild1.Lock _
        destrect, BmpDesc, DDLOCK_WAIT Or DDLOCK_READONLY, 0
  bmpBild2.Lock _
        destrect, BmpDesc, DDLOCK_WAIT Or DDLOCK_WRITEONLY, 0

  For y = 0 To 84
    For x = 0 To 72
      Pixel = bmpBild1.GetLockedPixel(x, y)
      PixelRGB = GetRGB16(Pixel)
      einbyte = PixelRGB.r
      If einbyte > 0 Then einbyte = einbyte - counter
      If einbyte < 0 Then einbyte = 0
      If einbyte > 31 Then einbyte = 31
      PixelRGB.r = einbyte
      einbyte = PixelRGB.g
      If Mode16 = Mode565 Then
        If einbyte > 0 Then einbyte = einbyte - (counter * 2)
      Else
        If einbyte > 0 Then einbyte = einbyte - counter
      End If
      If einbyte < 0 Then einbyte = 0
      If einbyte > GruenMax Then einbyte = GruenMax
      PixelRGB.g = einbyte
      einbyte = PixelRGB.b
      If einbyte > 0 Then einbyte = einbyte - counter
      If einbyte < 0 Then einbyte = 0
      If einbyte > 31 Then einbyte = 31
      PixelRGB.b = einbyte
      bmpBild2.SetLockedPixel x, y, Get16BitColor(PixelRGB)
    Next x
  Next y

  bmpBild1.Unlock destrect
  bmpBild2.Unlock destrect

  Exit Sub
ErrEnd:
  running = False
End Sub