Tipp 0124 24-bit-Farben zu 16-bit konvertieren
Autor/Einsender:
Datum:
  Alexander Csadek
21.09.2001
Entwicklungsumgebung:
DirectX-Version:
  VB 6
DirectX 7
Es gibt immer wieder die Situation, dass man eine RGB-Farbe aus einem Grafikprogramm (z.B. Paint) hat, und diese in seinem Spiel einsetzen möchte, oder der Anwender soll eine RGB-Farbe direkt eingeben können. Wie auch immer, wenn das Spiel den 16bit Modus verwendet, muss diese Farbe zu 16bit konvertiert werden.
Eine ausführlichere Beschreibung zu diesem Tipp gibt es in der DirectX-Rubrik unter DirectDraw und 16bit-Farben.
Code im Codebereich der Form frmMain
 
Option Explicit

Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim Farbe24bit As cRGB
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, To16bit(Farbe24bit)

    BackBuffer.SetForeColor vbRed
    BackBuffer.SetFont Me.Font
    BackBuffer.DrawText 10, 10, "DirectDraw und 24-bit zu " & _
          "16-bit Farben konvertieren", 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: " & Farbe24bit.g, False
        BackBuffer.DrawText 10, 160, "Blau: " & Farbe24bit.b, False
        BackBuffer.SetForeColor vbWhite
        BackBuffer.DrawText 10, 120, "Rot: " & Farbe24bit.r, False
      Case 1:
        BackBuffer.DrawText 10, 120, "Rot: " & Farbe24bit.r, False
        BackBuffer.DrawText 10, 160, "Blau: " & Farbe24bit.b, False
        BackBuffer.SetForeColor vbWhite
        BackBuffer.DrawText 10, 140, "Grün: " & Farbe24bit.g, False
      Case 2:
        BackBuffer.DrawText 10, 120, "Rot: " & Farbe24bit.r, False
        BackBuffer.DrawText 10, 140, "Grün: " & Farbe24bit.g, False
        BackBuffer.SetForeColor vbWhite
        BackBuffer.DrawText 10, 160, "Blau: " & Farbe24bit.b, False
    End Select
    BackBuffer.SetForeColor vbRed
    BackBuffer.DrawText 10, 180, "24bit-Farbwert: " & _
            RGB(Farbe24bit.r, Farbe24bit.g, Farbe24bit.b), False

    Farbe16bit = GetRGB16(To16bit(Farbe24bit))
    BackBuffer.DrawText 10, 200, "16bit-Farbe: Rot " & _
            Farbe16bit.r & " Grün " & Farbe16bit.g & _
            " Blau " & Farbe16bit.b, False
    BackBuffer.DrawText 10, 220, "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

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

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyUp Then
    Select Case WelcherFarbanteil
      Case 0:
        If Farbe24bit.r < 255 Then Farbe24bit.r = Farbe24bit.r + 1
      Case 1:
        If Farbe24bit.g < 255 Then Farbe24bit.g = Farbe24bit.g + 1
      Case 2:
        If Farbe24bit.b < 255 Then Farbe24bit.b = Farbe24bit.b + 1
    End Select
  End If

  If KeyCode = vbKeyDown Then
    Select Case WelcherFarbanteil
      Case 0:
        If Farbe24bit.r > 0 Then Farbe24bit.r = Farbe24bit.r - 1
      Case 1:
        If Farbe24bit.g > 0 Then Farbe24bit.g = Farbe24bit.g - 1
      Case 2:
        If Farbe24bit.b > 0 Then Farbe24bit.b = Farbe24bit.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 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
 
Code im Codebereich des Moduls
 
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 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
      Else
        Mode16 = Mode555
      End If
    End If
    GBitMask = .lGBitMask
    RBitMask = .lRBitMask
    BBitMask = .lBBitMask
  End With
End Sub

Function To16bit(Color As cRGB) As Long
  Dim bsG As Single
  Dim bsR As Single
  Dim bsB As Single
  Dim cr As cRGB

  cr = Color
  cr.r = cr.r \ &H8

  If Mode16 = Mode555 Then
    cr.g = cr.g \ &H8
  Else
    cr.g = cr.g \ &H4
  End If

  cr.b = cr.b \ &H8
  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

  To16bit = cr.r * bsR Or cr.g * bsG Or cr.b * bsB
End Function

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

Public Function GetRGB24(Color As Long) As cRGB
  Dim bsG As Single
  Dim bsR As Single
  Dim bsB As Single
  Dim Rmask As Long
  Dim Gmask As Long
  Dim Bmask As Long

  bsR = 1
  bsG = &H100
  bsB = &H10000

  Rmask = &HFF
  Gmask = 65280
  Bmask = &HFF0000

  With GetRGB24
    .r = (Color And Rmask) / bsR
    .g = (Color And Gmask) / bsG
    .b = (Color And Bmask) / bsB
  End With
End Function
 
Weitere Links zum Thema
16-bit Farben
Hinweis
Um dieses Beispiel ausführen zu können, wird die DirectX 7 for Visual Basic Type Library benötigt (siehe dazu die Erläuterungen in der DirectX-Rubrik).

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (5,6 kB) Downloads bisher: [ 1201 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Dienstag, 4. Oktober 2011