'**************************************************************
'
' THIS WORK, INCLUDING THE SOURCE CODE, DOCUMENTATION
' AND RELATED MEDIA AND DATA, IS PLACED INTO THE PUBLIC DOMAIN.
'
' THE ORIGINAL AUTHOR IS RYAN CLARK.
'
' THIS SOFTWARE IS PROVIDED AS-IS WITHOUT WARRANTY
' OF ANY KIND, NOT EVEN THE IMPLIED WARRANTY OF
' MERCHANTABILITY. THE AUTHOR OF THIS SOFTWARE,
' ASSUMES _NO_ RESPONSIBILITY FOR ANY CONSEQUENCE
' RESULTING FROM THE USE, MODIFICATION, OR
' REDISTRIBUTION OF THIS SOFTWARE.
'
'**************************************************************
'
' This file was downloaded from The Game Programming Wiki.
' Come and visit us at http://gpwiki.org
'
'**************************************************************

Const FULLSCREEN                                     As Boolean = False

'Need to slow things down a bit
Private Declare Function GetTickCount Lib "kernel32" () As Long


Dim lngTickStore      As Long
Const DelayMS = 20                              'Delay 20ms between each gamma change

Dim ddClipper         As DirectDrawClipper        'A décrire
Dim dx                As DirectX7
Dim dd                As DirectDraw7
Dim ddsdPrimary       As DDSURFACEDESC2
Dim Primary           As DirectDrawSurface7
Dim BackBuffer        As DirectDrawSurface7
Dim Sprite            As DirectDrawSurface7                'Contains the sprite (starbase) to display
Dim GammaControler    As DirectDrawGammaControl    'The object that gets/sets gamma ramps
Dim ddgGammaVoulu     As DDGAMMARAMP                    'The gamma ramp we'll use to alter the screen state
Dim ddgGammaOriginal  As DDGAMMARAMP                 'The gamma ramp we'll use to store the original screen state
Dim lngRouge          As Integer                        'Store the currend red value w.r.t. original
Dim lngVert           As Integer                      'Store the currend green value w.r.t. original
Dim lngBleu           As Integer                       'Store the currend blue value w.r.t. original

Private Sub Form_Load()

Dim srcRect               As RECT
Dim destRect              As RECT
Dim hwCaps                As DDCAPS
Dim helCaps               As DDCAPS

    Set dx = New DirectX7
    Set dd = dx.DirectDrawCreate("")
   
    'Check for Gamma Ramp Support
    dd.GetCaps hwCaps, helCaps
    If (hwCaps.lCaps2 And DDCAPS2_PRIMARYGAMMA) = 0 Then
        MsgBox "Your system does not have Gamma Ramp Support", vbOKOnly, "No Gamma Support"
        End
    End If
   
    'Set up our rectangles
    With srcRect
        .Bottom = 75
        .Left = 0
        .Right = 100
        .Top = 0
    End With
'    With destRect
'        .Bottom = 480
'        .Left = 0
'        .Right = 640
'        .Top = 0
'    End With

    'Set the cooperative level and displaymode...
    If FULLSCREEN Then
        Call dd.SetCooperativeLevel(frmGamma.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE Or DDSCL_ALLOWREBOOT)
        Call dd.SetDisplayMode(640, 480, 16, 0, DDSDM_DEFAULT)
   
        'Create the primary complex surface with one backbuffer
        ddsdPrimary.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
        ddsdPrimary.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
        ddsdPrimary.lBackBufferCount = 1
        Set Primary = dd.CreateSurface(ddsdPrimary)
   
        'Get the backbuffer from the primary surface
        Dim caps As DDSCAPS2
        caps.lCaps = DDSCAPS_BACKBUFFER
        Set BackBuffer = Primary.GetAttachedSurface(caps)
        BackBuffer.SetFontTransparency True
        BackBuffer.SetForeColor vbWhite     'Make white text
   
    Else

        With frmGamma
          .Width = 640 * Screen.TwipsPerPixelX
          .Height = 480 * Screen.TwipsPerPixelY
          .AutoRedraw = False
          .ClipControls = False
          .KeyPreview = True
          .ScaleMode = 3
        End With
         
        frmGamma.Show
       
        dd.SetCooperativeLevel frmGamma.hWnd, DDSCL_NORMAL Or DDSCL_ALLOWREBOOT
   
        'Create the primary complex surface with one backbuffer
        ddsdPrimary.lFlags = DDSD_CAPS
        ddsdPrimary.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_VIDEOMEMORY
        ddsdPrimary.lWidth = 640: ddsdPrimary.lHeight = 480
        Set Primary = dd.CreateSurface(ddsdPrimary)
           
        Set ddClipper = dd.CreateClipper(0)
        ddClipper.SetHWnd frmGamma.hWnd
        Primary.SetClipper ddClipper
   
        ddsdPrimary.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        ddsdPrimary.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        ddsdPrimary.lWidth = 100
        ddsdPrimary.lHeight = 75
        Set BackBuffer = dd.CreateSurface(ddsdPrimary)
        'BackBuffer.SetFontTransparency True
        BackBuffer.SetForeColor vbWhite
         
        'On définit le rectangle de l'écran
        dx.GetWindowRect frmGamma.hWnd, destRect
   
    End If


    'Load the sprite surface
    LoadSprite

    'Make a new gamma controler
    Set GammaControler = Primary.GetDirectDrawGammaControl

    'Fill out the original gamma ramps
    GammaControler.GetGammaRamp DDSGR_DEFAULT, ddgGammaOriginal
   
    'Set our initial colour values to zero
    lngRouge = 0
    lngVert = 0
    lngBleu = 0
   
    'Render the scene - NOTE: We're only doing this once!
    'Changing the screen gamma takes IMMEDIATE EFFECT,
    'no need to blit or flip!
    BackBuffer.BltColorFill DIRX_ObtenirRECT(0, 0, 0, 0), 0                         'Fill with black
   
    BackBuffer.BltFast 0, 0, Sprite, srcRect, DDBLTFAST_WAIT    'Show the sprite
   
    'Display some info text
    BackBuffer.DrawText 640 * 0.4, 480 - (480 * 0.05), "Press 'R' to decrease red by 5%", False
'    BackBuffer.DrawText 0, 315, "Press 'SHIFT-R' to increase red by 5%", False
'    BackBuffer.DrawText 0, 330, "Press 'G' to decrease green by 5%", False
'    BackBuffer.DrawText 0, 345, "Press 'SHIFT-G' to increase green by 5%", False
'    BackBuffer.DrawText 0, 360, "Press 'B' to decrease blue by 5%", False
'    BackBuffer.DrawText 0, 375, "Press 'SHIFT-B' to increase blue by 5%", False
'    BackBuffer.DrawText 0, 390, "Press 'F' to fade from white to original", False
'    BackBuffer.DrawText 0, 405, "Press 'SHIFT-F' to fade from black to original", False
'    BackBuffer.DrawText 0, 420, "Press 'o' to restore original gamma values", False
'    BackBuffer.DrawText 0, 435, "Press 'x' to exit", False
   
    If FULLSCREEN Then
      Primary.Flip Nothing, DDFLIP_WAIT                           'Display the scene
    Else
      Primary.Blt destRect, BackBuffer, DIRX_ObtenirRECT(0, 0, 0, 0), DDBLT_WAIT
    End If

End Sub

Public Function DIRX_ObtenirRECT(lngLeft As Long, lngTop As Long, lngRight As Long, lngBottom As Long) As RECT
  With DIRX_ObtenirRECT
    .Left = lngLeft
    .Right = lngRight
    .Top = lngTop
    .Bottom = lngBottom
  End With
End Function

Public Sub LoadSprite()

Dim CKey As DDCOLORKEY
Dim ddsdNewSprite As DDSURFACEDESC2
   
  'load the sprite onto the surface
  Set Sprite = Nothing
     
  If bolPleinEcran Then
   
    ddsdNewSprite.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
    ddsdNewSprite.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    ddsdNewSprite.lWidth = 400
    ddsdNewSprite.lHeight = 300
    Set Sprite = dd.CreateSurfaceFromFile(App.Path & "\9hanta.bmp", ddsdNewSprite)
 
  Else
   
    ddsdNewSprite.lWidth = 100
    ddsdNewSprite.lHeight = 75
    Set Sprite = dd.CreateSurfaceFromFile(App.Path & "\9hanta.bmp", ddsdNewSprite)
 
  End If
 
End Sub

Public Function ConvToSignedValue(lngValue As Long) As Integer

    'Cheezy method for converting to signed integer
    If lngValue <= 32767 Then
        ConvToSignedValue = CInt(lngValue)
        Exit Function
    End If
   
    ConvToSignedValue = CInt(lngValue - 65535)

End Function

Public Function ConvToUnSignedValue(intValue As Integer) As Long

    'Cheezy method for converting to unsigned integer
    If intValue >= 0 Then
        ConvToUnSignedValue = intValue
        Exit Function
    End If
   
    ConvToUnSignedValue = intValue + 65535

End Function

Public Sub SetGamma(intRed As Integer, intGreen As Integer, intBlue As Integer)

Dim i As Integer

    '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 ddgGammaVoulu.red(i) = ConvToSignedValue(ConvToUnSignedValue(ddgGammaOriginal.red(i)) * (100 - Abs(intRed)) / 100)
        If intRed = 0 Then ddgGammaVoulu.red(i) = ddgGammaOriginal.red(i)
        If intRed > 0 Then ddgGammaVoulu.red(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(ddgGammaOriginal.red(i))) * (100 - intRed) / 100))
        If intGreen < 0 Then ddgGammaVoulu.green(i) = ConvToSignedValue(ConvToUnSignedValue(ddgGammaOriginal.green(i)) * (100 - Abs(intGreen)) / 100)
        If intGreen = 0 Then ddgGammaVoulu.green(i) = ddgGammaOriginal.green(i)
        If intGreen > 0 Then ddgGammaVoulu.green(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(ddgGammaOriginal.green(i))) * (100 - intGreen) / 100))
        If intBlue < 0 Then ddgGammaVoulu.blue(i) = ConvToSignedValue(ConvToUnSignedValue(ddgGammaOriginal.blue(i)) * (100 - Abs(intBlue)) / 100)
        If intBlue = 0 Then ddgGammaVoulu.blue(i) = ddgGammaOriginal.blue(i)
        If intBlue > 0 Then ddgGammaVoulu.blue(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(ddgGammaOriginal.blue(i))) * (100 - intBlue) / 100))
    Next
    GammaControler.SetGammaRamp DDSGR_DEFAULT, ddgGammaVoulu

End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)

Dim i As Integer

    'Alter the gamma ramps by percent
    Select Case Chr(KeyAscii)
        Case "r"
            If lngRouge > -95 Then lngRouge = lngRouge - 5
            SetGamma lngRouge, lngVert, lngBleu
        Case "R"
            If lngRouge < 95 Then lngRouge = lngRouge + 5
            SetGamma lngRouge, lngVert, lngBleu
        Case "g"
            If lngVert > -95 Then lngVert = lngVert - 5
            SetGamma lngRouge, lngVert, lngBleu
        Case "G"
            If lngVert < 95 Then lngVert = lngVert + 5
            SetGamma lngRouge, lngVert, lngBleu
        Case "b"
            If lngBleu > -95 Then lngBleu = lngBleu - 5
            SetGamma lngRouge, lngVert, lngBleu
        Case "B"
            If lngBleu < 95 Then lngBleu = lngBleu + 5
            SetGamma lngRouge, lngVert, lngBleu
        Case "o"
            lngRouge = 0
            lngVert = 0
            lngBleu = 0
            SetGamma lngRouge, lngVert, lngBleu
        Case "x"    'Exit on "x"
            End
    End Select
   
    'If "f" is pressed, do a smooth fade white to normal
    If Chr(KeyAscii) = "f" Then
        For i = 99 To 0 Step -1
            SlowDown
            lngRouge = i
            lngVert = i
            lngBleu = i
            SetGamma lngRouge, lngVert, lngBleu
        Next
    End If
   
    'If "F" is pressed, do a smooth fade from black to normal
    If Chr(KeyAscii) = "F" Then
        For i = -99 To 0 Step 1
            SlowDown
            lngRouge = i
            lngVert = i
            lngBleu = i
            SetGamma lngRouge, lngVert, lngBleu
        Next
    End If
       
End Sub

Private Sub SlowDown()

    'Delay the effect somewhat
    lngTickStore = GetTickCount()
    Do While lngTickStore + DelayMS > GetTickCount()
    Loop

End Sub