VB5 Bitmap Quantiser (143K)
VB6 Bitmap Quantiser (135K)
16 Apr 2004
First Posted
Subclassing Without The Crashes
Hue Luminance and Saturation (HLS) Model and Manipulating Colours
vbAccelerator - Contents of code file: frmQuantiser.frm
VERSION 5.00
Begin VB.Form frmDIBQuantiser
Caption = "vbAccelerator DIB Quantisation Demonstration"
ClientHeight = 8655
ClientLeft = 2880
ClientTop = 2790
ClientWidth = 7200
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmQuantiser.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8655
ScaleWidth = 7200
Begin VB.PictureBox picApply
BorderStyle = 0 'None
Height = 1695
Left = 1380
ScaleHeight = 1695
ScaleWidth = 3915
TabIndex = 20
Top = 6840
Width = 3915
Begin VB.CommandButton cmdPickSaveBackColor
Caption = "..."
Height = 315
Left = 3540
TabIndex = 28
Top = 900
Width = 315
End
Begin VB.PictureBox picSaveBackColor
BackColor = &H00FFFFFF&
Height = 315
Left = 2100
ScaleHeight = 255
ScaleWidth = 1395
TabIndex = 27
Top = 900
Width = 1455
End
Begin VB.CommandButton cmdApply
Caption = "&Apply"
Height = 375
Left = 1380
TabIndex = 24
Top = 1260
Width = 1155
End
Begin VB.HScrollBar hscResultScale
Height = 255
LargeChange = 2
Left = 2100
Max = 5
Min = 1
TabIndex = 23
Top = 600
Value = 2
Width = 1755
End
Begin VB.CheckBox chkColours
Alignment = 1 'Right Justify
Caption = "Keep Colours"
Height = 255
Left = 0
TabIndex = 22
Top = 0
Width = 2295
End
Begin VB.CheckBox chkLuminance
Alignment = 1 'Right Justify
Caption = "Apply Quantise Luminance"
Height = 255
Left = 0
TabIndex = 21
Top = 300
Width = 2295
End
Begin VB.Label Label1
Caption = "&Back Colour:"
Height = 255
Left = 0
TabIndex = 26
Top = 960
Width = 2235
End
Begin VB.Label lblResultScale
Caption = "&Sample Size"
Height = 195
Left = 0
TabIndex = 25
Top = 660
Width = 2235
End
End
Begin VB.PictureBox picResult
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 4035
Left = 3600
ScaleHeight = 4035
ScaleWidth = 3495
TabIndex = 16
Top = 2700
Width = 3495
Begin VB.CommandButton cmdSaveResult
BackColor = &H80000010&
Caption = "&Save..."
Enabled = 0 'False
Height = 375
Left = 2460
TabIndex = 18
Top = 60
Width = 975
End
Begin DIBQuantiser.dibViewPort picResultImage
Height = 3615
Left = 0
TabIndex = 17
Top = 420
Width = 3435
_ExtentX = 6059
_ExtentY = 6376
BorderStyle = 0
BackgroundStyle = 1
PictureAlign = 1
End
End
Begin VB.PictureBox picSource
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 4035
Left = 60
ScaleHeight = 4035
ScaleWidth = 3435
TabIndex = 13
Top = 2700
Width = 3435
Begin VB.CommandButton cmdLoadImage
BackColor = &H80000010&
Caption = "&Load..."
Height = 375
Left = 2400
TabIndex = 15
Top = 60
Width = 975
End
Begin DIBQuantiser.dibViewPort picSourceImage
Height = 3555
Left = 0
TabIndex = 14
Top = 420
Width = 3435
_ExtentX = 6059
_ExtentY = 6271
BorderStyle = 0
BackgroundStyle = 1
PictureAlign = 1
End
End
Begin VB.PictureBox picStripFrame
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 2595
Left = 60
ScaleHeight = 2595
ScaleWidth = 7095
TabIndex = 0
Top = 60
Width = 7095
Begin VB.TextBox txtFileName
BackColor = &H8000000F&
BorderStyle = 0 'None
Height = 675
Left = 720
Locked = -1 'True
MultiLine = -1 'True
TabIndex = 12
Top = 1380
Width = 2955
End
Begin VB.PictureBox picPanel
BorderStyle = 0 'None
Height = 1155
Left = 3840
ScaleHeight = 1155
ScaleWidth = 3195
TabIndex = 3
Top = 1380
Width = 3195
Begin VB.CheckBox chkAuto
Caption = "&Auto"
Height = 195
Left = 1140
TabIndex = 19
Top = 720
Value = 1 'Checked
Width = 615
End
Begin VB.HScrollBar hscImages
Height = 255
LargeChange = 4
Left = 1140
Max = 128
Min = 1
TabIndex = 7
Top = 0
Value = 16
Width = 1995
End
Begin VB.HScrollBar hscScale
Height = 255
LargeChange = 2
Left = 1140
Max = 6
TabIndex = 6
Top = 300
Value = 2
Width = 1995
End
Begin VB.PictureBox picTransparent
BackColor = &H00FFFFFF&
Height = 315
Left = 1860
ScaleHeight = 255
ScaleWidth = 915
TabIndex = 5
Top = 660
Width = 975
End
Begin VB.CommandButton cmdBackColour
Caption = "..."
Enabled = 0 'False
Height = 315
Left = 2820
TabIndex = 4
Top = 660
Width = 315
End
Begin VB.Label lblImages
Caption = "&Images"
Height = 195
Left = 0
TabIndex = 10
Top = 0
Width = 1035
End
Begin VB.Label lblScale
Caption = "&Scale"
Height = 195
Left = 0
TabIndex = 9
Top = 300
Width = 1035
End
Begin VB.Label lblBackColour
Caption = "&Transparent Colour"
Height = 375
Left = 0
TabIndex = 8
Top = 660
Width = 1035
End
End
Begin VB.CommandButton cmdLoadStrip
Caption = "&Load..."
Height = 375
Left = 660
TabIndex = 2
Top = 2040
Width = 975
End
Begin DIBQuantiser.dibViewPort picImageStrip
Height = 1035
Left = 0
TabIndex = 1
Top = 240
Width = 7035
_ExtentX = 12409
_ExtentY = 1826
BorderStyle = 0
BackgroundStyle = 1
End
Begin VB.Label lblFileName
Caption = "&File:"
Height = 195
Left = 60
TabIndex = 11
Top = 1380
Width = 555
End
End
End
Attribute VB_Name = "frmDIBQuantiser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As
RECT, ByVal hBrush As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As
Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
wFormat As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal
crColor As Long) As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hDC As Long,
ByVal nCharExtra As Long) As Long
Private Const DT_LEFT = &H0
Private Const DT_VCENTER = &H4
Private Const DT_END_ELLIPSIS = &H8000&
Private Const DT_SINGLELINE = &H20
Private m_cQuantiser As New cDibQuantiser
Private Sub pLoadStrip(ByVal sFile As String)
On Error GoTo errorHandler
Dim sPicSrc As StdPicture
txtFileName.Text = ""
Set sPicSrc = LoadPicture(sFile)
If Not (sPicSrc Is Nothing) Then
m_cQuantiser.LoadImageStrip sPicSrc
picImageStrip.DibSection = m_cQuantiser.ScaledImageStrip
picImageStrip.VerticalGridSize = m_cQuantiser.ScaledImageStrip.Height
picImageStrip.HorizontalGridSize = m_cQuantiser.ScaledImageStrip.Width \
hscImages.Value
picTransparent.BackColor = m_cQuantiser.ImageStripTransparentColor
txtFileName.Text = sFile
End If
Exit Sub
errorHandler:
MsgBox "An error occurred trying to load " & vbCrLf & sFile & vbCrLf &
vbCrLf & Err.Description, vbExclamation
Exit Sub
End Sub
Private Sub pLoadImage(ByVal sFile As String)
On Error GoTo errorHandler
Dim sPicSrc As StdPicture
Set sPicSrc = LoadPicture(sFile)
If Not (sPicSrc Is Nothing) Then
m_cQuantiser.LoadImage sPicSrc
picSourceImage.DibSection = m_cQuantiser.SourceImage
picTransparent.BackColor = m_cQuantiser.ImageStripTransparentColor
End If
Exit Sub
errorHandler:
MsgBox "An error occurred trying to load " & vbCrLf & sFile & vbCrLf &
vbCrLf & Err.Description, vbExclamation
Exit Sub
End Sub
Private Sub chkAuto_Click()
cmdBackColour.Enabled = (chkAuto.Value = vbUnchecked)
If (chkAuto.Value = vbChecked) Then
m_cQuantiser.ImageStripTransparentColor = -1
If Len(txtFileName.Text) > 0 Then
pLoadStrip txtFileName.Text
End If
End If
End Sub
Private Sub chkColours_Click()
m_cQuantiser.KeepColours = (chkColours.Value = vbChecked)
End Sub
Private Sub chkLuminance_Click()
m_cQuantiser.ApplyQuantisedLuminance = (chkLuminance.Value = vbChecked)
End Sub
Private Sub cmdApply_Click()
m_cQuantiser.Apply
picResultImage.DibSection = m_cQuantiser.ResultImage
cmdSaveResult.Enabled = Not (m_cQuantiser.ResultImage Is Nothing)
End Sub
Private Sub cmdBackColour_Click()
Dim lColor As Long
Dim cD As New cCommonDialog
If (cD.VBChooseColor(lColor, FullOpen:=True, Owner:=Me.hwnd)) Then
picTransparent.BackColor = lColor
m_cQuantiser.ImageStripTransparentColor = lColor
pLoadStrip txtFileName.Text
End If
End Sub
Private Sub cmdLoadImage_Click()
Dim sFile As String
Dim cD As New cCommonDialog
If (cD.VBGetOpenFileName(sFile, _
Filter:="Picture Files (*.BMP;*.GIF;*.JPG)|*.BMP;*.GIF;*.JPG|Bitmaps
(*,BMP)|*.BMP|GIF Files (*.GIF)|*.GIF|JPEG Files (*.JPG)|*.JPG|All Files
(*.*)|*.*", _
DefaultExt:="BMP", _
Owner:=Me.hwnd)) Then
pLoadImage sFile
End If
End Sub
Private Sub cmdLoadStrip_Click()
Dim sFile As String
Dim cD As New cCommonDialog
If (cD.VBGetOpenFileName(sFile, _
Filter:="Picture Files (*.BMP;*.GIF;*.JPG)|*.BMP;*.GIF;*.JPG|Bitmaps
(*,BMP)|*.BMP|GIF Files (*.GIF)|*.GIF|JPEG Files (*.JPG)|*.JPG|All Files
(*.*)|*.*", _
DefaultExt:="BMP", _
Owner:=Me.hwnd)) Then
pLoadStrip sFile
End If
End Sub
Private Sub cmdPickSaveBackColor_Click()
Dim cD As New cCommonDialog
Dim lColor As Long
If (cD.VBChooseColor(lColor, FullOpen:=True, Owner:=Me.hwnd)) Then
picSaveBackColor.BackColor = lColor
End If
End Sub
Private Sub cmdSaveResult_Click()
Dim sFile As String
Dim iFilterIndex As Long
Dim cD As New cCommonDialog
If (cD.VBGetSaveFileName(sFile, _
Filter:="Windows Bitmap File (*.BMP)|*.BMP|Alpha Bitmap File
(*.BMP)|*.BMP|All Files (*.*)|*.*", _
FilterIndex:=iFilterIndex, _
DefaultExt:="BMP", Owner:=Me.hwnd)) Then
If (iFilterIndex = 2) Then
m_cQuantiser.ResultImage.SavePicture sFile
Else
Dim cASave As New cAlphaDibSection
With m_cQuantiser.ResultImage
cASave.Create .Width, .Height
Dim tR As RECT
tR.right = .Width
tR.bottom = .Height
Dim hBr As Long
hBr = CreateSolidBrush(picSaveBackColor.BackColor)
FillRect cASave.hDC, tR, hBr
DeleteObject hBr
.AlphaPaintPicture cASave.hDC
cASave.SavePicture sFile
End With
End If
End If
End Sub
Private Sub Form_Load()
hscImages_Change
hscScale_Change
hscResultScale_Change
Dim sNormPath As String
sNormPath = App.Path
If Not (right(sNormPath, 1) = "\") Then
sNormPath = sNormPath & "\"
End If
pLoadStrip sNormPath & "qall_small.bmp"
pLoadImage sNormPath & "hepburn.bmp"
picImageStrip.GridLineColor = &H606060
End Sub
Private Sub Form_Resize()
Dim lWidth As Long
Dim lHeight As Long
On Error Resume Next
picStripFrame.Width = Me.ScaleWidth - picStripFrame.left * 2
lWidth = (Me.ScaleWidth - picStripFrame.left * 3) \ 2
lHeight = Me.ScaleHeight - picSource.top - picApply.Height - 4 *
Screen.TwipsPerPixelY
picSource.Move picStripFrame.left, picSource.top, lWidth, lHeight
picResult.Move picSource.left * 2 + lWidth, picSource.top, lWidth, lHeight
picApply.Move (Me.ScaleWidth - picApply.Width) \ 2, picSource.top + lHeight
+ 2 * Screen.TwipsPerPixelY
End Sub
Private Sub hscImages_Change()
lblImages.Caption = "&Images (" & hscImages.Value & ")"
m_cQuantiser.ImageStripImageCount = hscImages.Value
If Not (m_cQuantiser.ScaledImageStrip Is Nothing) Then
picImageStrip.HorizontalGridSize = m_cQuantiser.ScaledImageStrip.Width \
hscImages.Value
End If
End Sub
Private Sub hscImages_Scroll()
hscImages_Change
End Sub
Private Sub hscResultScale_Change()
'
lblResultScale.Caption = "&Sample Size (" & 2 ^ hscResultScale.Value & "
pixels)"
m_cQuantiser.PixelsPerBlock = 2 ^ hscResultScale.Value
'
End Sub
Private Sub hscResultScale_Scroll()
'
hscResultScale_Change
'
End Sub
Private Sub hscScale_Change()
'
lblScale.Caption = "&Scale (" & 100 \ 2 ^ hscScale & "%)"
m_cQuantiser.ImageStripScale = 2 ^ hscScale.Value
picImageStrip.DibSection = m_cQuantiser.ScaledImageStrip
If Not (m_cQuantiser.ScaledImageStrip Is Nothing) Then
picImageStrip.HorizontalGridSize = m_cQuantiser.ScaledImageStrip.Width \
hscImages.Value
picImageStrip.VerticalGridSize = m_cQuantiser.ScaledImageStrip.Height
End If
'
End Sub
Private Sub hscScale_Scroll()
hscScale_Change
End Sub
Private Sub picResult_Resize()
Dim tR As RECT
picResult.Cls
GetClientRect picResult.hwnd, tR
DrawThinFrame picResult.hDC, tR, 32, "Result"
picResult.Refresh
picResultImage.Move Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY,
picResult.ScaleWidth - 2 * Screen.TwipsPerPixelX, picResult.ScaleHeight -
33 * Screen.TwipsPerPixelY
cmdLoadImage.Move picResult.ScaleWidth - cmdLoadImage.Width - 5 *
Screen.TwipsPerPixelX
End Sub
Private Sub picSource_Resize()
Dim tR As RECT
picSource.Cls
GetClientRect picSource.hwnd, tR
DrawThinFrame picSource.hDC, tR, 32, "Source"
picSource.Refresh
On Error Resume Next
picSourceImage.Move Screen.TwipsPerPixelX, 32 * Screen.TwipsPerPixelY,
picSource.ScaleWidth - 2 * Screen.TwipsPerPixelX, picSource.ScaleHeight -
33 * Screen.TwipsPerPixelY
cmdSaveResult.Move picSource.ScaleWidth - cmdSaveResult.Width - 5 *
Screen.TwipsPerPixelX
End Sub
Private Sub picStripFrame_Resize()
picImageStrip.Move Screen.TwipsPerPixelX, 18 * Screen.TwipsPerPixelY,
picStripFrame.ScaleWidth - 2 * Screen.TwipsPerPixelX
Dim tR As RECT
picStripFrame.Cls
GetClientRect picStripFrame.hwnd, tR
DrawThinFrame picStripFrame.hDC, tR, 17, "Quantise Image Strip"
picStripFrame.Refresh
End Sub
Private Sub DrawThinFrame( _
ByVal lhDC As Long, _
ByRef tR As RECT, _
ByVal lTitleHeight As Long, _
ByVal sTitle As String _
)
Dim hBr As Long
hBr = CreateSolidBrush(GetSysColor(vbButtonShadow And &H1F&))
FrameRect lhDC, tR, hBr
tR.bottom = tR.top + lTitleHeight
FillRect lhDC, tR, hBr
DeleteObject hBr
SetTextColor lhDC, GetSysColor(vb3DHighlight And &H1F&)
DrawText lhDC, " " & sTitle, -1, tR, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE
End Sub