Option Explicit

Dim binit As Boolean


'These values should be easy now
'if not, go see the Fullscreen tutorial
Dim dx As New DirectX7
Dim dd As DirectDraw7
Dim Mainsurf As DirectDrawSurface7
Dim primary As DirectDrawSurface7
Dim backbuffer As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd2 As DDSURFACEDESC2
Dim ddsd3 As DDSURFACEDESC2
Dim brunning As Boolean
Dim CurModeActiveStatus As Boolean
Dim bRestore As Boolean


'Palette Variables
'An 8bit palette has 256 entries, making an
'array of 255 (0 is the first element) allows us
'to represent the entire palette.
Dim Pal(255) As PALETTEENTRY
'This is the palette object, it is created by Directdraw based
'on the entries in the above array.
Dim DDPalette As DirectDrawPalette
'These are the offset variables - explained in the init procedure
Dim Ro As Integer, Go As Integer, Bo As Integer


Sub Init()
On Local Error GoTo errOut:

'This creates a directdraw object
Set dd = dx.DirectDrawCreate("")
'This must be called before the next two lines.
'Otherwise (for some reason) the form does not maximise itself.
'This becomes a problem when the user clicks the mouse, if the mouse
'isn't over the form then it will attempt to bring whatever window
'is behind it to the front - which conflicts with DD, it won't crash, but
'you'll get some weird arftifacts appearing - parts of windows will appear
'on the screen in 8-bit palettised form. Only if the form is maximised can
'we be garaunteed to catch every mouse event.
Me.Show

'You should know these two lines by now.....
Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE) Call dd.SetDisplayMode(640, 480, 8, 0, DDSDM_DEFAULT)


'Create the primarybuffer. Note the special flag DDPF_PALETTEINDEXED8
'This is so that we can apply an 8-bit palette to this surface. the same
'flag is used when creating the bitmap surface. If you use 1,2 or 4 bit
'palettes change this flag to be DDPF_PALETTEINDEXED*1*2*4 (whichever
'fits).
ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
ddsd1.ddpfPixelFormat.lFlags = DDPF_PALETTEINDEXED8
ddsd1.lBackBufferCount = 1
Set primary = dd.CreateSurface(ddsd1)
'The palette is not applied to the primary surface just yet. This is because
'it has not yet been created - see notes below.

Dim caps As DDSCAPS2
caps.lCaps = DDSCAPS_BACKBUFFER
Set backbuffer = primary.GetAttachedSurface(caps)
backbuffer.GetSurfaceDesc ddsd3

'We must set up the palettes before the surfaces. This is because
'of the way i wrote the program - not a directdraw convention
'In the initsurfaces procedure it applies the palette to the surface
'if the palette hasn't been created yet it will give an error, so we
'must create the palettes first. SetupPalette
'The only rules you must adhere to when using palettes and applying
'them to surfaces are:
'1. Surfaces must be created before palettes can be applied to them
'2. Palettes must be created before they can be attached to a surface

'Create the single surface
InitSurfaces

'Set the default values.
'These values just shift an entry towards one end
'of the spectrum. They are an Offset.
'If the offset is 0 then it generates a normal black-white
'greyscale palette, if the offset changes it will enhance the
'amount of colour in that channel. ie. if Ro is positive it will tint the palette
'red. If one colour goes negative it is the same as enhancing the other
'channels, ie. if Ro=-10 and Go=0; Bo=0 it is the same colour as
'Ro=0, Go=10,Bo=10
'The easiest way to understand this effect is to play with the program
'use the controls to enhance different colours and see what the different
'results are.
Ro = 0: Go = 0: Bo = 0

binit = True
brunning = True
Do While brunning
'This is a simple logic tree, it stops the values
'from going out of range. There is more checking in the
'ModifyPalette procedure. The values must be allowed
'to go all the way to -255, otherwise we can't
'achieve true black.
If Ro >= 255 Then Ro = -255
If Go >= 255 Then Go = -255
If Bo >= 255 Then Bo = -255

If Ro <= -255 Then Ro = 255
If Go <= -255 Then Go = 255
If Bo <= -255 Then Bo = 255
'This is actually a call to modify the palette.
'you could manually set the palette offsets by
'replacing Ro,Go and Bo.....
ModifyPalette Ro, Go, Bo
blt
DoEvents
Loop

errOut:
EndIt
End Sub


Sub InitSurfaces()
Set Mainsurf = Nothing 'clear any existing data

'load the bitmap into a surface - backdrop.bmp
ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
ddsd2.ddpfPixelFormat.lFlags = DDPF_PALETTEINDEXED8
ddsd2.lWidth = 640
ddsd2.lHeight = 480

'To demonstrate the effects there are 3 different pictures: 0,1 and 2
'This just chooses a random picture. tip: 1 and 2 look good. :-)
Randomize
Set Mainsurf = dd.CreateSurfaceFromFile(App.Path & "\backdrop" & Int(Rnd * 2) & ".bmp", ddsd2)

'Apply the palette to the surface. You can only do this AFTER the
'surface has been created - if you try to do this before then it will generate
'an error
Mainsurf.SetPalette DDPalette
'DDPalette is the single, standard palette
'that we are going to use.
'Note, the palette used for the Mainsurf is always going to be a greyscale
'bitmap - only the palette for the primary buffer gets changed/tinted.
End Sub


Sub blt()
On Local Error GoTo errOut
If binit = False Then Exit Sub 'Skip this code if we haven't finished
'initialising directdraw. This should never be the case though, the code
'is designed to only start blitting after the initialisation process. If this line
'stops the code then it is because there was an error setting up directdraw

'DirectDrawReturnVALue
Dim ddrval As Long

Dim rBack As RECT


' this will keep us from trying to blt in case we lose the surfaces (alt-tab)
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

'Define the area we want to blit to as the whole screen
rBack.Bottom = ddsd3.lHeight
rBack.Right = ddsd3.lWidth

'A very simple call. Note: Palettes are not mentioned here. DDraw
'automatically implements the use of them and modifies the
'colours - you don't need to do this.
ddrval = backbuffer.BltFast(0, 0, Mainsurf, rBack, DDBLTFAST_WAIT)

'flip the back buffer to the screen
primary.Flip Nothing, DDFLIP_WAIT
errOut:
End Sub


Sub EndIt()
'This shuts DD down, very quick, very simple.
Call dd.RestoreDisplayMode
Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
End End


Sub Private Sub Form_Click()
'Can also press [escape] to end the program
EndIt
End Sub


Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'This part is fairly simple, depending on which button is pressed
'it modifies that colour
'I used Form_Keydown because it allows you to hold down the button
'Form_KeyUp requires you to keep tapping the button
Select Case KeyCode
Case vbKeyPageUp
Bo = Bo + 1
Case vbKeyPageDown
Bo = Bo - 1
Case vbKeyEnd
Go = Go - 1
Case vbKeyHome
Go = Go + 1
Case vbKeyInsert
Ro = Ro + 1
Case vbKeyDelete
Ro = Ro - 1
Case vbKeyUp
Ro = Ro + 1: Go = Go + 1: Bo = Bo + 1
Case vbKeyDown
Ro = Ro - 1: Go = Go - 1: Bo = Bo - 1
Case vbKeyReturn
Ro = 0: Go = 0: Bo = 0
Case vbKeyEscape
'This is the only different one - just ends the program
EndIt
End Select
End Sub


Private Sub Form_Load()
Dim msg As String
'This just lists the controls for you.
msg = "Controls:" & vbCr
msg = msg & "INSERT = Increase amount of red" & vbCr
msg = msg & "DELETE = Decrease amount of red" & vbCr
msg = msg & " " & vbCr
msg = msg & "HOME = Increase amount of green" & vbCr
msg = msg & "END = Decrease amount of green" & vbCr
msg = msg & " " & vbCr
msg = msg & "PAGE UP = Increase amount of blue" & vbCr
msg = msg & "PAGE DOWN = Decrease the amount of blue" & vbCr
msg = msg & " " & vbCr
msg = msg & "UP ARROW = Increase all colours" & vbCr
msg = msg & "DOWN ARROW = Decrease all colours" & vbCr
msg = msg & " " & vbCr
msg = msg & "ENTER = Reset all values" & vbCr
msg = msg & "ESCAPE / Left Mouse Button = Exit Program" & vbCr
msg = msg & " " & vbCr
'A little bit of advertising ;-)
msg = msg & "If you like this example, visit me at:" & vbCr
msg = msg & "http://www.dx4vb.da.ru" & vbCr
MsgBox msg, vbInformation, "Info"
Init
End Sub


Private Sub Form_Paint()
'if windows tells VB that you need to redraw
'the window then translate it into a
'directdraw call.....
blt
End Sub


Function ExModeActive() As Boolean
'This checks that we're in the correct mode
Dim TestCoopRes As Long
TestCoopRes = dd.TestCooperativeLevel
If (TestCoopRes = DD_OK) Then
ExModeActive = True
Else
ExModeActive = False
End If
End Function


Sub SetupPalette()
'This goes through each entry in the pal() array and creates a default colour
'If you skipped this part and just created a palette it would be completely
'black - as by default all the entries in the array will be 0
Dim I As Integer
For I = 0 To 255
Pal(I).red = I
Pal(I).green = I
Pal(I).blue = I
Next I

'The is where you actually create the palette. The flags specify it as
'being an 8bit palette; the ALLOW256 flag is important. Without it, directdraw
'reserves entries 0 and 255 in the palette for itself - effectively allowing you
'only 254 colours. if we use this flag it allows us to use the first & last entries.
Set DDPalette = dd.CreatePalette(DDPCAPS_8BIT Or DDPCAPS_ALLOW256, Pal())
'Apply the palette to the surface - this represents the screen.
primary.SetPalette DDPalette
'If you have slightly different palettes on the primary surface and the bitmpa
'surface, when you copy the bitmap to the primary surface it will translate it
'into the primary surface's palette.
End Sub


Sub ModifyPalette(redOffset As Integer, greenOffset As Integer, blueOffset As Integer)
'This modifies the palette depending on the offset.
'This is almost identical to creating the original palette
'the offsets add (or subtract) an amount from the overall value.

Dim Temp As Integer
Dim T As Integer

For T = 0 To 255
Temp = T + redOffset
'We must check that the value is within the correct range
'before setting the value. If the value is out of bounds
'we correct it.
If Temp >= 255 Then Temp = 255
If Temp <= 0 Then Temp = 0
Pal(T).red = Temp Temp =

T + greenOffset If Temp >= 255 Then Temp = 255
If Temp <= 0 Then Temp = 0
Pal(T).green = Temp

Temp = T + blueOffset
If Temp >= 255 Then Temp = 255
If Temp <= 0 Then Temp = 0
Pal(T).blue = Temp

Next T
'This creates the palette again.
Set DDPalette = dd.CreatePalette(DDPCAPS_8BIT Or DDPCAPS_ALLOW256, Pal())
'and applies it to the screen.
primary.SetPalette DDPalette
End Sub