|
|
Option Explicit 'DirectX likes all it's variables to be predefined
Dim binit As Boolean
Dim dx As New DirectX7 'This is the root object. DirectDraw is created From this
Dim dd As DirectDraw7 'This is DirectDraw, all things DirectDraw come From here
Dim Mainsurf As DirectDrawSurface7 'This holds our bitmap
Dim primary As DirectDrawSurface7 'This surface represents the screen
Dim backbuffer As DirectDrawSurface7 'this describes the primary surface
Dim ddsd1 As DDSURFACEDESC2 'this describes the primary surface
Dim ddsd2 As DDSURFACEDESC2 'this describes the bitmap that we load
Dim ddsd3 As DDSURFACEDESC2 'this describes the size of the screen
Dim brunning As Boolean 'this is another flag that states whether or not
'the main game loop is running.
Dim CurModeActiveStatus As Boolean 'This checks that we still have the
'correct display mode
Dim bRestore As Boolean 'If we don't have the correct display mode then
'this flag states that we need to restore the display mode
Dim FontX As New StdFont
'Gamma Correction Stuff
Dim GammaControler As DirectDrawGammaControl
Dim GammaRamp As DDGAMMARAMP
Dim OriginalRamp As DDGAMMARAMP
Dim GammaSupport As Boolean
Dim CurrRed As Integer, CurrGreen As Integer, CurrBlue As Integer
'Frame rate stuff
Dim FramesDone As Integer
Dim LasttimeCount As Long
Dim OutputText As String
Sub CheckForGammaSupport()
Dim Hard As DDCAPS, Soft As DDCAPS
Dim lVal As Long
dd.GetCaps Hard, Soft
If (Hard.lCaps2 And DDCAPS2_PRIMARYGAMMA) = 0 Then
GammaSupport = False
Else
GammaSupport = True
End If
End Sub
Sub CreateGamma()
If GammaSupport = False Then Exit Sub
If GammaSupport = True Then
Set GammaControler = primary.GetDirectDrawGammaControl
GammaControler.GetGammaRamp DDSGR_DEFAULT, OriginalRamp
End If
End Sub
Sub Init()
'On Local Error GoTo errOut 'If there is an error we end the program.
Set dd = dx.DirectDrawCreate("") 'the ("") means that we want the default driver
Me.Show 'maximises the form and makes sure it's visible
Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
'You get different effects at different colour depths; in general they
'will look brilliant in 24/32bit and poor at 16bit - And terrible at 8bit
Call dd.SetDisplayMode(640, 480, 24, 0, DDSDM_DEFAULT)
'get the screen surface and create a back buffer too
ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
ddsd1.lBackBufferCount = 1
Set primary = dd.CreateSurface(ddsd1)
'Get the backbuffer
Dim caps As DDSCAPS2
caps.lCaps = DDSCAPS_BACKBUFFER
Set backbuffer = primary.GetAttachedSurface(caps)
backbuffer.GetSurfaceDesc ddsd3
' init the surfaces
InitSurfaces
CheckForGammaSupport
If GammaSupport = True Then
CreateGamma
End If
FontX.Size = 12
FontX.Name = "Verdana"
backbuffer.SetFont FontX
backbuffer.SetForeColor RGB(255, 255, 255)
backbuffer.SetFontTransparency True
'This is the main loop. It only runs whilst brunning=true
binit = True
brunning = True
OutputText = "Frame Rate: Still Checking"
Do While brunning
blt
If GammaSupport = True Then
UpdateGamma CurrRed, CurrGreen, CurrBlue
End If
DoEvents
Loop
ErrOut: 'If there is an error we want to close the program down straight away.
If Err.Number = 429 Then
EndIt True
Else
EndIt False
End If
End Sub
Sub InitSurfaces()
Set Mainsurf = Nothing
ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH 'default flags
ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsd2.lWidth = ddsd3.lWidth
ddsd2.lHeight = ddsd3.lHeight
Set Mainsurf = dd.CreateSurfaceFromFile(App.Path & "\BackDrop.bmp", ddsd2)
End Sub
Sub blt()
If binit = False Then Exit Sub 'If we haven't initiaised then don't try anything
'DirectDraw related.
Dim ddrval As Long
Dim rBack As RECT
bRestore = False
Do Until ExModeActive
DoEvents
bRestore = True
Loop
' if we lost and got back the surfaces, then restore them
DoEvents
If bRestore Then
bRestore = False
dd.RestoreAllSurfaces
InitSurfaces
End If
rBack.Bottom = ddsd3.lHeight
rBack.Right = ddsd3.lWidth
ddrval = backbuffer.BltFast(0, 0, Mainsurf, rBack, DDBLTFAST_WAIT)
backbuffer.SetForeColor RGB(0, 0, 0)
Call backbuffer.DrawText(10, 10, "Insert/Delete = Alter red channel (Red = " & CStr(CurrRed) & ")", False)
Call backbuffer.DrawText(10, 25, "Home/End = Alter green channel (Green = " & CStr(CurrGreen) & ")", False)
Call backbuffer.DrawText(10, 40, " ageUp/PageDown = Alter blue channel (Blue = " & CStr(CurrBlue) & ")", False)
If GammaSupport = False Then
backbuffer.SetForeColor RGB(255, 0, 0)
Call backbuffer.DrawText(10, 55, "Gamma Correction not possible - No Hardware", False)
Else
backbuffer.SetForeColor RGB(0, 255, 0)
Call backbuffer.DrawText(10, 55, "Gamma Correction possible", False)
End If
Call backbuffer.DrawText(10, 70, OutputText, False)
'flip the back buffer to the screen
primary.Flip Nothing, DDFLIP_WAIT
FramesDone = FramesDone + 1
If dx.TickCount >= LasttimeCount + 1000 Then
OutputText = "Frame rate: " & CStr(FramesDone) & " per second"
LasttimeCount = dx.TickCount
FramesDone = 0
End If
ErrOut:
End Sub
Sub EndIt(WasItAXErr As Boolean)
Call dd.RestoreDisplayMode
Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
End
End Sub
Sub UpdateGamma(intRed As Integer, intGreen As Integer, intBlue As Integer)
'I'm not sure who wrote this procedure; but I (Jack Hoxley) didn't.
'Full credit to whoever did...
On Error GoTo GamOut:
Dim I As Integer
If GammaSupport = True Then
'Alter the gamma ramp to the percent given by comparing to original state
'A value of zero ("0") for intRed, intGreen, or intBlue will result in the
'gamma level being set back to the original levels. Anything ABOVE zero will
'fade towards FULL colour, anything below zero will fade towards NO colour
For I = 0 To 255
If intRed < 0 Then GammaRamp.red(I) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.red(I)) * (100 - Abs(intRed)) / 100)
If intRed = 0 Then GammaRamp.red(I) = OriginalRamp.red(I)
If intRed > 0 Then GammaRamp.red(I) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.red(I))) * (100 - intRed) / 100))
If intGreen < 0 Then GammaRamp.green(I) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.green(I)) * (100 - Abs(intGreen)) / 100)
If intGreen = 0 Then GammaRamp.green(I) = OriginalRamp.green(I)
If intGreen > 0 Then GammaRamp.green(I) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.green(I))) * (100 - intGreen) / 100))
If intBlue < 0 Then GammaRamp.blue(I) = ConvToSignedValue(ConvToUnSignedValue(OriginalRamp.blue(I)) * (100 - Abs(intBlue)) / 100)
If intBlue = 0 Then GammaRamp.blue(I) = OriginalRamp.blue(I)
If intBlue > 0 Then GammaRamp.blue(I) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(OriginalRamp.blue(I))) * (100 - intBlue) / 100))
Next
GammaControler.SetGammaRamp DDSGR_DEFAULT, GammaRamp
End If
Exit Sub
GamOut:
End Sub
Private Function ConvToSignedValue(lngValue As Long) As Integer
'This was written by the same person who did the "updateGamma" code
If lngValue <= 32767 Then
ConvToSignedValue = CInt(lngValue)
Exit Function
End If
ConvToSignedValue = CInt(lngValue - 65535)
End Function
Private Function ConvToUnSignedValue(intValue As Integer) As Long
'This was written by the same person who did the "updateGamma" code
If intValue >= 0 Then
ConvToUnSignedValue = intValue
Exit Function
End If
ConvToUnSignedValue = intValue + 65535
End Function
Private Sub Form_Click()
'Clicking the form will result in the program closing down.
'because the form is maximised (and therefore covers the whole screen)
'where you click is not important.
If Err.Number = 429 Then
EndIt True
Else
EndIt False
End If
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
'RED
Case vbKeyInsert
CurrRed = CurrRed + 1
If CurrRed >= 99 Then CurrRed = 99
Case vbKeyDelete
CurrRed = CurrRed - 1
If CurrRed <= -99 Then CurrRed = -99
'GREEN
Case vbKeyHome
CurrGreen = CurrGreen + 1
If CurrGreen >= 99 Then CurrGreen = 99
Case vbKeyEnd
CurrGreen = CurrGreen - 1
If CurrGreen <= -99 Then CurrGreen = -99
'BLUE
Case vbKeyPageUp
CurrBlue = CurrBlue + 1
If CurrBlue >= 99 Then CurrBlue = 99
Case vbKeyPageDown
CurrBlue = CurrBlue - 1
If CurrBlue <= -99 Then CurrBlue = -99
End Select
End Sub
Private Sub Form_Load()
'Starts the whole program.
Init
End Sub
Private Sub Form_Paint()
'If windows sends a "paint" message translate this into a call
'to DirectDraw.
blt
End Sub
Function ExModeActive() As Boolean
'This is used to test if we're in the correct resolution.
Dim TestCoopRes As Long
TestCoopRes = dd.TestCooperativeLevel
If (TestCoopRes = DD_OK) Then
ExModeActive = True
Else
ExModeActive = False
End If
End Function
转贴：///
|
|
发表于 2003-10-7 08:40:00
楼主