VB5 Colour Depth Sample (128K)
VB6 Colour Depth Sample (123K)
13 Jan 2003
Added VB6 Version
Tidied up the demonstration code classes to make them easier to reuse.
Previously the optimal palette method was checking 3 times too many pixels in the x direction. Now corrected; the performance is consequently a little better...
Optimised Colour Reduction Using Octrees
Floyd-Stucci Colour Reduction Methods and Gray Scaling
vbAccelerator - Contents of code file: frmClrDepth.frm
VERSION 5.00
Begin VB.Form frmColourDepth
Caption = "vbAccelerator Colour Depth Control Sample"
ClientHeight = 4905
ClientLeft = 3555
ClientTop = 3015
ClientWidth = 6885
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmClrDepth.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4905
ScaleWidth = 6885
Begin VB.CommandButton cmdReset
Caption = "&Reset"
Height = 375
Left = 5460
TabIndex = 18
Top = 3720
Width = 1335
End
Begin VB.CommandButton cmdConvert
Caption = "&Convert"
Height = 375
Left = 4080
TabIndex = 17
Top = 3720
Width = 1335
End
Begin VB.CommandButton cmdLoad
Caption = "&Load..."
Height = 375
Left = 4080
TabIndex = 16
Top = 120
Width = 1335
End
Begin VB.CommandButton cmdSave
Caption = "&Save..."
Height = 375
Left = 4080
TabIndex = 15
Top = 4320
Width = 1335
End
Begin VB.PictureBox picColourReductionOptions
BorderStyle = 0 'None
Height = 1455
Left = 4080
ScaleHeight = 1455
ScaleWidth = 3315
TabIndex = 6
Top = 2160
Width = 3315
Begin VB.PictureBox picFloydStucciOptions
BorderStyle = 0 'None
Height = 495
Left = 240
ScaleHeight = 495
ScaleWidth = 2715
TabIndex = 10
Top = 600
Width = 2715
Begin VB.OptionButton optFloydStucciType
Appearance = 0 'Flat
Caption = "&Web Safe"
ForeColor = &H80000008&
Height = 255
Index = 1
Left = 60
TabIndex = 12
Top = 240
Width = 2355
End
Begin VB.OptionButton optFloydStucciType
Appearance = 0 'Flat
Caption = "&Halftone"
ForeColor = &H80000008&
Height = 255
Index = 0
Left = 60
TabIndex = 11
Top = 0
Width = 2355
End
End
Begin VB.OptionButton optReduceMethod
Appearance = 0 'Flat
Caption = "&Optimal Palette"
ForeColor = &H80000008&
Height = 255
Index = 2
Left = 0
TabIndex = 9
Top = 1080
Width = 2835
End
Begin VB.OptionButton optReduceMethod
Appearance = 0 'Flat
Caption = "&Default"
ForeColor = &H80000008&
Height = 195
Index = 0
Left = 0
TabIndex = 8
Top = 120
Value = -1 'True
Width = 2835
End
Begin VB.OptionButton optReduceMethod
Appearance = 0 'Flat
Caption = "&Floyd-Stucci"
ForeColor = &H80000008&
Height = 255
Index = 1
Left = 0
TabIndex = 7
Top = 360
Width = 2835
End
End
Begin VB.PictureBox picColourDepthOptions
BorderStyle = 0 'None
Height = 1095
Left = 4080
ScaleHeight = 1095
ScaleWidth = 3615
TabIndex = 1
Top = 780
Width = 3615
Begin VB.OptionButton optColourDepth
Appearance = 0 'Flat
Caption = "&True Colour"
ForeColor = &H80000008&
Height = 315
Index = 3
Left = 0
TabIndex = 5
Top = 720
Value = -1 'True
Width = 2835
End
Begin VB.OptionButton optColourDepth
Appearance = 0 'Flat
Caption = "&256 Colour"
ForeColor = &H80000008&
Height = 315
Index = 2
Left = 0
TabIndex = 4
Top = 480
Width = 2835
End
Begin VB.OptionButton optColourDepth
Appearance = 0 'Flat
Caption = "&16 Colour"
ForeColor = &H80000008&
Height = 315
Index = 1
Left = 0
TabIndex = 3
Top = 240
Width = 2835
End
Begin VB.OptionButton optColourDepth
Appearance = 0 'Flat
Caption = "&Black and White"
ForeColor = &H80000008&
Height = 315
Index = 0
Left = 0
TabIndex = 2
Top = 0
Width = 2835
End
End
Begin VB.PictureBox picCurrent
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4575
Left = 120
ScaleHeight = 4515
ScaleWidth = 3795
TabIndex = 0
Top = 120
Width = 3855
End
Begin VB.Label lblOutputDepth
Caption = "Output Colour Reduction Method:"
Height = 255
Index = 1
Left = 4080
TabIndex = 14
Top = 1980
Width = 3495
End
Begin VB.Label lblOutputDepth
Caption = "Output Colour Depth:"
Height = 255
Index = 0
Left = 4080
TabIndex = 13
Top = 540
Width = 3495
End
End
Attribute VB_Name = "frmColourDepth"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_cDIB As cDIBSection
Private m_cDIBSectionSave As cDIBSectionSave
Private m_sFilename As String
Private Property Get ColourDepth() As EDSSColourDepthConstants
Select Case True
Case optColourDepth(0).value
ColourDepth = edss2Colour
Case optColourDepth(1).value
ColourDepth = edss16Colour
Case optColourDepth(2).value
ColourDepth = edss256Colour
Case optColourDepth(3).value
ColourDepth = edssTrueColour
End Select
End Property
Private Property Get ReductionMethod() As EDSSColourReductionConstants
Select Case True
Case optReduceMethod(0).value
ReductionMethod = edssSystemDefault
Case optReduceMethod(1).value
ReductionMethod = edssUsePalette
Case optReduceMethod(2).value
ReductionMethod = edssGeneratePalette
End Select
End Property
Private Sub pLoad(ByVal sFile As String)
On Error Resume Next
Dim oPic As New StdPicture
Set oPic = LoadPicture(sFile)
If (Err.Number <> 0) Then
MsgBox "Failed to load file '" & sFile & "'" & vbCrLf & Err.Description,
vbExclamation
Else
m_cDIB.CreateFromPicture oPic
m_sFilename = sFile
If Not (optColourDepth(3).value) Then
optColourDepth(3).value = True
End If
Set m_cDIBSectionSave = New cDIBSectionSave
m_cDIBSectionSave.ColourDepth = ColourDepth
m_cDIBSectionSave.ReductionMethod = ReductionMethod
m_cDIBSectionSave.Convert m_cDIB
End If
cmdReset.Enabled = (Len(m_sFilename) > 0)
End Sub
Private Sub cmdConvert_Click()
Screen.MousePointer = vbHourglass
Set m_cDIBSectionSave = New cDIBSectionSave
m_cDIBSectionSave.ColourDepth = ColourDepth()
m_cDIBSectionSave.ReductionMethod = ReductionMethod()
If ReductionMethod = edssUsePalette Then
' create the palette:
Dim cP As New cPalette
Select Case True
Case optFloydStucciType(0).value
cP.CreateHalfTone
Case optFloydStucciType(1).value
cP.CreateWebSafe
End Select
Set m_cDIBSectionSave.Palette = cP
End If
m_cDIBSectionSave.Convert m_cDIB
Screen.MousePointer = vbDefault
picCurrent.Refresh
End Sub
Private Sub cmdLoad_Click()
Dim cD As New GCommonDialog
Dim sFile As String
If (cD.VBGetOpenFileName( _
Filename:=sFile, _
Filter:="All Picture Files
(*.BMP;*.JPG;*.GIF)|*.BMP;*.JPG;*.GIF|Bitmaps (*.BMP)|*.BMP|JPEGs
(*.JPG)|*.JPG|GIFs (*.GIF)|*.GIF|All Files (*.*)|*.*", _
Owner:=Me.hwnd)) Then
pLoad sFile
picCurrent.Refresh
End If
End Sub
Private Sub cmdReset_Click()
pLoad m_sFilename
picCurrent.Refresh
End Sub
Private Sub cmdSave_Click()
Dim sFile As String
Dim eD As EDSSColourDepthConstants
Dim eM As EDSSColourReductionConstants
Dim cD As New GCommonDialog
If (cD.VBGetSaveFileName( _
Filename:=sFile, _
Filter:="Bitmap Files (*.bmp)|*.BMP|All Files (*.*)|*.*", _
DefaultExt:="bmp", _
Owner:=Me.hwnd _
)) Then
m_cDIBSectionSave.Save sFile
End If
End Sub
Private Sub Form_Load()
optColourDepth_Click 3
Set m_cDIB = New cDIBSection
pLoad App.Path & "\cocksoup.jpg"
End Sub
Private Sub optColourDepth_Click(Index As Integer)
Dim i As Long
If optColourDepth(3).value Then
optReduceMethod(0).value = True
For i = 1 To 2
optReduceMethod(i).Enabled = False
Next i
Else
optReduceMethod(0).value = True
optReduceMethod(1).Enabled = True
optReduceMethod(2).Enabled = (optColourDepth(2).value)
End If
optFloydStucciType(0).Enabled = optColourDepth(2).value And
optReduceMethod(1).value
optFloydStucciType(1).Enabled = optColourDepth(2).value And
optReduceMethod(1).value
If Not (optColourDepth(2).value) Then
optFloydStucciType(0).value = False
optFloydStucciType(1).value = False
Else
If Not (optFloydStucciType(0).value Or optFloydStucciType(1).value) Then
optFloydStucciType(0).value = True
End If
End If
End Sub
Private Sub optReduceMethod_Click(Index As Integer)
optFloydStucciType(0).Enabled = (optColourDepth(2).value And
optReduceMethod(1).value)
optFloydStucciType(1).Enabled = (optColourDepth(2).value And
optReduceMethod(1).value)
End Sub
Private Sub picCurrent_Paint()
If Not m_cDIB Is Nothing Then
m_cDIB.PaintPicture picCurrent.hdc
End If
End Sub
