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 Integer
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 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 Farbe16bit As cRGB
Dim WelcherFarbanteil As Single

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

Private Sub Form_Load()
  Dim destrect As RECT

  Me.Show
  Me.Refresh

  Initialization
  GetColorMode PrimarySurface

  running = True

  Do
    With destrect
      .Bottom = 600: .Left = 0
      .Right = 800: .Top = 0
    End With
    BackBuffer.BltColorFill destrect, Get16BitColor(Farbe16bit)

    BackBuffer.SetForeColor vbRed
    BackBuffer.SetFont Me.Font
    BackBuffer.DrawText 10, 10, _
          "DirectDraw und 16bit Farben", False
    BackBuffer.DrawText 10, 30, _
          "<Esc> beendet das Programm", False
    BackBuffer.DrawText 10, 50, _
          "FPS: " & Format(FPS, "0.0"), False

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

    If Mode16 = Mode555 Then
      BackBuffer.DrawText 150, 70, "  Modus: 555", False
    Else
      BackBuffer.DrawText 150, 70, "  Modus: 565", False
    End If

    Select Case WelcherFarbanteil
      Case 0:
        BackBuffer.DrawText 10, 140, "Grün: " & Farbe16bit.g, False
        BackBuffer.DrawText 10, 160, "Blau: " & Farbe16bit.b, False
        BackBuffer.SetForeColor vbWhite
        BackBuffer.DrawText 10, 120, "Rot: " & Farbe16bit.r, False
      Case 1:
        BackBuffer.DrawText 10, 120, "Rot: " & Farbe16bit.r, False
        BackBuffer.DrawText 10, 160, "Blau: " & Farbe16bit.b, False
        BackBuffer.SetForeColor vbWhite
        BackBuffer.DrawText 10, 140, "Grün: " & Farbe16bit.g, False
      Case 2:
        BackBuffer.DrawText 10, 120, "Rot: " & Farbe16bit.r, False
        BackBuffer.DrawText 10, 140, "Grün: " & Farbe16bit.g, False
        BackBuffer.SetForeColor vbWhite
        BackBuffer.DrawText 10, 160, "Blau: " & Farbe16bit.b, False
    End Select
    BackBuffer.SetForeColor vbRed
    BackBuffer.DrawText 10, 180, "16bit-Farbwert: " & _
            Get16BitColor(Farbe16bit), 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_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyUp Then
    Select Case WelcherFarbanteil
      Case 0:
        If Farbe16bit.r < 31 Then Farbe16bit.r = Farbe16bit.r + 1
      Case 1:
        If Farbe16bit.g < GruenMax Then _
              Farbe16bit.g = Farbe16bit.g + 1
      Case 2:
        If Farbe16bit.b < 31 Then Farbe16bit.b = Farbe16bit.b + 1
    End Select
  End If

  If KeyCode = vbKeyDown Then
    Select Case WelcherFarbanteil
      Case 0:
        If Farbe16bit.r > 0 Then Farbe16bit.r = Farbe16bit.r - 1
      Case 1:
        If Farbe16bit.g > 0 Then Farbe16bit.g = Farbe16bit.g - 1
      Case 2:
        If Farbe16bit.b > 0 Then Farbe16bit.b = Farbe16bit.b - 1
    End Select
  End If

  If KeyCode = vbKeyRight Then
    WelcherFarbanteil = WelcherFarbanteil + 1
    If WelcherFarbanteil > 2 Then WelcherFarbanteil = 0
  End If

  If KeyCode = vbKeyLeft Then
    WelcherFarbanteil = WelcherFarbanteil - 1
    If WelcherFarbanteil < 0 Then WelcherFarbanteil = 2
  End If
End Sub

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

Sub Terminate()
  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