|
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
|
|